hackport 0.4.6 → 0.4.7

raw patch · 216 files changed

+21652/−10304 lines, 216 filesdep +binarydep +randomdep +stmdep ~base

Dependencies added: binary, random, stm

Dependency ranges changed: base

Files

Hackage.hs +7/−4
Main.hs +3/−1
Merge.hs +3/−3
Merge/Dependencies.hs +29/−11
Portage/Cabal.hs +5/−1
Portage/EBuild.hs +4/−2
Portage/GHCCore.hs +58/−25
Portage/Metadata.hs +7/−8
Portage/Overlay.hs +4/−4
Status.hs +1/−1
cabal/.gitignore +15/−3
cabal/.travis.yml +47/−20
cabal/Cabal/Cabal.cabal +79/−33
cabal/Cabal/Distribution/Compat/Binary.hs +60/−0
cabal/Cabal/Distribution/Compat/Binary/Class.hs +530/−0
cabal/Cabal/Distribution/Compat/Binary/Generic.hs +128/−0
cabal/Cabal/Distribution/Compat/CreatePipe.hs +62/−0
cabal/Cabal/Distribution/Compat/Environment.hs +67/−2
cabal/Cabal/Distribution/Compat/ReadP.hs +6/−2
cabal/Cabal/Distribution/Compat/TempFile.hs +8/−7
cabal/Cabal/Distribution/Compiler.hs +69/−34
cabal/Cabal/Distribution/InstalledPackageInfo.hs +150/−54
cabal/Cabal/Distribution/Lex.hs +55/−0
cabal/Cabal/Distribution/License.hs +96/−74
cabal/Cabal/Distribution/Make.hs +3/−32
cabal/Cabal/Distribution/ModuleName.hs +12/−35
cabal/Cabal/Distribution/Package.hs +217/−49
cabal/Cabal/Distribution/PackageDescription.hs +311/−97
cabal/Cabal/Distribution/PackageDescription/Check.hs +395/−166
cabal/Cabal/Distribution/PackageDescription/Configuration.hs +22/−39
cabal/Cabal/Distribution/PackageDescription/Parse.hs +165/−80
cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs +71/−80
cabal/Cabal/Distribution/ParseUtils.hs +71/−56
cabal/Cabal/Distribution/ReadE.hs +1/−31
cabal/Cabal/Distribution/Simple.hs +140/−150
cabal/Cabal/Distribution/Simple/Bench.hs +7/−36
cabal/Cabal/Distribution/Simple/Build.hs +153/−117
cabal/Cabal/Distribution/Simple/Build/Macros.hs +14/−2
cabal/Cabal/Distribution/Simple/Build/PathsModule.hs +86/−27
cabal/Cabal/Distribution/Simple/BuildPaths.hs +9/−39
cabal/Cabal/Distribution/Simple/BuildTarget.hs +24/−16
cabal/Cabal/Distribution/Simple/CCompiler.hs +4/−1
cabal/Cabal/Distribution/Simple/Command.hs +101/−93
cabal/Cabal/Distribution/Simple/Compiler.hs +150/−42
cabal/Cabal/Distribution/Simple/Configure.hs +742/−240
cabal/Cabal/Distribution/Simple/GHC.hs +1160/−1369
cabal/Cabal/Distribution/Simple/GHC/IPI641.hs +14/−37
cabal/Cabal/Distribution/Simple/GHC/IPI642.hs +14/−37
cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs +111/−0
cabal/Cabal/Distribution/Simple/GHC/Internal.hs +521/−0
cabal/Cabal/Distribution/Simple/GHCJS.hs +896/−0
cabal/Cabal/Distribution/Simple/Haddock.hs +353/−307
cabal/Cabal/Distribution/Simple/HaskellSuite.hs +8/−2
cabal/Cabal/Distribution/Simple/Hpc.hs +41/−83
cabal/Cabal/Distribution/Simple/Hugs.hs +0/−639
cabal/Cabal/Distribution/Simple/Install.hs +19/−49
cabal/Cabal/Distribution/Simple/InstallDirs.hs +92/−73
cabal/Cabal/Distribution/Simple/JHC.hs +6/−36
cabal/Cabal/Distribution/Simple/LHC.hs +48/−66
cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs +136/−58
cabal/Cabal/Distribution/Simple/NHC.hs +0/−436
cabal/Cabal/Distribution/Simple/PackageIndex.hs +112/−72
cabal/Cabal/Distribution/Simple/PreProcess.hs +98/−73
cabal/Cabal/Distribution/Simple/Program.hs +8/−8
cabal/Cabal/Distribution/Simple/Program/Ar.hs +14/−12
cabal/Cabal/Distribution/Simple/Program/Builtin.hs +75/−30
cabal/Cabal/Distribution/Simple/Program/Db.hs +69/−30
cabal/Cabal/Distribution/Simple/Program/Find.hs +1/−0
cabal/Cabal/Distribution/Simple/Program/GHC.hs +162/−65
cabal/Cabal/Distribution/Simple/Program/HcPkg.hs +111/−132
cabal/Cabal/Distribution/Simple/Program/Hpc.hs +1/−1
cabal/Cabal/Distribution/Simple/Program/Internal.hs +46/−0
cabal/Cabal/Distribution/Simple/Program/Run.hs +2/−2
cabal/Cabal/Distribution/Simple/Program/Strip.hs +32/−8
cabal/Cabal/Distribution/Simple/Program/Types.hs +20/−4
cabal/Cabal/Distribution/Simple/Register.hs +163/−122
cabal/Cabal/Distribution/Simple/Setup.hs +504/−283
cabal/Cabal/Distribution/Simple/SrcDist.hs +30/−54
cabal/Cabal/Distribution/Simple/Test.hs +41/−452
cabal/Cabal/Distribution/Simple/Test/ExeV10.hs +168/−0
cabal/Cabal/Distribution/Simple/Test/LibV09.hs +262/−0
cabal/Cabal/Distribution/Simple/Test/Log.hs +161/−0
cabal/Cabal/Distribution/Simple/UHC.hs +9/−37
cabal/Cabal/Distribution/Simple/UserHooks.hs +4/−33
cabal/Cabal/Distribution/Simple/Utils.hs +259/−143
cabal/Cabal/Distribution/System.hs +30/−16
cabal/Cabal/Distribution/TestSuite.hs +1/−30
cabal/Cabal/Distribution/Text.hs +3/−2
cabal/Cabal/Distribution/Utils/NubList.hs +100/−0
cabal/Cabal/Distribution/Verbosity.hs +9/−33
cabal/Cabal/Distribution/Version.hs +111/−37
cabal/Cabal/LICENSE +3/−2
cabal/Cabal/Language/Haskell/Extension.hs +55/−43
cabal/Cabal/Makefile +6/−22
cabal/Cabal/README +0/−179
cabal/Cabal/README.md +182/−0
cabal/Cabal/cabal.config +0/−1
cabal/Cabal/changelog +72/−2
cabal/Cabal/doc/developing-packages.markdown +206/−135
cabal/Cabal/doc/index.markdown +3/−4
cabal/Cabal/doc/installing-packages.markdown +164/−77
cabal/Cabal/doc/misc.markdown +12/−12
cabal/Cabal/misc/gen-extra-source-files.sh +1/−1
cabal/HACKING +0/−25
cabal/HACKING.md +147/−0
cabal/Paths_Cabal.hs +1/−1
cabal/Paths_cabal_install.hs +1/−1
cabal/README.md +8/−8
cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs +11/−10
cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs +54/−24
cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs +38/−24
cabal/cabal-install/Distribution/Client/Check.hs +7/−3
cabal/cabal-install/Distribution/Client/Compat/Environment.hs +0/−88
cabal/cabal-install/Distribution/Client/Compat/ExecutablePath.hs +21/−2
cabal/cabal-install/Distribution/Client/Compat/Process.hs +5/−0
cabal/cabal-install/Distribution/Client/Compat/Time.hs +20/−10
cabal/cabal-install/Distribution/Client/ComponentDeps.hs +142/−0
cabal/cabal-install/Distribution/Client/Config.hs +498/−77
cabal/cabal-install/Distribution/Client/Configure.hs +179/−53
cabal/cabal-install/Distribution/Client/Dependency.hs +270/−60
cabal/cabal-install/Distribution/Client/Dependency/Modular.hs +8/−7
cabal/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs +15/−10
cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs +75/−51
cabal/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs +2/−1
cabal/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs +21/−16
cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs +306/−73
cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs +5/−5
cabal/cabal-install/Distribution/Client/Dependency/Modular/Flag.hs +10/−11
cabal/cabal-install/Distribution/Client/Dependency/Modular/Index.hs +19/−5
cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs +88/−53
cabal/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs +523/−0
cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs +4/−1
cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs +48/−29
cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs +7/−13
cabal/cabal-install/Distribution/Client/Dependency/Modular/Package.hs +35/−23
cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs +155/−54
cabal/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs +21/−10
cabal/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs +50/−46
cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs +31/−19
cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs +185/−52
cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs +14/−15
cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs +58/−6
cabal/cabal-install/Distribution/Client/Dependency/Types.hs +125/−34
cabal/cabal-install/Distribution/Client/Exec.hs +133/−0
cabal/cabal-install/Distribution/Client/Fetch.hs +19/−12
cabal/cabal-install/Distribution/Client/FetchUtils.hs +18/−13
cabal/cabal-install/Distribution/Client/Freeze.hs +102/−31
cabal/cabal-install/Distribution/Client/GZipUtils.hs +46/−4
cabal/cabal-install/Distribution/Client/Get.hs +15/−8
cabal/cabal-install/Distribution/Client/Haddock.hs +14/−53
cabal/cabal-install/Distribution/Client/HttpUtils.hs +636/−107
cabal/cabal-install/Distribution/Client/IndexUtils.hs +99/−125
cabal/cabal-install/Distribution/Client/Init.hs +207/−63
cabal/cabal-install/Distribution/Client/Init/Heuristics.hs +80/−20
cabal/cabal-install/Distribution/Client/Init/Licenses.hs +570/−99
cabal/cabal-install/Distribution/Client/Init/Types.hs +7/−1
cabal/cabal-install/Distribution/Client/Install.hs +357/−198
cabal/cabal-install/Distribution/Client/InstallPlan.hs +320/−260
cabal/cabal-install/Distribution/Client/InstallSymlink.hs +56/−34
cabal/cabal-install/Distribution/Client/List.hs +68/−28
cabal/cabal-install/Distribution/Client/PackageIndex.hs +20/−201
cabal/cabal-install/Distribution/Client/ParseUtils.hs +9/−4
cabal/cabal-install/Distribution/Client/PlanIndex.hs +339/−0
cabal/cabal-install/Distribution/Client/Run.hs +98/−23
cabal/cabal-install/Distribution/Client/Sandbox.hs +88/−49
cabal/cabal-install/Distribution/Client/Sandbox/Index.hs +10/−5
cabal/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs +109/−76
cabal/cabal-install/Distribution/Client/Sandbox/Timestamp.hs +22/−18
cabal/cabal-install/Distribution/Client/Sandbox/Types.hs +4/−1
cabal/cabal-install/Distribution/Client/Setup.hs +754/−140
cabal/cabal-install/Distribution/Client/SetupWrapper.hs +189/−36
cabal/cabal-install/Distribution/Client/SrcDist.hs +2/−5
cabal/cabal-install/Distribution/Client/Tar.hs +7/−8
cabal/cabal-install/Distribution/Client/Targets.hs +48/−25
cabal/cabal-install/Distribution/Client/Types.hs +119/−56
cabal/cabal-install/Distribution/Client/Update.hs +24/−42
cabal/cabal-install/Distribution/Client/Upload.hs +39/−115
cabal/cabal-install/Distribution/Client/Utils.hs +80/−3
cabal/cabal-install/Distribution/Client/Utils/LabeledGraph.hs +116/−0
cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs +16/−11
cabal/cabal-install/Distribution/Client/World.hs +3/−5
cabal/cabal-install/Main.hs +381/−156
cabal/cabal-install/README +0/−143
cabal/cabal-install/README.md +155/−0
cabal/cabal-install/bash-completion/cabal +51/−1
cabal/cabal-install/bootstrap.sh +265/−76
cabal/cabal-install/cabal-install.cabal +87/−21
cabal/cabal-install/cabal.config +0/−1
cabal/cabal-install/changelog +68/−0
cabal/cabal-install/tests/PackageTests.hs +95/−0
cabal/cabal-install/tests/PackageTests/Exec/Check.hs +145/−0
cabal/cabal-install/tests/PackageTests/Exec/Foo.hs +4/−0
cabal/cabal-install/tests/PackageTests/Exec/My.hs +5/−0
cabal/cabal-install/tests/PackageTests/Exec/my.cabal +14/−0
cabal/cabal-install/tests/PackageTests/Exec/subdir/.gitkeep +0/−0
cabal/cabal-install/tests/PackageTests/Freeze/Check.hs +116/−0
cabal/cabal-install/tests/PackageTests/Freeze/my.cabal +21/−0
cabal/cabal-install/tests/PackageTests/MultipleSource/Check.hs +28/−0
cabal/cabal-install/tests/PackageTests/MultipleSource/p/LICENSE +0/−0
cabal/cabal-install/tests/PackageTests/MultipleSource/p/Setup.hs +2/−0
cabal/cabal-install/tests/PackageTests/MultipleSource/p/p.cabal +11/−0
cabal/cabal-install/tests/PackageTests/MultipleSource/q/LICENSE +0/−0
cabal/cabal-install/tests/PackageTests/MultipleSource/q/Setup.hs +2/−0
cabal/cabal-install/tests/PackageTests/MultipleSource/q/q.cabal +11/−0
cabal/cabal-install/tests/PackageTests/PackageTester.hs +232/−0
cabal/cabal-install/tests/UnitTests.hs +23/−5
cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs +322/−0
cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/PSQ.hs +3/−3
cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs +360/−0
cabal/cabal-install/tests/UnitTests/Distribution/Client/GZipUtils.hs +60/−0
cabal/cabal-install/tests/UnitTests/Distribution/Client/Sandbox.hs +5/−6
cabal/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs +3/−4
cabal/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs +103/−0
cabal/setup-dev.sh +50/−0
cabal/stack.yaml +39/−0
hackport.cabal +21/−23

Hackage.hs view

@@ -17,13 +17,16 @@ defaultRepo :: FilePath -> Repo defaultRepo overlayPath =   Repo {-      repoKind = Left hackage,+      repoKind = Left defaultRemoteRepo,       repoLocalDir = overlayPath </> ".hackport"     }++-- A copy from cabal-install/Distribution.Client.Config+defaultRemoteRepo :: RemoteRepo+defaultRemoteRepo = RemoteRepo name uri () False   where-    hackage = RemoteRepo server_name uri-    server_name = "hackage.haskell.org"-    uri  = URI "http:" (Just (URIAuth "" server_name "")) "/packages/archive" "" ""+    name = "hackage.haskell.org"+    uri  = URI "http:" (Just (URIAuth "" name "")) "/" "" ""  defaultRepoURI :: FilePath -> URI defaultRepoURI overlayPath =

Main.hs view

@@ -24,6 +24,7 @@  import Distribution.Client.Types import Distribution.Client.Update+import qualified Distribution.Client.HttpUtils as DCH  import qualified Distribution.Client.PackageIndex as Index import qualified Distribution.Client.IndexUtils as Index@@ -300,7 +301,8 @@     die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs   let verbosity = fromFlag (updateVerbosity flags)   overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)-  update verbosity [ defaultRepo overlayPath ]+  http_transport <- DCH.configureTransport verbosity Nothing+  update http_transport verbosity [ defaultRepo overlayPath ]     -----------------------------------------------------------------------

Merge.hs view

@@ -204,7 +204,7 @@       (user_specified_fas, cf_to_iuse_rename) = read_fas requested_cabal_flags    debug verbosity "searching for minimal suitable ghc version"-  (compilerId, ghc_packages, pkgDesc0, _flags, pix) <- case GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc user_specified_fas of+  (compiler_info, ghc_packages, pkgDesc0, _flags, pix) <- case GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc user_specified_fas of               Just v  -> return v               Nothing -> let pn = display merged_cabal_pkg_name                              cn = display cat@@ -252,7 +252,7 @@                , Right (pkgDesc1,fr) <- [GHCCore.finalizePackageDescription f                                                                   (GHCCore.dependencySatisfiable pix)                                                                   GHCCore.platform-                                                                  compilerId+                                                                  compiler_info                                                                   []                                                                   pkgGenericDesc]                -- drop circular deps and shipped deps@@ -330,7 +330,7 @@                        in k e        cabal_to_emerge_dep :: Cabal.PackageDescription -> Merge.EDep-      cabal_to_emerge_dep cabal_pkg = Merge.resolveDependencies overlay cabal_pkg compilerId ghc_packages merged_cabal_pkg_name+      cabal_to_emerge_dep cabal_pkg = Merge.resolveDependencies overlay cabal_pkg compiler_info ghc_packages merged_cabal_pkg_name    debug verbosity $ "buildDepends pkgDesc0 raw: " ++ Cabal.showPackageDescription pkgDesc0   debug verbosity $ "buildDepends pkgDesc0: " ++ show (map display (Cabal.buildDepends pkgDesc0))

Merge/Dependencies.hs view

@@ -107,10 +107,10 @@     , dep_e  = dep_eA  `S.union` dep_eB     } -resolveDependencies :: Portage.Overlay -> PackageDescription -> Cabal.CompilerId+resolveDependencies :: Portage.Overlay -> PackageDescription -> Cabal.CompilerInfo                     -> [Cabal.PackageName] -> Cabal.PackageName                     -> EDep-resolveDependencies overlay pkg compiler ghc_package_names merged_cabal_pkg_name = edeps+resolveDependencies overlay pkg compiler_info ghc_package_names merged_cabal_pkg_name = edeps   where     -- hasBuildableExes p = any (buildable . buildInfo) . executables $ p     treatAsLibrary :: Bool@@ -126,9 +126,9 @@                     map PN.normalize_depend $                     testDependencies overlay pkg ghc_package_names merged_cabal_pkg_name     cabal_dep :: Portage.Dependency-    cabal_dep = cabalDependency overlay pkg compiler+    cabal_dep = cabalDependency overlay pkg compiler_info     ghc_dep :: Portage.Dependency-    ghc_dep = compilerIdToDependency compiler+    ghc_dep = compilerInfoToDependency compiler_info     extra_libs :: Portage.Dependency     extra_libs = Portage.DependAllOf $ findCLibs pkg     pkg_config_libs :: [Portage.Dependency]@@ -197,8 +197,11 @@  -- | Select the most restrictive dependency on Cabal, either the .cabal -- file's descCabalVersion, or the Cabal GHC shipped with.-cabalDependency :: Portage.Overlay -> PackageDescription -> Cabal.CompilerId -> Portage.Dependency-cabalDependency overlay pkg ~(Cabal.CompilerId Cabal.GHC _ghcVersion@(Cabal.Version versionNumbers _)) =+cabalDependency :: Portage.Overlay -> PackageDescription -> Cabal.CompilerInfo -> Portage.Dependency+cabalDependency overlay pkg ~(Cabal.CompilerInfo {+                                  Cabal.compilerInfoId =+                                      Cabal.CompilerId Cabal.GHC (Cabal.Version versionNumbers _)+                              }) =          C2E.convertDependency overlay                                (Portage.Category "dev-haskell")                                (Cabal.Dependency (Cabal.PackageName "Cabal")@@ -216,8 +219,10 @@ -- GHC Dependency --------------------------------------------------------------- -compilerIdToDependency :: Cabal.CompilerId -> Portage.Dependency-compilerIdToDependency ~(Cabal.CompilerId Cabal.GHC versionNumbers) =+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)  ---------------------------------------------------------------@@ -344,6 +349,14 @@       , ("Xrender", any_c_p "x11-libs" "libXrender")       , ("Xcursor", any_c_p "x11-libs" "libXcursor")       , ("Xinerama", any_c_p "x11-libs" "libXinerama")+      , ("wayland-client", any_c_p "dev-libs" "wayland")+      , ("wayland-cursor", any_c_p "dev-libs" "wayland")+      , ("wayland-server", any_c_p "dev-libs" "wayland")+      , ("wayland-egl", any_c_p_s_u "media-libs" "mesa" Portage.AnySlot [Portage.mkUse (Portage.Use "wayland")])+      , ("xkbcommon", any_c_p "x11-libs" "libxkbcommon")+      , ("SDL_gfx", any_c_p "media-libs" "sdl-gfx")+      , ("SDL_image", any_c_p "media-libs" "sdl-image")+      , ("SDL_ttf", any_c_p "media-libs" "sdl-ttf")       ]  ---------------------------------------------------------------@@ -370,14 +383,15 @@   [ ("happy", any_c_p "dev-haskell" "happy")   , ("alex", any_c_p "dev-haskell" "alex")   , ("c2hs", any_c_p "dev-haskell" "c2hs")+  , ("cabal",               any_c_p "dev-haskell" "cabal-install")   , ("cabal-install", any_c_p "dev-haskell" "cabal-install")+  , ("cpphs",               any_c_p "dev-haskell" "cpphs")+  , ("ghc",                 any_c_p "dev-lang" "ghc")   , ("gtk2hsTypeGen",       any_c_p "dev-haskell" "gtk2hs-buildtools")   , ("gtk2hsHookGenerator", any_c_p "dev-haskell" "gtk2hs-buildtools")   , ("gtk2hsC2hs",          any_c_p "dev-haskell" "gtk2hs-buildtools")-  , ("cabal",               any_c_p "dev-haskell" "cabal-install")+  , ("hsb2hs",              any_c_p "dev-haskell" "hsb2hs")   , ("llvm-config",         any_c_p "sys-devel" "llvm")-  , ("cpphs",               any_c_p "dev-haskell" "cpphs")-  , ("ghc",                 any_c_p "dev-lang" "ghc")   ]  -- tools that are provided by ghc or some other existing program@@ -427,6 +441,7 @@    ,("gtk+-2.0",            ("x11-libs", "gtk+", Portage.GivenSlot "2"))   ,("gdk-2.0",             ("x11-libs", "gtk+", Portage.GivenSlot "2"))+  ,("gdk-3.0",             ("x11-libs", "gtk+", Portage.GivenSlot "3"))   ,("gdk-pixbuf-2.0",      ("x11-libs", "gtk+", Portage.GivenSlot "2"))   ,("gdk-pixbuf-xlib-2.0", ("x11-libs", "gtk+", Portage.GivenSlot "2"))   ,("gdk-x11-2.0",         ("x11-libs", "gtk+", Portage.GivenSlot "2"))@@ -455,6 +470,7 @@   ,("gnome-vfs-2.0", ("gnome-base", "gnome-vfs", Portage.AnySlot))   ,("gnome-vfs-module-2.0", ("gnome-base", "gnome-vfs", Portage.AnySlot))   ,("webkit-1.0", ("net-libs","webkit-gtk", Portage.GivenSlot "2"))+  ,("gtksourceview-3.0", ("x11-libs", "gtksourceview", Portage.GivenSlot "3.0"))    ,("gstreamer-0.10",              ("media-libs", "gstreamer", Portage.AnySlot))   ,("gstreamer-base-0.10",         ("media-libs", "gstreamer", Portage.AnySlot))@@ -499,4 +515,6 @@   ,("taglib_c",                    ("media-libs", "taglib", Portage.AnySlot))   ,("libcurl",                     ("net-misc", "curl", Portage.AnySlot))   ,("libpq",                       ("dev-db", "postgresql", Portage.AnySlot))+  ,("poppler-glib",                ("app-text", "poppler", Portage.AnySlot))+  ,("gsl",                         ("sci-libs", "gsl", Portage.AnySlot))   ]

Portage/Cabal.hs view

@@ -29,15 +29,19 @@         Cabal.AGPL mv      -> Right $ "AGPL-" ++ (maybe "3" Cabal.display mv)  -- almost certainly version 3         Cabal.GPL mv       -> Right $ "GPL-" ++ (maybe "2" Cabal.display mv)  -- almost certainly version 2         Cabal.LGPL mv      -> Right $ "LGPL-" ++ (maybe "2.1" Cabal.display mv) -- probably version 2.1+        Cabal.BSD2         -> Right "BSD-2"         Cabal.BSD3         -> Right "BSD"         Cabal.BSD4         -> Right "BSD-4"         Cabal.PublicDomain -> Right "public-domain"         Cabal.MIT          -> Right "MIT"         Cabal.Apache mv    -> Right $ "Apache-" ++ (maybe "1.1" Cabal.display mv) -- probably version 1.1+        Cabal.ISC          -> Right "ISC"+        Cabal.MPL v        -> Right $ "MPL-" ++ Cabal.display v -- probably version 1.0         -- bad ones         Cabal.AllRightsReserved -> Left "EULA-style licence. Please pick it manually."         Cabal.UnknownLicense _  -> Left "license unknown to cabal. Please pick it manually."-        Cabal.OtherLicense      -> Left "Please look at license file of package and pick it manually."+        Cabal.OtherLicense      -> Left "(Other) Please look at license file of package and pick it manually."+        Cabal.UnspecifiedLicense -> Left "(Unspecified) Please look at license file of package and pick it manually."  partition_depends :: [Cabal.PackageName] -> Cabal.PackageName -> [Cabal.Dependency] -> ([Cabal.Dependency], [Cabal.Dependency]) partition_depends ghc_package_names merged_cabal_pkg_name = L.partition (not . is_internal_depend)

Portage/EBuild.hs view

@@ -109,7 +109,7 @@      Just pn -> ss "MY_PN=". quote pn. nl.                 ss "MY_P=". quote "${MY_PN}-${PV}". nl. nl).   ss "DESCRIPTION=". quote (drop_tdot $ description ebuild). nl.-  ss "HOMEPAGE=". quote (expandVars (homepage ebuild)). nl.+  ss "HOMEPAGE=". quote (toHttps $ expandVars (homepage ebuild)). nl.   ss "SRC_URI=". quote (toMirror $ src_uri ebuild). nl.   nl.   ss "LICENSE=". (either (\err -> quote "" . ss ("\t# FIXME: " ++ err))@@ -148,7 +148,7 @@             ss "}" . nl).    if_games (nl . ss "pkg_postinst() {" . nl.-            ss (tabify_line " ghc-package_pkg_postinst") . nl.+            ss (tabify_line " haskell-cabal_pkg_postinst") . nl.             ss (tabify_line " games_pkg_postinst") . nl.             ss "}" . nl). @@ -158,6 +158,8 @@                                       , (hackage_name ebuild, "${HACKAGE_N}")                                       ]         toMirror = replace "http://hackage.haskell.org/" "mirror://hackage/"+        -- TODO: this needs to be more generic+        toHttps  = replace "http://github.com/" "https://github.com/"         this_year :: String         this_year = TC.formatTime TC.defaultTimeLocale "%Y" now         if_games :: DString -> DString

Portage/GHCCore.hs view

@@ -8,10 +8,11 @@         , dependencySatisfiable         ) where +import qualified Distribution.Compiler as DC import Distribution.Package import Distribution.Version import Distribution.Simple.PackageIndex-import Distribution.InstalledPackageInfo+import Distribution.InstalledPackageInfo as IPI  import Distribution.PackageDescription import Distribution.PackageDescription.Configuration@@ -28,9 +29,9 @@  -- ghcs tried in specified order. -- It means that first ghc in this list is a minmum default.-ghcs :: [(CompilerId, PackageIndex)]+ghcs :: [(DC.CompilerInfo, InstalledPackageIndex)] ghcs = modern_ghcs-    where modern_ghcs  = [ghc741, ghc742, ghc761, ghc762, ghc782, ghc7101]+    where modern_ghcs  = [ghc741, ghc742, ghc761, ghc762, ghc782, ghc7101, ghc7102]  cabalFromGHC :: [Int] -> Maybe Version cabalFromGHC ver = lookup ver table@@ -40,12 +41,13 @@           , ([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] [])           ]  platform :: Platform platform = Platform X86_64 Linux -packageIsCore :: PackageIndex -> PackageName -> Bool+packageIsCore :: InstalledPackageIndex -> PackageName -> Bool packageIsCore index pn = not . null $ lookupPackageName index pn  packageIsCoreInAnyGHC :: PackageName -> Bool@@ -55,7 +57,7 @@ -- 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 :: PackageIndex -> Dependency -> Bool+dependencySatisfiable :: InstalledPackageIndex -> Dependency -> Bool dependencySatisfiable pindex dep@(Dependency pn _rang)   | pn == PackageName "Win32" = False -- only exists on windows, not in linux   | not . null $ lookupDependency pindex dep = True -- the package index satisfies the dep@@ -65,67 +67,98 @@ packageBuildableWithGHCVersion   :: GenericPackageDescription   -> FlagAssignment-  -> (CompilerId, PackageIndex)+  -> (DC.CompilerInfo, InstalledPackageIndex)   -> Either [Dependency] (PackageDescription, FlagAssignment)-packageBuildableWithGHCVersion pkg user_specified_fas (compiler, pkgIndex) = trace_failure $-  finalizePackageDescription user_specified_fas (dependencySatisfiable pkgIndex) platform compiler [] pkg+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-              (Left deps) -> trace (unwords ["rejecting dep:" , show_compiler compiler+              (Left deps) -> trace (unwords ["rejecting dep:" , show_compiler compiler_info                                             , "as", show_deps deps                                             , "were not found."                                             ]                                    ) v-              _           -> trace (unwords ["accepting dep:" , show_compiler compiler+              _           -> trace (unwords ["accepting dep:" , show_compiler compiler_info                                             ]                                    ) v           show_deps = show . map display-          show_compiler (CompilerId GHC v) = "ghc-" ++ showVersion v+          show_compiler (DC.CompilerInfo { DC.compilerInfoId = CompilerId GHC v }) = "ghc-" ++ showVersion 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 (CompilerId, [PackageName], PackageDescription, FlagAssignment, PackageIndex)+minimumGHCVersionToBuildPackage :: GenericPackageDescription -> FlagAssignment -> Maybe (DC.CompilerInfo, [PackageName], PackageDescription, FlagAssignment, InstalledPackageIndex) minimumGHCVersionToBuildPackage gpd user_specified_fas =-  listToMaybe [ (cid, packageNamesFromPackageIndex pix, pkg_desc, picked_flags, pix)-              | g@(cid, pix) <- ghcs+  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] -> PackageIndex+mkIndex :: [PackageIdentifier] -> InstalledPackageIndex mkIndex pids = fromList   [ emptyInstalledPackageInfo-      { installedPackageId = InstalledPackageId $ display name ++ "-" ++  display version+      { IPI.installedPackageId = InstalledPackageId $ display name ++ "-" ++  display version       , sourcePackageId = pindex       , exposed = True       }   | pindex@(PackageIdentifier name version) <- pids ] -packageNamesFromPackageIndex :: PackageIndex -> [PackageName]+packageNamesFromPackageIndex :: InstalledPackageIndex -> [PackageName] packageNamesFromPackageIndex pix = nub $ map fst $ allPackagesByName pix -ghc :: [Int] -> CompilerId-ghc nrs = CompilerId GHC (Version nrs [])+ghc :: [Int] -> DC.CompilerInfo+ghc nrs = DC.unknownCompilerInfo c_id DC.NoAbiTag+    where c_id = CompilerId GHC (Version nrs []) -ghc7101 :: (CompilerId, PackageIndex)+ghc7102 :: (DC.CompilerInfo, InstalledPackageIndex)+ghc7102 = (ghc [7,10,2], mkIndex ghc7102_pkgs)++ghc7101 :: (DC.CompilerInfo, InstalledPackageIndex) ghc7101 = (ghc [7,10,1], mkIndex ghc7101_pkgs) -ghc782 :: (CompilerId, PackageIndex)+ghc782 :: (DC.CompilerInfo, InstalledPackageIndex) ghc782 = (ghc [7,8,2], mkIndex ghc782_pkgs) -ghc762 :: (CompilerId, PackageIndex)+ghc762 :: (DC.CompilerInfo, InstalledPackageIndex) ghc762 = (ghc [7,6,2], mkIndex ghc762_pkgs) -ghc761 :: (CompilerId, PackageIndex)+ghc761 :: (DC.CompilerInfo, InstalledPackageIndex) ghc761 = (ghc [7,6,1], mkIndex ghc761_pkgs) -ghc742 :: (CompilerId, PackageIndex)+ghc742 :: (DC.CompilerInfo, InstalledPackageIndex) ghc742 = (ghc [7,4,2], mkIndex ghc742_pkgs) -ghc741 :: (CompilerId, PackageIndex)+ghc741 :: (DC.CompilerInfo, InstalledPackageIndex) ghc741 = (ghc [7,4,1], mkIndex ghc741_pkgs)  -- | Non-upgradeable core packages -- Source: http://haskell.org/haskellwiki/Libraries_released_with_GHC --         and our binary tarballs (package.conf.d.initial subdir)++ghc7102_pkgs :: [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 "bytestring" [0,10,6,0]+--  , p "Cabal" [1,18,1,3]  package is upgradeable+  , p "containers" [0,5,6,2]+  , p "deepseq" [1,4,1,1] -- used by time+  , p "directory" [1,2,2,0]+  , p "filepath" [1,4,0,0]+  , p "ghc-prim" [0,4,0,0]+  -- , p "haskell2010" [1,1,2,0] -- stopped shipping in 7.10, deprecated+  -- , p "haskell98" [2,0,0,3] -- stopped shipping in 7.10, deprecated+  , p "hoopl" [3,10,1,0] -- used by libghc+  , p "hpc" [0,6,0,2] -- used by libghc+  , p "integer-gmp" [1,0,0,0]+  -- , p "old-locale" [1,0,0,6] -- stopped shipping in 7.10, deprecated+  -- , p "old-time" [1,1,0,2] -- stopped shipping in 7.10, deprecated+  , p "pretty" [1,1,2,0]+  , 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 "unix" [2,7,1,0]+  ]  ghc7101_pkgs :: [PackageIdentifier] ghc7101_pkgs =

Portage/Metadata.hs view

@@ -11,7 +11,7 @@ import Text.XML.Light  data Metadata = Metadata-      { metadataHerds :: [String]+      { metadata_emails :: [String]       -- , metadataMaintainers :: [String],       -- , metadataUseFlags :: [(String,String)]       } deriving (Show)@@ -22,12 +22,8 @@   return (doc >>= parseMetadata)  parseMetadata :: Element -> Maybe Metadata-parseMetadata xml = do-  let herds = map strContent (findChildren (unqual "herd") xml)-  return Metadata-            {-              metadataHerds = herds-            }+parseMetadata xml =+  return Metadata { metadata_emails = map strContent (findElements (unqual "email") xml) }  -- don't use Text.XML.Light as we like our own pretty printer makeDefaultMetadata :: String -> String@@ -35,7 +31,10 @@     unlines [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"             , "<!DOCTYPE pkgmetadata SYSTEM \"http://www.gentoo.org/dtd/metadata.dtd\">"             , "<pkgmetadata>"-            , "\t<herd>haskell</herd>"+            , "\t<maintainer type=\"project\">"+            , "\t\t<email>haskell@gentoo.org</email>"+            , "\t\t<name>Gentoo Haskell</name>"+            , "\t</maintainer>"             , (init {- strip trailing newline-}               . unlines               . map (\l -> if l `elem` ["<longdescription>", "</longdescription>"]

Portage/Overlay.hs view

@@ -6,7 +6,7 @@   , getDirectoryTree, DirectoryTree    , reduceOverlay-  , filterByHerd+  , filterByEmail   , inOverlay   )   where@@ -96,13 +96,13 @@         , File "metadata.xml" <- files         ] -filterByHerd :: ([String] -> Bool) -> Overlay -> Overlay-filterByHerd p overlay = overlay+filterByEmail :: ([String] -> Bool) -> Overlay -> Overlay+filterByEmail p overlay = overlay                             { overlayMetadata = metadataMap'                             , overlayMap = pkgMap'                             }   where-    metadataMap' = Map.filter (p . Portage.metadataHerds) (overlayMetadata overlay)+    metadataMap' = Map.filter (p . Portage.metadata_emails) (overlayMetadata overlay)     pkgMap' = Map.intersection (overlayMap overlay) metadataMap'

Status.hs view

@@ -94,7 +94,7 @@     let repo = defaultRepo overlaydir     overlay <- loadLazy overlaydir     hackage <- loadHackage verbosity repo overlay-    portage <- filterByHerd ("haskell" `elem`) <$> loadLazy portdir+    portage <- filterByEmail ("haskell@gentoo.org" `elem`) <$> loadLazy portdir     let (over, both, port) = portageDiff (overlayMap overlay) (overlayMap portage)      both' <- T.forM both $ mapM $ \e -> do

cabal/.gitignore view

@@ -2,16 +2,24 @@ .cabal-sandbox/ cabal.sandbox.config cabal-dev/-Cabal/dist/-Cabal/tests/Setup-cabal-install/dist/ .hpc/ *.hi *.o *.p_hi *.prof *.tix+cabal.config+dist+dist-* +/Cabal/dist/+/Cabal/tests/Setup+/Cabal/Setup++/cabal-install/dist/+/cabal-install/Setup++ # editor temp files  *#@@ -29,3 +37,7 @@  # TAGS files TAGS+tags++# stack artifacts+/.stack-work/

cabal/.travis.yml view

@@ -2,42 +2,69 @@  # 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.0.4  - GHCVER=7.4.2  - GHCVER=7.6.3+ - GHCVER=7.8.4+ - GHCVER=7.10.1  - GHCVER=head  # Note: the distinction between `before_install` and `install` is not important. before_install:- - sudo add-apt-repository -y ppa:hvr/ghc- - sudo apt-get update- - sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy- - export PATH=/opt/ghc/$GHCVER/bin:$PATH- - export CABAL_TEST_RUNNING_ON_TRAVIS=1+ - 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.22 ghc-$GHCVER-prof ghc-$GHCVER-dyn happy+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH  install:- - sudo /opt/ghc/$GHCVER/bin/ghc-pkg recache- - cabal-1.18 update- - cd Cabal- - cabal-1.18 install --only-dependencies --enable-tests --enable-benchmarks+ - 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.  # Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.+# Using ./dist/setup/setup here instead of cabal-install to avoid breakage+# when the build config format changed script:- - cabal-1.18 configure --enable-tests --enable-benchmarks -v2  # -v2 provides useful information for debugging- - cabal-1.18 build   # this builds all libraries and executables (including tests/benchmarks)- - cabal-1.18 test- - cabal-1.18 check- - cabal-1.18 sdist   # tests that a source-distribution can be generated+ - cd Cabal+ - mkdir -p ./dist/setup+ - cp Setup.hs ./dist/setup/setup.hs+# Should be able to build setup without extra dependencies+ - /opt/ghc/$GHCVER/bin/ghc --make -odir ./dist/setup -hidir ./dist/setup -i -i. ./dist/setup/setup.hs -o ./dist/setup/setup -Wall -Werror -threaded  # the command cabal-install would use to build setup +# Need extra dependencies for test suite+ - cabal install --only-dependencies --enable-tests+ - sudo /opt/ghc/$GHCVER/bin/ghc-pkg recache+ - /opt/ghc/$GHCVER/bin/ghc-pkg recache --user++ - ./dist/setup/setup configure --user --enable-tests --enable-benchmarks --ghc-option=-Werror -v2  # -v2 provides useful information for debugging+ - ./dist/setup/setup build   # this builds all libraries and executables (including tests/benchmarks)+ - ./dist/setup/setup haddock # see #2198+ - ./dist/setup/setup test --show-details=streaming+ - 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- - export SRC_TGZ=$(cabal-1.18 info . | awk '{print $2 ".tar.gz";exit}') ;-   cd dist/;-   if [ -f "$SRC_TGZ" ]; then-      cabal-1.18 install "$SRC_TGZ";+ - function install_from_tarball {+   export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;+   if [ -f "dist/$SRC_TGZ" ]; then+      cabal install "dist/$SRC_TGZ" -v2;    else-      echo "expected '$SRC_TGZ' not found";+      echo "expected 'dist/$SRC_TGZ' not found";       exit 1;    fi+   }+ - install_from_tarball++# Also build cabal-install.+ - cd ../cabal-install+ - cabal sandbox init+ - cabal sandbox add-source ../Cabal+ - cabal install --dependencies-only --enable-tests+ - cabal configure --enable-tests --ghc-option=-Werror+ - cabal build+ - cabal test+ - cabal check+ - cabal sdist+ - install_from_tarball  matrix:   allow_failures:

cabal/Cabal/Cabal.cabal view

@@ -1,5 +1,5 @@ name: Cabal-version: 1.19.2+version: 1.23.0.0 copyright: 2003-2006, Isaac Jones            2005-2011, Duncan Coutts license: BSD3@@ -24,7 +24,10 @@ -- that we build Setup.lhs using our own local Cabal source code.  extra-source-files:-  README tests/README changelog+  README.md tests/README.md changelog+  doc/developing-packages.markdown doc/index.markdown+  doc/installing-packages.markdown+  doc/misc.markdown    -- Generated with 'misc/gen-extra-source-files.sh' & 'M-x sort-lines':   tests/PackageTests/BenchmarkExeV10/Foo.hs@@ -71,8 +74,6 @@   tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs   tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs   tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal-  tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs-  tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal   tests/PackageTests/CMain/Bar.hs   tests/PackageTests/CMain/Setup.hs   tests/PackageTests/CMain/foo.c@@ -80,6 +81,11 @@   tests/PackageTests/DeterministicAr/Lib.hs   tests/PackageTests/DeterministicAr/my.cabal   tests/PackageTests/EmptyLib/empty/empty.cabal+  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/OrderFlags/Foo.hs   tests/PackageTests/OrderFlags/my.cabal   tests/PackageTests/PathsModule/Executable/Main.hs@@ -88,6 +94,7 @@   tests/PackageTests/PreProcess/Foo.hsc   tests/PackageTests/PreProcess/Main.hs   tests/PackageTests/PreProcess/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@@ -103,9 +110,12 @@   tests/PackageTests/TestOptions/TestOptions.cabal   tests/PackageTests/TestOptions/test-TestOptions.hs   tests/PackageTests/TestStanza/my.cabal-  tests/PackageTests/TestSuiteExeV10/Foo.hs-  tests/PackageTests/TestSuiteExeV10/my.cabal-  tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs+  tests/PackageTests/TestSuiteTests/ExeV10/Foo.hs+  tests/PackageTests/TestSuiteTests/ExeV10/my.cabal+  tests/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs+  tests/PackageTests/TestSuiteTests/LibV09/LibV09.cabal+  tests/PackageTests/TestSuiteTests/LibV09/Lib.hs+  tests/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs   tests/Setup.hs   tests/hackage/check.sh   tests/hackage/download.sh@@ -117,19 +127,31 @@   location: https://github.com/haskell/cabal/   subdir:   Cabal +flag bundled-binary-generic+  default: False+ library   build-depends:-    base       >= 4       && < 5,-    deepseq    >= 1.3     && < 1.4,-    filepath   >= 1       && < 1.4,-    directory  >= 1       && < 1.3,-    process    >= 1.0.1.1 && < 1.3,-    time       >= 1.1     && < 1.5,-    containers >= 0.1     && < 0.6,-    array      >= 0.1     && < 0.6,-    pretty     >= 1       && < 1.2,+    base       >= 4.4 && < 5,+    deepseq    >= 1.3 && < 1.5,+    filepath   >= 1   && < 1.5,+    directory  >= 1   && < 1.3,+    process    >= 1.1.0.1 && < 1.4,+    time       >= 1.1 && < 1.6,+    containers >= 0.1 && < 0.6,+    array      >= 0.1 && < 0.6,+    pretty     >= 1   && < 1.2,     bytestring >= 0.9 +  if flag(bundled-binary-generic)+    build-depends: binary >= 0.5 && < 0.7+  else+    build-depends: binary >= 0.7 && < 0.8++  -- Needed for GHC.Generics before GHC 7.6+  if impl(ghc < 7.6)+    build-depends: ghc-prim >= 0.2 && < 0.3+   if !os(windows)     build-depends:       unix >= 2.0 && < 2.8@@ -137,6 +159,7 @@   ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs    exposed-modules:+    Distribution.Compat.CreatePipe     Distribution.Compat.Environment     Distribution.Compat.Exception     Distribution.Compat.ReadP@@ -166,16 +189,15 @@     Distribution.Simple.Compiler     Distribution.Simple.Configure     Distribution.Simple.GHC+    Distribution.Simple.GHCJS     Distribution.Simple.Haddock     Distribution.Simple.HaskellSuite     Distribution.Simple.Hpc-    Distribution.Simple.Hugs     Distribution.Simple.Install     Distribution.Simple.InstallDirs     Distribution.Simple.JHC     Distribution.Simple.LHC     Distribution.Simple.LocalBuildInfo-    Distribution.Simple.NHC     Distribution.Simple.PackageIndex     Distribution.Simple.PreProcess     Distribution.Simple.PreProcess.Unlit@@ -187,6 +209,7 @@     Distribution.Simple.Program.GHC     Distribution.Simple.Program.HcPkg     Distribution.Simple.Program.Hpc+    Distribution.Simple.Program.Internal     Distribution.Simple.Program.Ld     Distribution.Simple.Program.Run     Distribution.Simple.Program.Script@@ -196,24 +219,37 @@     Distribution.Simple.Setup     Distribution.Simple.SrcDist     Distribution.Simple.Test+    Distribution.Simple.Test.ExeV10+    Distribution.Simple.Test.LibV09+    Distribution.Simple.Test.Log     Distribution.Simple.UHC     Distribution.Simple.UserHooks     Distribution.Simple.Utils     Distribution.System     Distribution.TestSuite     Distribution.Text+    Distribution.Utils.NubList     Distribution.Verbosity     Distribution.Version     Language.Haskell.Extension    other-modules:+    Distribution.Compat.Binary     Distribution.Compat.CopyFile     Distribution.Compat.TempFile     Distribution.GetOpt+    Distribution.Lex+    Distribution.Simple.GHC.Internal     Distribution.Simple.GHC.IPI641     Distribution.Simple.GHC.IPI642+    Distribution.Simple.GHC.ImplInfo     Paths_Cabal +  if flag(bundled-binary-generic)+    other-modules:+      Distribution.Compat.Binary.Class+      Distribution.Compat.Binary.Generic+   default-language: Haskell98   default-extensions: CPP @@ -221,15 +257,19 @@ test-suite unit-tests   type: exitcode-stdio-1.0   hs-source-dirs: tests-  other-modules: UnitTests.Distribution.Compat.ReadP+  other-modules:+    UnitTests.Distribution.Compat.CreatePipe+    UnitTests.Distribution.Compat.ReadP+    UnitTests.Distribution.Simple.Program.Internal+    UnitTests.Distribution.Utils.NubList   main-is: UnitTests.hs   build-depends:     base,-    test-framework,-    test-framework-hunit,-    test-framework-quickcheck2,-    HUnit,-    QuickCheck,+    tasty,+    tasty-hunit,+    tasty-quickcheck,+    pretty,+    QuickCheck < 2.9,     Cabal   ghc-options: -Wall   default-language: Haskell98@@ -239,7 +279,6 @@   type: exitcode-stdio-1.0   main-is: PackageTests.hs   other-modules:-    Distribution.Compat.CreatePipe     PackageTests.BenchmarkExeV10.Check     PackageTests.BenchmarkOptions.Check     PackageTests.BenchmarkStanza.Check@@ -254,34 +293,41 @@     PackageTests.BuildDeps.TargetSpecificDeps1.Check     PackageTests.BuildDeps.TargetSpecificDeps2.Check     PackageTests.BuildDeps.TargetSpecificDeps3.Check-    PackageTests.BuildTestSuiteDetailedV09.Check     PackageTests.CMain.Check     PackageTests.DeterministicAr.Check     PackageTests.EmptyLib.Check+    PackageTests.Haddock.Check     PackageTests.OrderFlags.Check     PackageTests.PackageTester     PackageTests.PathsModule.Executable.Check     PackageTests.PathsModule.Library.Check     PackageTests.PreProcess.Check+    PackageTests.PreProcessExtraSources.Check+    PackageTests.ReexportedModules.Check     PackageTests.TemplateHaskell.Check     PackageTests.TestOptions.Check     PackageTests.TestStanza.Check-    PackageTests.TestSuiteExeV10.Check+    PackageTests.TestSuiteTests.ExeV10.Check+    PackageTests.TestSuiteTests.LibV09.Check+    Test.Distribution.Version+    Test.Laws+    Test.QuickCheck.Utils   hs-source-dirs: tests   build-depends:     base,-    test-framework,-    test-framework-quickcheck2 >= 0.2.12,-    test-framework-hunit,-    HUnit,-    QuickCheck >= 2.1.0.1,+    containers,+    tasty,+    tasty-quickcheck,+    tasty-hunit,+    QuickCheck >= 2.1.0.1 && < 2.9,     Cabal,     process,     directory,     filepath,     extensible-exceptions,     bytestring,-    regex-posix+    regex-posix,+    old-time   if !os(windows)     build-depends: unix   ghc-options: -Wall

+ cabal/Cabal/Distribution/Compat/Binary.hs view

@@ -0,0 +1,60 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 711+{-# LANGUAGE PatternSynonyms #-}+#endif++#ifndef MIN_VERSION_binary+#define MIN_VERSION_binary(x, y, z) 0+#endif++module Distribution.Compat.Binary+       ( decodeOrFailIO+#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0)+       , module Data.Binary+#else+       , Binary(..)+       , decode, encode+#endif+       ) where++import Control.Exception (catch, evaluate)+#if __GLASGOW_HASKELL__ >= 711+import Control.Exception (pattern ErrorCall)+#else+import Control.Exception (ErrorCall(..))+#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++#else++import Data.Binary.Get+import Data.Binary.Put++import Distribution.Compat.Binary.Class+import Distribution.Compat.Binary.Generic ()++-- | Decode a value from a lazy ByteString, reconstructing the original structure.+--+decode :: Binary a => ByteString -> a+decode = runGet get++-- | Encode a value using binary serialisation to a lazy ByteString.+--+encode :: Binary a => a -> ByteString+encode = runPut . put+{-# INLINE encode #-}++#endif++decodeOrFailIO :: Binary a => ByteString -> IO (Either String a)+decodeOrFailIO bs =+  catch (evaluate (decode bs) >>= return . Right)+  $ \(ErrorCall str) -> return $ Left str

+ cabal/Cabal/Distribution/Compat/Binary/Class.hs view

@@ -0,0 +1,530 @@+{-# LANGUAGE CPP, FlexibleContexts #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DefaultSignatures #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Distribution.Compat.Binary.Class+-- Copyright   : Lennart Kolmodin+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Lennart Kolmodin <kolmodin@gmail.com>+-- Stability   : unstable+-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances+--+-- Typeclass and instances for binary serialization.+--+-----------------------------------------------------------------------------++module Distribution.Compat.Binary.Class (++    -- * The Binary class+      Binary(..)++    -- * Support for generics+    , GBinary(..)++    ) where++import Data.Word++import Data.Binary.Put+import Data.Binary.Get++import Control.Monad+import Foreign++import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as L++import Data.Char    (chr,ord)+import Data.List    (unfoldr)++-- And needed for the instances:+import qualified Data.ByteString as B+import qualified Data.Map        as Map+import qualified Data.Set        as Set+import qualified Data.IntMap     as IntMap+import qualified Data.IntSet     as IntSet+import qualified Data.Ratio      as R++import qualified Data.Tree as T++import Data.Array.Unboxed++import GHC.Generics++--+-- This isn't available in older Hugs or older GHC+--+#if __GLASGOW_HASKELL__ >= 606+import qualified Data.Sequence as Seq+import qualified Data.Foldable as Fold+#endif++------------------------------------------------------------------------++class GBinary f where+    gput :: f t -> Put+    gget :: Get (f t)++-- | The 'Binary' class provides 'put' and 'get', methods to encode and+-- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and+-- 'Show' classes for textual representation of Haskell types, and is+-- suitable for serialising Haskell values to disk, over the network.+--+-- For decoding and generating simple external binary formats (e.g. C+-- structures), Binary may be used, but in general is not suitable+-- for complex protocols. Instead use the 'Put' and 'Get' primitives+-- directly.+--+-- Instances of Binary should satisfy the following property:+--+-- > decode . encode == id+--+-- That is, the 'get' and 'put' methods should be the inverse of each+-- other. A range of instances are provided for basic Haskell types.+--+class Binary t where+    -- | Encode a value in the Put monad.+    put :: t -> Put+    -- | Decode a value in the Get monad+    get :: Get t++    default put :: (Generic t, GBinary (Rep t)) => t -> Put+    put = gput . from++    default get :: (Generic t, GBinary (Rep t)) => Get t+    get = to `fmap` gget++------------------------------------------------------------------------+-- Simple instances++-- The () type need never be written to disk: values of singleton type+-- can be reconstructed from the type alone+instance Binary () where+    put ()  = return ()+    get     = return ()++-- Bools are encoded as a byte in the range 0 .. 1+instance Binary Bool where+    put     = putWord8 . fromIntegral . fromEnum+    get     = liftM (toEnum . fromIntegral) getWord8++-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2+instance Binary Ordering where+    put     = putWord8 . fromIntegral . fromEnum+    get     = liftM (toEnum . fromIntegral) getWord8++------------------------------------------------------------------------+-- Words and Ints++-- Words8s are written as bytes+instance Binary Word8 where+    put     = putWord8+    get     = getWord8++-- Words16s are written as 2 bytes in big-endian (network) order+instance Binary Word16 where+    put     = putWord16be+    get     = getWord16be++-- Words32s are written as 4 bytes in big-endian (network) order+instance Binary Word32 where+    put     = putWord32be+    get     = getWord32be++-- Words64s are written as 8 bytes in big-endian (network) order+instance Binary Word64 where+    put     = putWord64be+    get     = getWord64be++-- Int8s are written as a single byte.+instance Binary Int8 where+    put i   = put (fromIntegral i :: Word8)+    get     = liftM fromIntegral (get :: Get Word8)++-- Int16s are written as a 2 bytes in big endian format+instance Binary Int16 where+    put i   = put (fromIntegral i :: Word16)+    get     = liftM fromIntegral (get :: Get Word16)++-- Int32s are written as a 4 bytes in big endian format+instance Binary Int32 where+    put i   = put (fromIntegral i :: Word32)+    get     = liftM fromIntegral (get :: Get Word32)++-- Int64s are written as a 4 bytes in big endian format+instance Binary Int64 where+    put i   = put (fromIntegral i :: Word64)+    get     = liftM fromIntegral (get :: Get Word64)++------------------------------------------------------------------------++-- Words are are written as Word64s, that is, 8 bytes in big endian format+instance Binary Word where+    put i   = put (fromIntegral i :: Word64)+    get     = liftM fromIntegral (get :: Get Word64)++-- Ints are are written as Int64s, that is, 8 bytes in big endian format+instance Binary Int where+    put i   = put (fromIntegral i :: Int64)+    get     = liftM fromIntegral (get :: Get Int64)++------------------------------------------------------------------------+--+-- Portable, and pretty efficient, serialisation of Integer+--++-- Fixed-size type for a subset of Integer+type SmallInt = Int32++-- Integers are encoded in two ways: if they fit inside a SmallInt,+-- they're written as a byte tag, and that value.  If the Integer value+-- is too large to fit in a SmallInt, it is written as a byte array,+-- along with a sign and length field.++instance Binary Integer where++    {-# INLINE put #-}+    put n | n >= lo && n <= hi = do+        putWord8 0+        put (fromIntegral n :: SmallInt)  -- fast path+     where+        lo = fromIntegral (minBound :: SmallInt) :: Integer+        hi = fromIntegral (maxBound :: SmallInt) :: Integer++    put n = do+        putWord8 1+        put sign+        put (unroll (abs n))         -- unroll the bytes+     where+        sign = fromIntegral (signum n) :: Word8++    {-# INLINE get #-}+    get = do+        tag <- get :: Get Word8+        case tag of+            0 -> liftM fromIntegral (get :: Get SmallInt)+            _ -> do sign  <- get+                    bytes <- get+                    let v = roll bytes+                    return $! if sign == (1 :: Word8) then v else - v++--+-- Fold and unfold an Integer to and from a list of its bytes+--+unroll :: Integer -> [Word8]+unroll = unfoldr step+  where+    step 0 = Nothing+    step i = Just (fromIntegral i, i `shiftR` 8)++roll :: [Word8] -> Integer+roll   = foldr unstep 0+  where+    unstep b a = a `shiftL` 8 .|. fromIntegral b++{-++--+-- An efficient, raw serialisation for Integer (GHC only)+--++-- TODO  This instance is not architecture portable.  GMP stores numbers as+-- arrays of machine sized words, so the byte format is not portable across+-- architectures with different endianness and word size.++import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)+import GHC.Base     hiding (ord, chr)+import GHC.Prim+import GHC.Ptr (Ptr(..))+import GHC.IOBase (IO(..))++instance Binary Integer where+    put (S# i)    = putWord8 0 >> put (I# i)+    put (J# s ba) = do+        putWord8 1+        put (I# s)+        put (BA ba)++    get = do+        b <- getWord8+        case b of+            0 -> do (I# i#) <- get+                    return (S# i#)+            _ -> do (I# s#) <- get+                    (BA a#) <- get+                    return (J# s# a#)++instance Binary ByteArray where++    -- Pretty safe.+    put (BA ba) =+        let sz   = sizeofByteArray# ba   -- (primitive) in *bytes*+            addr = byteArrayContents# ba+            bs   = unsafePackAddress (I# sz) addr+        in put bs   -- write as a ByteString. easy, yay!++    -- Pretty scary. Should be quick though+    get = do+        (fp, off, n@(I# sz)) <- liftM toForeignPtr get      -- so decode a ByteString+        assert (off == 0) $ return $ unsafePerformIO $ do+            (MBA arr) <- newByteArray sz                    -- and copy it into a ByteArray#+            let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?+            withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)+            freezeByteArray arr++-- wrapper for ByteArray#+data ByteArray = BA  {-# UNPACK #-} !ByteArray#+data MBA       = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)++newByteArray :: Int# -> IO MBA+newByteArray sz = IO $ \s ->+  case newPinnedByteArray# sz s of { (# s', arr #) ->+  (# s', MBA arr #) }++freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray+freezeByteArray arr = IO $ \s ->+  case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->+  (# s', BA arr' #) }++-}++instance (Binary a,Integral a) => Binary (R.Ratio a) where+    put r = put (R.numerator r) >> put (R.denominator r)+    get = liftM2 (R.%) get get++------------------------------------------------------------------------++-- Char is serialised as UTF-8+instance Binary Char where+    put a | c <= 0x7f     = put (fromIntegral c :: Word8)+          | c <= 0x7ff    = do put (0xc0 .|. y)+                               put (0x80 .|. z)+          | c <= 0xffff   = do put (0xe0 .|. x)+                               put (0x80 .|. y)+                               put (0x80 .|. z)+          | c <= 0x10ffff = do put (0xf0 .|. w)+                               put (0x80 .|. x)+                               put (0x80 .|. y)+                               put (0x80 .|. z)+          | otherwise     = error "Not a valid Unicode code point"+     where+        c = ord a+        z, y, x, w :: Word8+        z = fromIntegral (c           .&. 0x3f)+        y = fromIntegral (shiftR c 6  .&. 0x3f)+        x = fromIntegral (shiftR c 12 .&. 0x3f)+        w = fromIntegral (shiftR c 18 .&. 0x7)++    get = do+        let getByte = liftM (fromIntegral :: Word8 -> Int) get+            shiftL6 = flip shiftL 6 :: Int -> Int+        w <- getByte+        r <- case () of+                _ | w < 0x80  -> return w+                  | w < 0xe0  -> do+                                    x <- liftM (xor 0x80) getByte+                                    return (x .|. shiftL6 (xor 0xc0 w))+                  | w < 0xf0  -> do+                                    x <- liftM (xor 0x80) getByte+                                    y <- liftM (xor 0x80) getByte+                                    return (y .|. shiftL6 (x .|. shiftL6+                                            (xor 0xe0 w)))+                  | otherwise -> do+                                x <- liftM (xor 0x80) getByte+                                y <- liftM (xor 0x80) getByte+                                z <- liftM (xor 0x80) getByte+                                return (z .|. shiftL6 (y .|. shiftL6+                                        (x .|. shiftL6 (xor 0xf0 w))))+        return $! chr r++------------------------------------------------------------------------+-- Instances for the first few tuples++instance (Binary a, Binary b) => Binary (a,b) where+    put (a,b)           = put a >> put b+    get                 = liftM2 (,) get get++instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where+    put (a,b,c)         = put a >> put b >> put c+    get                 = liftM3 (,,) get get get++instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where+    put (a,b,c,d)       = put a >> put b >> put c >> put d+    get                 = liftM4 (,,,) get get get get++instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where+    put (a,b,c,d,e)     = put a >> put b >> put c >> put d >> put e+    get                 = liftM5 (,,,,) get get get get get++--+-- and now just recurse:+--++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)+        => Binary (a,b,c,d,e,f) where+    put (a,b,c,d,e,f)   = put (a,(b,c,d,e,f))+    get                 = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)+        => Binary (a,b,c,d,e,f,g) where+    put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))+    get                 = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)++instance (Binary a, Binary b, Binary c, Binary d, Binary e,+          Binary f, Binary g, Binary h)+        => Binary (a,b,c,d,e,f,g,h) where+    put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))+    get                   = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h)++instance (Binary a, Binary b, Binary c, Binary d, Binary e,+          Binary f, Binary g, Binary h, Binary i)+        => Binary (a,b,c,d,e,f,g,h,i) where+    put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))+    get                     = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i)++instance (Binary a, Binary b, Binary c, Binary d, Binary e,+          Binary f, Binary g, Binary h, Binary i, Binary j)+        => Binary (a,b,c,d,e,f,g,h,i,j) where+    put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))+    get                       = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j)++------------------------------------------------------------------------+-- Container types++instance Binary a => Binary [a] where+    put l  = put (length l) >> mapM_ put l+    get    = do n <- get :: Get Int+                getMany n++-- | 'getMany n' get 'n' elements in order, without blowing the stack.+getMany :: Binary a => Int -> Get [a]+getMany n = go [] n+ where+    go xs 0 = return $! reverse xs+    go xs i = do x <- get+                 -- we must seq x to avoid stack overflows due to laziness in+                 -- (>>=)+                 x `seq` go (x:xs) (i-1)+{-# INLINE getMany #-}++instance (Binary a) => Binary (Maybe a) where+    put Nothing  = putWord8 0+    put (Just x) = putWord8 1 >> put x+    get = do+        w <- getWord8+        case w of+            0 -> return Nothing+            _ -> liftM Just get++instance (Binary a, Binary b) => Binary (Either a b) where+    put (Left  a) = putWord8 0 >> put a+    put (Right b) = putWord8 1 >> put b+    get = do+        w <- getWord8+        case w of+            0 -> liftM Left  get+            _ -> liftM Right get++------------------------------------------------------------------------+-- ByteStrings (have specially efficient instances)++instance Binary B.ByteString where+    put bs = do put (B.length bs)+                putByteString bs+    get    = get >>= getByteString++--+-- Using old versions of fps, this is a type synonym, and non portable+--+-- Requires 'flexible instances'+--+instance Binary ByteString where+    put bs = do put (fromIntegral (L.length bs) :: Int)+                putLazyByteString bs+    get    = get >>= getLazyByteString++------------------------------------------------------------------------+-- Maps and Sets++instance (Binary a) => Binary (Set.Set a) where+    put s = put (Set.size s) >> mapM_ 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)+    get   = liftM Map.fromDistinctAscList get++instance Binary IntSet.IntSet where+    put s = put (IntSet.size s) >> mapM_ 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)+    get   = liftM IntMap.fromDistinctAscList get++------------------------------------------------------------------------+-- Queues and Sequences++#if __GLASGOW_HASKELL__ >= 606+--+-- This is valid Hugs, but you need the most recent Hugs+--++instance (Binary e) => Binary (Seq.Seq e) where+    put s = put (Seq.length s) >> Fold.mapM_ put s+    get = do n <- get :: Get Int+             rep Seq.empty n get+      where rep xs 0 _ = return $! xs+            rep xs n g = xs `seq` n `seq` do+                           x <- g+                           rep (xs Seq.|> x) (n-1) g++#endif++------------------------------------------------------------------------+-- Floating point++instance Binary Double where+    put d = put (decodeFloat d)+    get   = liftM2 encodeFloat get get++instance Binary Float where+    put f = put (decodeFloat f)+    get   = liftM2 encodeFloat get get++------------------------------------------------------------------------+-- Trees++instance (Binary e) => Binary (T.Tree e) where+    put (T.Node r s) = put r >> put s+    get = liftM2 T.Node get get++------------------------------------------------------------------------+-- Arrays++instance (Binary i, Ix i, Binary e) => Binary (Array i e) where+    put a = do+        put (bounds a)+        put (rangeSize $ bounds a) -- write the length+        mapM_ put (elems a)        -- now the elems.+    get = do+        bs <- get+        n  <- get                  -- read the length+        xs <- getMany n            -- now the elems.+        return (listArray bs xs)++--+-- The IArray UArray e constraint is non portable. Requires flexible instances+--+instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where+    put a = do+        put (bounds a)+        put (rangeSize $ bounds a) -- now write the length+        mapM_ put (elems a)+    get = do+        bs <- get+        n  <- get+        xs <- getMany n+        return (listArray bs xs)

+ cabal/Cabal/Distribution/Compat/Binary/Generic.hs view

@@ -0,0 +1,128 @@+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures,+    ScopedTypeVariables, Trustworthy, TypeOperators, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Distribution.Compat.Binary.Generic+-- Copyright   : Bryan O'Sullivan+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Bryan O'Sullivan <bos@serpentine.com>+-- Stability   : unstable+-- Portability : Only works with GHC 7.2 and newer+--+-- Instances for supporting GHC generics.+--+-----------------------------------------------------------------------------+module Distribution.Compat.Binary.Generic+    (+    ) where++import Control.Applicative+import Distribution.Compat.Binary.Class+import Data.Binary.Get+import Data.Binary.Put+import Data.Bits+import Data.Word+import GHC.Generics++-- Type without constructors+instance GBinary V1 where+    gput _ = return ()+    gget   = return undefined++-- Constructor without arguments+instance GBinary U1 where+    gput U1 = return ()+    gget    = return U1++-- Product: constructor with parameters+instance (GBinary a, GBinary b) => GBinary (a :*: b) where+    gput (x :*: y) = gput x >> gput y+    gget = (:*:) <$> gget <*> gget++-- Metadata (constructor name, etc)+instance GBinary a => GBinary (M1 i c a) where+    gput = gput . unM1+    gget = M1 <$> gget++-- Constants, additional parameters, and rank-1 recursion+instance Binary a => GBinary (K1 i a) where+    gput = put . unK1+    gget = K1 <$> get++-- Borrowed from the cereal package.++-- The following GBinary instance for sums has support for serializing+-- types with up to 2^64-1 constructors. It will use the minimal+-- number of bytes needed to encode the constructor. For example when+-- a type has 2^8 constructors or less it will use a single byte to+-- encode the constructor. If it has 2^16 constructors or less it will+-- use two bytes, and so on till 2^64-1.++#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)+#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)+#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)++instance ( GSum     a, GSum     b+         , GBinary a, GBinary b+         , SumSize    a, SumSize    b) => GBinary (a :+: b) where+    gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64)+         | otherwise = sizeError "encode" size+      where+        size = unTagged (sumSize :: Tagged (a :+: b) Word64)++    gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64)+         | otherwise = sizeError "decode" size+      where+        size = unTagged (sumSize :: Tagged (a :+: b) Word64)++sizeError :: Show size => String -> size -> error+sizeError s size =+    error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors"++------------------------------------------------------------------------++checkGetSum :: (Ord word, Num word, Bits word, GSum f)+            => word -> word -> Get (f a)+checkGetSum size code | code < size = getSum code size+                      | otherwise   = fail "Unknown encoding for constructor"+{-# INLINE checkGetSum #-}++class GSum f where+    getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)+    putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put++instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where+    getSum !code !size | code < sizeL = L1 <$> getSum code           sizeL+                       | otherwise    = R1 <$> getSum (code - sizeL) sizeR+        where+          sizeL = size `shiftR` 1+          sizeR = size - sizeL++    putSum !code !size s = case s of+                             L1 x -> putSum code           sizeL x+                             R1 x -> putSum (code + sizeL) sizeR x+        where+          sizeL = size `shiftR` 1+          sizeR = size - sizeL++instance GBinary a => GSum (C1 c a) where+    getSum _ _ = gget++    putSum !code _ x = put code *> gput x++------------------------------------------------------------------------++class SumSize f where+    sumSize :: Tagged f Word64++newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}++instance (SumSize a, SumSize b) => SumSize (a :+: b) where+    sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) ++                       unTagged (sumSize :: Tagged b Word64)++instance SumSize (C1 c a) where+    sumSize = Tagged 1

+ cabal/Cabal/Distribution/Compat/CreatePipe.hs view

@@ -0,0 +1,62 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+module Distribution.Compat.CreatePipe (createPipe) where++import System.IO (Handle, hSetEncoding, localeEncoding)++-- The mingw32_HOST_OS CPP macro is GHC-specific+#if mingw32_HOST_OS+import Control.Exception (onException)+import Foreign.C.Error (throwErrnoIfMinus1_)+import Foreign.C.Types (CInt(..), CUInt(..))+import Foreign.Ptr (Ptr)+import Foreign.Marshal.Array (allocaArray)+import Foreign.Storable (peek, peekElemOff)+import GHC.IO.FD (mkFD)+import GHC.IO.Device (IODeviceType(Stream))+import GHC.IO.Handle.FD (mkHandleFromFD)+import System.IO (IOMode(ReadMode, WriteMode))+#elif ghcjs_HOST_OS+#else+import System.Posix.IO (fdToHandle)+import qualified System.Posix.IO as Posix+#endif++createPipe :: IO (Handle, Handle)+-- The mingw32_HOST_OS CPP macro is GHC-specific+#if mingw32_HOST_OS+createPipe = do+    (readfd, writefd) <- allocaArray 2 $ \ pfds -> do+        throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 ({- _O_BINARY -} 32768)+        readfd <- peek pfds+        writefd <- peekElemOff pfds 1+        return (readfd, writefd)+    (do readh <- fdToHandle readfd ReadMode+        writeh <- fdToHandle writefd WriteMode+        hSetEncoding readh localeEncoding+        hSetEncoding writeh localeEncoding+        return (readh, writeh)) `onException` (close readfd >> close writefd)+  where+    fdToHandle :: CInt -> IOMode -> IO 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++foreign import ccall "io.h _pipe" c__pipe ::+    Ptr CInt -> CUInt -> CInt -> IO CInt++foreign import ccall "io.h _close" c__close ::+    CInt -> IO CInt+#elif ghcjs_HOST_OS+createPipe = error "createPipe"+#else+createPipe = do+    (readfd, writefd) <- Posix.createPipe+    readh <- fdToHandle readfd+    writeh <- fdToHandle writefd+    hSetEncoding readh localeEncoding+    hSetEncoding writeh localeEncoding+    return (readh, writeh)+#endif

cabal/Cabal/Distribution/Compat/Environment.hs view

@@ -1,14 +1,29 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.Environment (getEnvironment)+module Distribution.Compat.Environment+       ( getEnvironment, lookupEnv, setEnv )        where  import qualified System.Environment as System+#if __GLASGOW_HASKELL__ >= 706+import System.Environment (lookupEnv)+#else+import Distribution.Compat.Exception (catchIO)+#endif  #ifdef mingw32_HOST_OS+import Control.Monad import qualified Data.Char as Char (toUpper)-#endif+import Foreign.C+import GHC.Windows+#else+import Foreign.C.Types+import Foreign.C.String+import Foreign.C.Error (throwErrnoIfMinus1_)+import System.Posix.Internals ( withFilePath )+#endif /* mingw32_HOST_OS */  getEnvironment :: IO [(String, String)] #ifdef mingw32_HOST_OS@@ -22,3 +37,53 @@ #else getEnvironment = System.getEnvironment #endif++#if __GLASGOW_HASKELL__ < 706+-- | @lookupEnv var@ returns the value of the environment variable @var@, or+-- @Nothing@ if there is no such value.+lookupEnv :: String -> IO (Maybe String)+lookupEnv name = (Just `fmap` System.getEnv name) `catchIO` const (return Nothing)+#endif /* __GLASGOW_HASKELL__ < 706 */++-- | @setEnv name value@ sets the specified environment variable to @value@.+--+-- 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+  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+    -- starts with NUL.+    value = takeWhile (/= '\NUL') value_++setEnv_ :: String -> String -> IO ()++#ifdef mingw32_HOST_OS++setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do+  success <- c_SetEnvironmentVariable k v+  unless success (throwGetLastError "setEnv")++# if defined(i386_HOST_ARCH)+#  define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH)+#  define WINDOWS_CCONV ccall+# else+#  error Unknown mingw32 arch+# endif /* i386_HOST_ARCH */++foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"+  c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool+#else+setEnv_ key value = do+  withFilePath key $ \ keyP ->+    withFilePath value $ \ valueP ->+      throwErrnoIfMinus1_ "setenv" $+        c_setenv keyP valueP (fromIntegral (fromEnum True))++foreign import ccall unsafe "setenv"+   c_setenv :: CString -> CString -> CInt -> IO CInt+#endif /* mingw32_HOST_OS */

cabal/Cabal/Distribution/Compat/ReadP.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Compat.ReadP@@ -14,7 +15,7 @@ -- it makes no difference which branch is \"shorter\". -- -- See also Koen's paper /Parallel Parsing Processes/--- (<http://www.cs.chalmers.se/~koen/publications.html>).+-- (<http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.19.9217>). -- -- This version of ReadP has been locally hacked to make it H98, by -- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>@@ -71,7 +72,10 @@  import Control.Monad( MonadPlus(..), liftM, liftM2, ap ) import Data.Char (isSpace)-import Control.Applicative (Applicative(..), Alternative(empty, (<|>)))+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative (Applicative(..))+#endif+import Control.Applicative (Alternative(empty, (<|>)))  infixr 5 +++, <++

cabal/Cabal/Distribution/Compat/TempFile.hs view

@@ -25,7 +25,7 @@  import System.Posix.Internals (c_getpid) -#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) import System.Directory       ( createDirectory ) #else import qualified System.Posix@@ -37,7 +37,8 @@  -- This is here for Haskell implementations that do not come with -- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.--- TODO: Not sure about jhc+-- TODO: Not sure about JHC+-- TODO: This file should probably be removed.  -- This is a copy/paste of the openBinaryTempFile definition, but -- if uses 666 rather than 600 for the permissions. The base library@@ -49,7 +50,7 @@   where     -- We split off the last extension, so we can use .foo.ext files     -- for temporary files (hidden on Unix OSes). Unfortunately we're-    -- below filepath in the hierarchy here.+    -- below file path in the hierarchy here.     (prefix,suffix) =        case break (== '.') $ reverse template of          -- First case: template contains no '.'s. Just re-reverse it.@@ -76,9 +77,9 @@            then findTempName (x+1)            else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))        else do-         -- TODO: We want to tell fdToHandle what the filepath is,+         -- TODO: We want to tell fdToHandle what the file path is,          -- as any exceptions etc will only be able to report the-         -- fd currently+         -- FD currently          h <- fdToHandle fd `onException` c_close fd          return (filepath, h)       where@@ -92,7 +93,7 @@                   | last a == pathSeparator = a ++ b                   | otherwise = a ++ [pathSeparator] ++ b --- FIXME: Should use filepath library+-- FIXME: Should use System.FilePath library pathSeparator :: Char #ifdef mingw32_HOST_OS pathSeparator = '\\'@@ -120,7 +121,7 @@                 | otherwise              -> ioError e  mkPrivateDir :: String -> IO ()-#ifdef mingw32_HOST_OS+#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) mkPrivateDir s = createDirectory s #else mkPrivateDir s = System.Posix.createDirectory s 0o700

cabal/Cabal/Distribution/Compiler.hs view

@@ -1,8 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Compiler -- Copyright   :  Isaac Jones 2003-2004+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -22,36 +25,6 @@ -- moment we just have to live with this deficiency. If you're interested, see -- ticket #57. -{- 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. -}- module Distribution.Compiler (   -- * Compiler flavor   CompilerFlavor(..),@@ -62,13 +35,22 @@    -- * Compiler id   CompilerId(..),++  -- * Compiler info+  CompilerInfo(..),+  unknownCompilerInfo,+  AbiTag(..), abiTagString   ) where +import Distribution.Compat.Binary (Binary) import Data.Data (Data) import Data.Typeable (Typeable) import Data.Maybe (fromMaybe) import Distribution.Version (Version(..))+import GHC.Generics (Generic) +import Language.Haskell.Extension (Language, Extension)+ import qualified System.Info (compilerName, compilerVersion) import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse@@ -78,13 +60,15 @@ import qualified Data.Char as Char (toLower, isDigit, isAlphaNum) import Control.Monad (when) -data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC+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 (Show, Read, Eq, Ord, Typeable, Data)+  deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) +instance Binary CompilerFlavor+ knownCompilerFlavors :: [CompilerFlavor]-knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]+knownCompilerFlavors = [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]  instance Text CompilerFlavor where   disp (OtherCompiler name) = Disp.text name@@ -154,8 +138,10 @@ -- ------------------------------------------------------------  data CompilerId = CompilerId CompilerFlavor Version-  deriving (Eq, Ord, Read, Show)+  deriving (Eq, Generic, Ord, Read, Show) +instance Binary CompilerId+ instance Text CompilerId where   disp (CompilerId f (Version [] _)) = disp f   disp (CompilerId f v) = disp f <> Disp.char '-' <> disp v@@ -167,3 +153,52 @@  lowercase :: String -> String lowercase = map Char.toLower++-- ------------------------------------------------------------+-- * Compiler Info+-- ------------------------------------------------------------++-- | 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.+         compilerInfoCompat     :: Maybe [CompilerId],+         -- ^ Other implementations that this compiler claims to be compatible with, if known.+         compilerInfoLanguages  :: Maybe [Language],+         -- ^ Supported language standards, if known.+         compilerInfoExtensions :: Maybe [Extension]+         -- ^ Supported extensions, if known.+     }+     deriving (Generic, Show, Read)++instance Binary CompilerInfo++data AbiTag+  = NoAbiTag+  | AbiTag String+  deriving (Generic, Show, Read)++instance Binary AbiTag++instance Text AbiTag where+  disp NoAbiTag     = Disp.empty+  disp (AbiTag tag) = Disp.text tag++  parse = do+    tag <- Parse.munch (\c -> Char.isAlphaNum c || c == '_')+    if null tag then return NoAbiTag else return (AbiTag tag)++abiTagString :: AbiTag -> String+abiTagString NoAbiTag     = ""+abiTagString (AbiTag tag) = tag++-- | Make a CompilerInfo of which only the known information is its CompilerId,+--   its AbiTag and that it does not claim to be compatible with other+--   compiler id's.+unknownCompilerInfo :: CompilerId -> AbiTag -> CompilerInfo+unknownCompilerInfo compilerId abiTag =+  CompilerInfo compilerId abiTag (Just []) Nothing Nothing

cabal/Cabal/Distribution/InstalledPackageInfo.hs view

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.InstalledPackageInfo@@ -22,40 +24,12 @@ -- textual format is rather simpler than the @.cabal@ format: there are no -- sections, for example. -{- 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 the University 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. -}- -- This module is meant to be local-only to Distribution...  module Distribution.InstalledPackageInfo (-        InstalledPackageInfo_(..), InstalledPackageInfo,+        InstalledPackageInfo(..),+        libraryName,+        OriginalModule(..), ExposedModule(..),         ParseResult(..), PError(..), PWarning,         emptyInstalledPackageInfo,         parseInstalledPackageInfo,@@ -72,29 +46,37 @@          , parseFieldsFlat          , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ          , showFilePath, showToken, boolField, parseOptVersion-         , parseFreeText, showFreeText )+         , parseFreeText, showFreeText, parseOptCommaList ) import Distribution.License     ( License(..) ) import Distribution.Package          ( PackageName(..), PackageIdentifier(..)          , PackageId, InstalledPackageId(..)-         , packageName, packageVersion )+         , packageName, packageVersion, PackageKey(..)+         , LibraryName(..) ) import qualified Distribution.Package as Package-         ( Package(..) ) import Distribution.ModuleName          ( ModuleName ) import Distribution.Version          ( Version(..) ) import Distribution.Text          ( Text(disp, parse) )+import Text.PrettyPrint as Disp+import qualified Distribution.Compat.ReadP as Parse +import Distribution.Compat.Binary  (Binary)+import Data.Maybe   (fromMaybe)+import GHC.Generics (Generic)+ -- ----------------------------------------------------------------------------- -- The InstalledPackageInfo type -data InstalledPackageInfo_ m++data InstalledPackageInfo    = InstalledPackageInfo {         -- these parts are exactly the same as PackageDescription         installedPackageId :: InstalledPackageId,         sourcePackageId    :: PackageId,+        packageKey         :: PackageKey,         license           :: License,         copyright         :: String,         maintainer        :: String,@@ -107,38 +89,51 @@         category          :: String,         -- these parts are required by an installed package only:         exposed           :: Bool,-        exposedModules    :: [m],-        hiddenModules     :: [m],+        exposedModules    :: [ExposedModule],+        instantiatedWith  :: [(ModuleName, OriginalModule)],+        hiddenModules     :: [ModuleName],         trusted           :: Bool,-        importDirs        :: [FilePath],  -- contain sources in case of Hugs+        importDirs        :: [FilePath],         libraryDirs       :: [FilePath],+        dataDir           :: FilePath,         hsLibraries       :: [String],         extraLibraries    :: [String],         extraGHCiLibraries:: [String],    -- overrides extraLibraries for GHCi         includeDirs       :: [FilePath],         includes          :: [String],         depends           :: [InstalledPackageId],-        hugsOptions       :: [String],         ccOptions         :: [String],         ldOptions         :: [String],         frameworkDirs     :: [FilePath],         frameworks        :: [String],         haddockInterfaces :: [FilePath],-        haddockHTMLs      :: [FilePath]+        haddockHTMLs      :: [FilePath],+        pkgRoot           :: Maybe FilePath     }-    deriving (Read, Show)+    deriving (Generic, Read, Show) -instance Package.Package          (InstalledPackageInfo_ str) where+libraryName :: InstalledPackageInfo -> LibraryName+libraryName ipi = Package.packageKeyLibraryName (sourcePackageId ipi) (packageKey ipi)++instance Binary InstalledPackageInfo++instance Package.Package InstalledPackageInfo where    packageId = sourcePackageId -type InstalledPackageInfo = InstalledPackageInfo_ ModuleName+instance Package.HasInstalledPackageId InstalledPackageInfo where+   installedPackageId = installedPackageId -emptyInstalledPackageInfo :: InstalledPackageInfo_ m+instance Package.PackageInstalled InstalledPackageInfo where+   installedDepends = depends++emptyInstalledPackageInfo :: InstalledPackageInfo emptyInstalledPackageInfo    = InstalledPackageInfo {         installedPackageId = InstalledPackageId "",         sourcePackageId    = PackageIdentifier (PackageName "") noVersion,-        license           = AllRightsReserved,+        packageKey         = OldPackageKey (PackageIdentifier+                                               (PackageName "") noVersion),+        license           = UnspecifiedLicense,         copyright         = "",         maintainer        = "",         author            = "",@@ -151,34 +146,116 @@         exposed           = False,         exposedModules    = [],         hiddenModules     = [],+        instantiatedWith  = [],         trusted           = False,         importDirs        = [],         libraryDirs       = [],+        dataDir           = "",         hsLibraries       = [],         extraLibraries    = [],         extraGHCiLibraries= [],         includeDirs       = [],         includes          = [],         depends           = [],-        hugsOptions       = [],         ccOptions         = [],         ldOptions         = [],         frameworkDirs     = [],         frameworks        = [],         haddockInterfaces = [],-        haddockHTMLs      = []+        haddockHTMLs      = [],+        pkgRoot           = Nothing     }  noVersion :: Version-noVersion = Version{ versionBranch=[], versionTags=[] }+noVersion = Version [] []  -- -----------------------------------------------------------------------------+-- Exposed modules++data OriginalModule+   = OriginalModule {+       originalPackageId :: InstalledPackageId,+       originalModuleName :: ModuleName+     }+  deriving (Generic, Eq, Read, Show)++data ExposedModule+   = ExposedModule {+       exposedName      :: ModuleName,+       exposedReexport  :: Maybe OriginalModule,+       exposedSignature :: Maybe OriginalModule -- This field is unused for now.+     }+  deriving (Generic, Read, Show)++instance Text OriginalModule where+    disp (OriginalModule ipi m) =+        disp ipi <> Disp.char ':' <> disp m+    parse = do+        ipi <- parse+        _ <- Parse.char ':'+        m <- parse+        return (OriginalModule ipi m)++instance Text ExposedModule where+    disp (ExposedModule m reexport signature) =+        Disp.sep [ disp m+                 , case reexport of+                    Just m' -> Disp.sep [Disp.text "from", disp m']+                    Nothing -> Disp.empty+                 , case signature of+                    Just m' -> Disp.sep [Disp.text "is", disp m']+                    Nothing -> Disp.empty+                 ]+    parse = do+        m <- parseModuleNameQ+        Parse.skipSpaces+        reexport <- Parse.option Nothing $ do+            _ <- Parse.string "from"+            Parse.skipSpaces+            fmap Just parse+        Parse.skipSpaces+        signature <- Parse.option Nothing $ do+            _ <- Parse.string "is"+            Parse.skipSpaces+            fmap Just parse+        return (ExposedModule m reexport signature)+++instance Binary OriginalModule++instance Binary ExposedModule++-- To maintain backwards-compatibility, we accept both comma/non-comma+-- separated variants of this field.  You SHOULD use the comma syntax if you+-- use any new functions, although actually it's unambiguous due to a quirk+-- of the fact that modules must start with capital letters.++showExposedModules :: [ExposedModule] -> Disp.Doc+showExposedModules xs+    | all isExposedModule xs = fsep (map disp xs)+    | otherwise = fsep (Disp.punctuate comma (map disp xs))+    where isExposedModule (ExposedModule _ Nothing Nothing) = True+          isExposedModule _ = False++parseExposedModules :: Parse.ReadP r [ExposedModule]+parseExposedModules = parseOptCommaList parse++-- ----------------------------------------------------------------------------- -- Parsing  parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo parseInstalledPackageInfo =-    parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo+    parseFieldsFlat (fieldsInstalledPackageInfo ++ deprecatedFieldDescrs)+    emptyInstalledPackageInfo +parseInstantiatedWith :: Parse.ReadP r (ModuleName, OriginalModule)+parseInstantiatedWith = do k <- parse+                           _ <- Parse.char '='+                           n <- parse+                           _ <- Parse.char '@'+                           p <- parse+                           return (k, OriginalModule p n)+ -- ----------------------------------------------------------------------------- -- Pretty-printing @@ -191,6 +268,9 @@ showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) showSimpleInstalledPackageInfoField = showSimpleSingleNamedField fieldsInstalledPackageInfo +showInstantiatedWith :: (ModuleName, OriginalModule) -> Doc+showInstantiatedWith (k, OriginalModule p m) = disp k <> text "=" <> disp m <> text "@" <> disp p+ -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing @@ -208,6 +288,9 @@  , simpleField "id"                            disp                   parse                            installedPackageId     (\ipid pkg -> pkg{installedPackageId=ipid})+ , simpleField "key"+                           disp                   parse+                           packageKey             (\pk pkg -> pkg{packageKey=pk})  , simpleField "license"                            disp                   parseLicenseQ                            license                (\l pkg -> pkg{license=l})@@ -244,12 +327,15 @@ installedFieldDescrs = [    boolField "exposed"         exposed            (\val pkg -> pkg{exposed=val})- , listField   "exposed-modules"-        disp               parseModuleNameQ+ , simpleField "exposed-modules"+        showExposedModules parseExposedModules         exposedModules     (\xs    pkg -> pkg{exposedModules=xs})  , listField   "hidden-modules"         disp               parseModuleNameQ         hiddenModules      (\xs    pkg -> pkg{hiddenModules=xs})+ , listField   "instantiated-with"+        showInstantiatedWith parseInstantiatedWith+        instantiatedWith   (\xs    pkg -> pkg{instantiatedWith=xs})  , boolField   "trusted"         trusted            (\val pkg -> pkg{trusted=val})  , listField   "import-dirs"@@ -258,6 +344,9 @@  , listField   "library-dirs"         showFilePath       parseFilePathQ         libraryDirs        (\xs pkg -> pkg{libraryDirs=xs})+ , simpleField "data-dir"+        showFilePath       (parseFilePathQ Parse.<++ return "")+        dataDir            (\val pkg -> pkg{dataDir=val})  , listField   "hs-libraries"         showFilePath       parseTokenQ         hsLibraries        (\xs pkg -> pkg{hsLibraries=xs})@@ -276,9 +365,6 @@  , listField   "depends"         disp               parse         depends            (\xs pkg -> pkg{depends=xs})- , listField   "hugs-options"-        showToken          parseTokenQ-        hugsOptions        (\path  pkg -> pkg{hugsOptions=path})  , listField   "cc-options"         showToken          parseTokenQ         ccOptions          (\path  pkg -> pkg{ccOptions=path})@@ -297,4 +383,14 @@  , listField   "haddock-html"         showFilePath       parseFilePathQ         haddockHTMLs       (\xs pkg -> pkg{haddockHTMLs=xs})+ , simpleField "pkgroot"+        (const Disp.empty)        parseFilePathQ+        (fromMaybe "" . pkgRoot)  (\xs pkg -> pkg{pkgRoot=Just xs})  ]++deprecatedFieldDescrs :: [FieldDescr InstalledPackageInfo]+deprecatedFieldDescrs = [+   listField   "hugs-options"+        showToken          parseTokenQ+        (const [])        (const id)+  ]

+ cabal/Cabal/Distribution/Lex.hs view

@@ -0,0 +1,55 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Lex+-- Copyright   :  Ben Gamari 2015-2019+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module contains a simple lexer supporting quoted strings++module Distribution.Lex (+        tokenizeQuotedWords+ ) where++import Data.Char (isSpace)+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid+#endif++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+  DList a `mappend` DList b = DList (a . b)++tokenizeQuotedWords :: String -> [String]+tokenizeQuotedWords = filter (not . null) . go False mempty+  where+    go :: Bool        -- ^ in quoted region+       -> DList Char  -- ^ accumulator+       -> String      -- ^ string to be parsed+       -> [String]    -- ^ parse result+    go _ accum []+      | [] <- accum' = []+      | otherwise    = [accum']+      where accum' = runDList accum++    go False  accum (c:cs)+      | isSpace c = runDList accum : go False mempty cs+      | c == '"'  = go True accum cs++    go True   accum (c:cs)+      | c == '"'  = go False accum cs++    go quoted accum (c:cs)+                  = go quoted (accum `mappend` singleton c) cs+

cabal/Cabal/Distribution/License.hs view

@@ -1,52 +1,46 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.License+-- Description :  The License data type. -- Copyright   :  Isaac Jones 2003-2005 --                Duncan Coutts 2008+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable ----- The License datatype.  For more information about these and other--- open-source licenses, you may visit <http://www.opensource.org/>.+-- Package descriptions contain fields for specifying the name of a software+-- license and the name of the file containing the text of that license. While+-- package authors may choose any license they like, Cabal provides an+-- enumeration of a small set of common free and open source software licenses.+-- This is done so that Hackage can recognise licenses, so that tools can detect+-- <https://en.wikipedia.org/wiki/License_compatibility licensing conflicts>,+-- and to deter+-- <https://en.wikipedia.org/wiki/License_proliferation license proliferation>. ----- The @.cabal@ file allows you to specify a license file. Of course you can--- use any license you like but people often pick common open source licenses--- and it's useful if we can automatically recognise that (eg so we can display--- it on the hackage web pages). So you can also specify the license itself in--- the @.cabal@ file from a short enumeration defined in this module. It--- includes 'GPL', 'AGPL', 'LGPL', 'Apache 2.0', 'MIT' and 'BSD3' licenses.--{- 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. -}+-- It is recommended that all package authors use the @license-file@ or+-- @license-files@ fields in their package descriptions. Further information+-- about these fields can be found in the+-- <http://www.haskell.org/cabal/users-guide/developing-packages.html#package-descriptions Cabal users guide>.+--+-- = Additional resources+--+-- The following websites provide information about free and open source+-- software licenses:+--+-- * <http://www.opensource.org The Open Source Initiative (OSI)>+--+-- * <https://www.fsf.org The Free Software Foundation (FSF)>+--+-- = Disclaimer+--+-- The descriptions of software licenses provided by this documentation are+-- intended for informational purposes only and in no way constitute legal+-- advice. Please read the text of the licenses and consult a lawyer for any+-- advice regarding software licensing.  module Distribution.License (     License(..),@@ -59,66 +53,87 @@ import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>))+import Distribution.Compat.Binary (Binary) import qualified Data.Char as Char (isAlphaNum) import Data.Data (Data) import Data.Typeable (Typeable)+import GHC.Generics (Generic) --- |This datatype indicates the license under which your package is--- released.  It is also wise to add your license to each source file--- using the license-file field.  The 'AllRightsReserved' constructor--- is not actually a license, but states that you are not giving--- anyone else a license to use or distribute your work.  The comments--- below are general guidelines.  Please read the licenses themselves--- and consult a lawyer if you are unsure of your rights to release--- the software.---+-- | 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+-- cause @cabal check@ to issue a warning. data License =----TODO: * remove BSD4+    -- TODO: * remove BSD4 -    -- | GNU Public License. Source code must accompany alterations.+    -- | GNU General Public License,+    -- <https://www.gnu.org/licenses/old-licenses/gpl-2.0.html version 2> or+    -- <https://www.gnu.org/licenses/gpl.html version 3>.     GPL (Maybe Version) -    -- | GNU Affero General Public License+    -- | <https://www.gnu.org/licenses/agpl.html GNU Affero General Public License, version 3>.   | AGPL (Maybe Version) -    -- | Lesser GPL, Less restrictive than GPL, useful for libraries.+    -- | GNU Lesser General Public License,+    -- <https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html version 2.1> or+    -- <https://www.gnu.org/licenses/lgpl.html version 3>.   | LGPL (Maybe Version) -    -- | 3-clause BSD license, newer, no advertising clause. Very free license.+    -- | <http://www.opensource.org/licenses/bsd-license 2-clause BSD license>.+  | BSD2++    -- | <http://www.opensource.org/licenses/bsd-3-clause 3-clause BSD license>.   | BSD3 -    -- | 4-clause BSD license, older, with advertising clause. You almost-    -- certainly want to use the BSD3 license instead.+    -- | <http://directory.fsf.org/wiki/License:BSD_4Clause 4-clause BSD license>.+    -- This license has not been approved by the OSI and is incompatible with+    -- the GNU GPL. It is provided for historical reasons and should be avoided.   | BSD4 -    -- | The MIT license, similar to the BSD3. Very free license.+    -- | <http://www.opensource.org/licenses/MIT MIT license>.   | MIT -    -- | The Apache License. Version 2.0 is the current version,-    -- previous versions are considered historical.+    -- | <http://www.isc.org/downloads/software-support-policy/isc-license/ ISC license>+  | ISC +    -- | <https://www.mozilla.org/MPL/ Mozilla Public License, version 2.0>.+  | MPL Version++    -- | <https://www.apache.org/licenses/ Apache License, version 2.0>.   | Apache (Maybe Version) -    -- | Holder makes no claim to ownership, least restrictive license.+    -- | The author of a package disclaims any copyright to its source code and+    -- dedicates it to the public domain. This is not a software license. Please+    -- note that it is not possible to dedicate works to the public domain in+    -- every jurisdiction, nor is a work that is in the public domain in one+    -- jurisdiction necessarily in the public domain elsewhere.   | PublicDomain -    -- | No rights are granted to others. Undistributable. Most restrictive.+    -- | Explicitly 'All Rights Reserved', eg for proprietary software. The+    -- package may not be legally modified or redistributed by anyone but the+    -- rightsholder.   | AllRightsReserved -    -- | Some other license.+    -- | No license specified which legally defaults to 'All Rights Reserved'.+    -- The package may not be legally modified or redistributed by anyone but+    -- the rightsholder.+  | UnspecifiedLicense++    -- | Any other software license.   | OtherLicense -    -- | Not a recognised license.-    -- Allows us to deal with future extensions more gracefully.+    -- | Indicates an erroneous license name.   | UnknownLicense String-  deriving (Read, Show, Eq, Typeable, Data)+  deriving (Generic, Read, Show, Eq, Typeable, Data) +instance Binary License++-- | The list of all currently recognised licenses. knownLicenses :: [License]-knownLicenses = [ GPL  unversioned, GPL  (version [2]),   GPL  (version [3])-                , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3])-                , AGPL unversioned,                       AGPL (version [3])-                , BSD3, MIT+knownLicenses = [ GPL  unversioned, GPL  (version [2]),    GPL  (version [3])+                , LGPL unversioned, LGPL (version [2, 1]), LGPL (version [3])+                , AGPL unversioned,                        AGPL (version [3])+                , BSD2, BSD3, MIT, ISC+                , MPL (Version [2, 0] [])                 , Apache unversioned, Apache (version [2, 0])                 , PublicDomain, AllRightsReserved, OtherLicense]  where@@ -126,9 +141,10 @@    version   v = Just (Version v [])  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 (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)@@ -140,16 +156,22 @@       ("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+      _                              -> UnknownLicense $ name +++                                        maybe "" (('-':) . display) version  dispOptVersion :: Maybe Version -> Disp.Doc dispOptVersion Nothing  = Disp.empty-dispOptVersion (Just v) = Disp.char '-' <> disp v+dispOptVersion (Just v) = dispVersion v++dispVersion :: Version -> Disp.Doc+dispVersion v = Disp.char '-' <> disp v

cabal/Cabal/Distribution/Make.hs view

@@ -2,6 +2,7 @@ -- | -- Module      :  Distribution.Make -- Copyright   :  Martin Sj&#xF6;gren 2004+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -16,7 +17,7 @@ -- that it works. -- -- Uses the parsed command-line from "Distribution.Simple.Setup" in order to build--- Haskell tools using a backend build system based on make. Obviously we+-- Haskell tools using a back-end build system based on make. Obviously we -- assume that there is a configure script, and that after the ConfigCmd has -- been run, there is a Makefile. Further assumptions: --@@ -53,36 +54,6 @@ --                              $(MAKE) install prefix=$(destdir)/$(prefix) \ --                                              bindir=$(destdir)/$(bindir) \ -{- 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. -}- module Distribution.Make (         module Distribution.Package,         License(..), Version(..),@@ -121,7 +92,7 @@  defaultMainHelper :: [String] -> IO () defaultMainHelper args =-  case commandsRun globalCommand commands args of+  case commandsRun (globalCommand commands) commands args of     CommandHelp   help                 -> printHelp help     CommandList   opts                 -> printOptionsList opts     CommandErrors errs                 -> printErrors errs

cabal/Cabal/Distribution/ModuleName.hs view

@@ -1,44 +1,17 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.ModuleName -- Copyright   :  Duncan Coutts 2008+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable -- -- Data type for Haskell module names. -{- 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. -}- module Distribution.ModuleName (         ModuleName,         fromString,@@ -51,21 +24,25 @@ import Distribution.Text          ( Text(..) ) +import Distribution.Compat.Binary (Binary)+import qualified Data.Char as Char+         ( isAlphaNum, isUpper ) import Data.Data (Data) import Data.Typeable (Typeable) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp-import qualified Data.Char as Char-         ( isAlphaNum, isUpper )-import System.FilePath-         ( pathSeparator ) import Data.List          ( intercalate, intersperse )+import GHC.Generics (Generic)+import System.FilePath+         ( pathSeparator )  -- | A valid Haskell module name. -- newtype ModuleName = ModuleName [String]-  deriving (Eq, Ord, Read, Show, Typeable, Data)+  deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)++instance Binary ModuleName  instance Text ModuleName where   disp (ModuleName ms) =

cabal/Cabal/Distribution/Package.hs view

@@ -1,8 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Package -- Copyright   :  Isaac Jones 2003-2004+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -12,36 +15,6 @@ -- a 'Dependency' data type. A dependency is a package name and a version -- range, like @\"foo >= 1.2 && < 2\"@. -{- 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. -}- module Distribution.Package (         -- * Package ids         PackageName(..),@@ -51,6 +24,17 @@         -- * Installed package identifiers         InstalledPackageId(..), +        -- * Package keys (used for linker symbols)+        PackageKey(..),+        mkPackageKey,+        packageKeyHash,+        packageKeyLibraryName,++        -- * Library name (used for install path, package key)+        LibraryName(..),+        emptyLibraryName,+        getHSLibraryName,+         -- * Package source dependencies         Dependency(..),         thisPackageVersion,@@ -59,27 +43,37 @@          -- * Package classes         Package(..), packageName, packageVersion,-        PackageFixedDeps(..),+        HasInstalledPackageId(..),+        PackageInstalled(..),   ) where  import Distribution.Version          ( Version(..), VersionRange, anyVersion, thisVersion          , notThisVersion, simplifyVersionRange ) -import Distribution.Text (Text(..))+import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ((<++)) import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint ((<>), (<+>), text)+ import Control.DeepSeq (NFData(..))-import qualified Data.Char as Char ( isDigit, isAlphaNum )-import Data.List ( intercalate )+import Distribution.Compat.Binary (Binary)+import qualified Data.Char as Char+    ( isDigit, isAlphaNum, isUpper, isLower, ord, chr ) import Data.Data ( Data )+import Data.List ( intercalate, foldl', sort ) import Data.Typeable ( Typeable )+import Data.Word ( Word64 )+import GHC.Fingerprint ( Fingerprint(..), fingerprintString )+import GHC.Generics (Generic)+import Numeric ( showIntAtBase )+import Text.PrettyPrint ((<>), (<+>), text) -newtype PackageName = PackageName String-    deriving (Read, Show, Eq, Ord, Typeable, Data)+newtype PackageName = PackageName { unPackageName :: String }+    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) +instance Binary PackageName+ instance Text PackageName where   disp (PackageName n) = Disp.text n   parse = do@@ -104,8 +98,10 @@         pkgName    :: PackageName, -- ^The name of this package, eg. foo         pkgVersion :: Version -- ^the version of this package, eg 1.2      }-     deriving (Read, Show, Eq, Ord, Typeable, Data)+     deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) +instance Binary PackageIdentifier+ instance Text PackageIdentifier where   disp (PackageIdentifier n v) = case v of     Version [] _ -> disp n -- if no version, don't show version.@@ -128,23 +124,192 @@ -- in a package database, or overlay of databases. -- newtype InstalledPackageId = InstalledPackageId String- deriving (Read,Show,Eq,Ord,Typeable,Data)+ deriving (Generic, Read,Show,Eq,Ord,Typeable,Data) +instance Binary InstalledPackageId+ instance Text InstalledPackageId where   disp (InstalledPackageId str) = text str    parse = InstalledPackageId `fmap` Parse.munch1 abi_char-   where abi_char c = Char.isAlphaNum c || c `elem` ":-_."+   where abi_char c = Char.isAlphaNum c || c `elem` "-_."  -- ------------------------------------------------------------+-- * Package Keys+-- ------------------------------------------------------------++-- | A 'PackageKey' is the notion of "package ID" which is visible to the+-- compiler. Why is this not a 'PackageId'? The 'PackageId' is a user-visible+-- concept written explicity in Cabal files; on the other hand, a 'PackageKey'+-- may contain, for example, information about the transitive dependency+-- tree of a package.  Why is this not an 'InstalledPackageId'?  A 'PackageKey'+-- should be stable so that we can incrementally recompile after a source edit;+-- however, an 'InstalledPackageId' may change even with source.+--+-- Package keys may be generated either by Cabal or GHC.  In particular,+-- ordinary, "old-style" packages which don't use Backpack features can+-- have their package keys generated directly by Cabal and coincide with+-- 'LibraryName's.  However, Backpack keys are generated by GHC may exhibit+-- more variation than a 'LibraryName'.+--+data PackageKey+    -- | Modern package key which is a hash of the PackageId and the transitive+    -- dependency key.  It's manually inlined here so we can get the instances+    -- we need.  There's an optional prefix for compatibility with GHC 7.10.+    = PackageKey (Maybe String) {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64+    -- | Old-style package key which is just a 'PackageId'.  Required because+    -- old versions of GHC assume that the 'sourcePackageId' recorded for an+    -- installed package coincides with the package key it was compiled with.+    | OldPackageKey !PackageId+    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)++instance Binary PackageKey++-- | Convenience function which converts a fingerprint into a new-style package+-- key.+fingerprintPackageKey :: Fingerprint -> PackageKey+fingerprintPackageKey (Fingerprint a b) = PackageKey Nothing a b++-- | Generates a 'PackageKey' from a 'PackageId', sorted package keys of the+-- immediate dependencies.+mkPackageKey :: Bool -- are modern style package keys supported?+             -> PackageId+             -> [LibraryName] -- dependencies+             -> PackageKey+mkPackageKey True pid deps =+    fingerprintPackageKey . fingerprintString $+        display pid ++ "\n" +++        concat [ display dep ++ "\n" | dep <- sort deps ]+mkPackageKey False pid _ = OldPackageKey pid++-- The base-62 code is based off of 'locators'+-- ((c) Operational Dynamics Consulting, BSD3 licensed)++-- Note: Instead of base-62 encoding a single 128-bit integer+-- (ceil(21.49) characters), we'll base-62 a pair of 64-bit integers+-- (2 * ceil(10.75) characters).  Luckily for us, it's the same number of+-- characters!  In the long term, this should go in GHC.Fingerprint,+-- but not now...++-- | Size of a 64-bit word when written as a base-62 string+word64Base62Len :: Int+word64Base62Len = 11++-- | Converts a 64-bit word into a base-62 string+toBase62 :: Word64 -> String+toBase62 w = pad ++ str+  where+    pad = replicate len '0'+    len = word64Base62Len - length str -- 11 == ceil(64 / lg 62)+    str = showIntAtBase 62 represent w ""+    represent :: Int -> Char+    represent x+        | x < 10 = Char.chr (48 + x)+        | x < 36 = Char.chr (65 + x - 10)+        | x < 62 = Char.chr (97 + x - 36)+        | otherwise = error ("represent (base 62): impossible!")++-- | Parses a base-62 string into a 64-bit word+fromBase62 :: String -> Word64+fromBase62 ss = foldl' multiply 0 ss+  where+    value :: Char -> Int+    value c+        | Char.isDigit c = Char.ord c - 48+        | Char.isUpper c = Char.ord c - 65 + 10+        | Char.isLower c = Char.ord c - 97 + 36+        | otherwise = error ("value (base 62): impossible!")++    multiply :: Word64 -> Char -> Word64+    multiply acc c = acc * 62 + (fromIntegral $ value c)++-- | Parses a base-62 string into a fingerprint.+readBase62Fingerprint :: String -> Fingerprint+readBase62Fingerprint s = Fingerprint w1 w2+ where (s1,s2) = splitAt word64Base62Len s+       w1 = fromBase62 s1+       w2 = fromBase62 (take word64Base62Len s2)++-- | Compute the hash (without a prefix) of a package key.  In GHC 7.12+-- this is equivalent to display.+packageKeyHash :: PackageKey -> String+packageKeyHash (PackageKey _ w1 w2) = toBase62 w1 ++ toBase62 w2+packageKeyHash (OldPackageKey pid) = display pid++-- | Legacy function for GHC 7.10 to compute a LibraryName based on+-- the package key.+packageKeyLibraryName :: PackageId -> PackageKey -> LibraryName+packageKeyLibraryName pid (PackageKey _ w1 w2) =+  LibraryName (display pid ++ "-" ++ toBase62 w1 ++ toBase62 w2)+packageKeyLibraryName _ (OldPackageKey pid) = LibraryName (display pid)++instance Text PackageKey where+  disp (PackageKey mb_prefix w1 w2)+    = maybe Disp.empty (\r -> Disp.text r <> Disp.char '_') mb_prefix <>+      Disp.text (toBase62 w1) <> Disp.text (toBase62 w2)+  disp (OldPackageKey pid) = disp pid++  parse = parseNewWithAnnot <++ parseNew <++ parseOld+    where parseNew = do+            fmap (fingerprintPackageKey . readBase62Fingerprint)+                . Parse.count (word64Base62Len * 2)+                $ Parse.satisfy Char.isAlphaNum+          parseNewWithAnnot = do+            -- this is ignored+            prefix <- Parse.munch1 (\c -> Char.isAlphaNum c || c `elem` "-")+            _ <- Parse.char '_' -- if we use '-' it's ambiguous+            PackageKey _ w1 w2 <- parseNew+            return (PackageKey (Just prefix) w1 w2)+          parseOld = do pid <- parse+                        return (OldPackageKey pid)++instance NFData PackageKey where+    rnf (PackageKey mb _ _) = rnf mb+    rnf (OldPackageKey pid) = rnf pid++-- ------------------------------------------------------------+-- * Library names+-- ------------------------------------------------------------++-- | A library name consists of not only a source package+-- id ('PackageId') but also the library names of all textual+-- dependencies; thus, a library name uniquely identifies an+-- installed package up to the dependency resolution done by Cabal.+-- Create using 'packageKeyLibraryName'.  Library names are opaque,+-- Cabal-defined strings.+newtype LibraryName+    = LibraryName String+    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)++instance Binary LibraryName++-- | Default library name for when it is not known.+emptyLibraryName :: LibraryName+emptyLibraryName = LibraryName ""++-- | Returns library name prefixed with HS, suitable for filenames+getHSLibraryName :: LibraryName -> String+getHSLibraryName (LibraryName s) = "HS" ++ s++instance Text LibraryName where+    disp (LibraryName s) = Disp.text s+    parse = LibraryName `fmap` Parse.munch1 hash_char+        where hash_char c = Char.isAlphaNum c || c `elem` "-_."++instance NFData LibraryName where+    rnf (LibraryName s) = rnf s++-- ------------------------------------------------------------ -- * Package source dependencies -- ------------------------------------------------------------  -- | Describes a dependency on a source package (API) -- data Dependency = Dependency PackageName VersionRange-                  deriving (Read, Show, Eq, Typeable, Data)+                  deriving (Generic, Read, Show, Eq, Typeable, Data) +instance Binary Dependency+ instance Text Dependency where   disp (Dependency name ver) =     disp name <+> disp ver@@ -192,12 +357,15 @@ instance Package PackageIdentifier where   packageId = id --- | 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.+-- | Packages that have an installed package ID+class Package pkg => HasInstalledPackageId pkg where+  installedPackageId :: pkg -> InstalledPackageId++-- | Class of installed packages. ---class Package pkg => PackageFixedDeps pkg where-  depends :: pkg -> [PackageIdentifier]+-- The primary data type which is an instance of this package is+-- 'InstalledPackageInfo', but when we are doing install plans in Cabal install+-- we may have other, installed package-like things which contain more metadata.+-- Installed packages have exact dependencies 'installedDepends'.+class HasInstalledPackageId pkg => PackageInstalled pkg where+  installedDepends :: pkg -> [InstalledPackageId]

cabal/Cabal/Distribution/PackageDescription.hs view

@@ -1,8 +1,12 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.PackageDescription -- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -21,36 +25,6 @@ -- feature was introduced. It could probably do with being rationalised at some -- point to make it simpler. -{- 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. -}- module Distribution.PackageDescription (         -- * Package descriptions         PackageDescription(..),@@ -60,8 +34,14 @@         BuildType(..),         knownBuildTypes, +        -- ** Renaming+        ModuleRenaming(..),+        defaultRenaming,+        lookupRenaming,+         -- ** Libraries         Library(..),+        ModuleReexport(..),         emptyLibrary,         withLib,         hasLibs,@@ -106,6 +86,8 @@         allExtensions,         usedExtensions,         hcOptions,+        hcProfOptions,+        hcSharedOptions,          -- ** Supplementary build information         HookedBuildInfo,@@ -116,32 +98,48 @@         GenericPackageDescription(..),         Flag(..), FlagName(..), FlagAssignment,         CondTree(..), ConfVar(..), Condition(..),+        cNot,          -- * Source repositories         SourceRepo(..),         RepoKind(..),         RepoType(..),         knownRepoTypes,++        -- * Custom setup build information+        SetupBuildInfo(..),   ) where -import Data.Data   (Data)-import Data.List   (nub, intercalate)-import Data.Maybe  (fromMaybe, maybeToList)-import Data.Monoid (Monoid(mempty, mappend))-import Data.Typeable ( Typeable )-import Control.Monad (MonadPlus(mplus))+import Distribution.Compat.Binary (Binary)+import Data.Data                  (Data)+import Data.Foldable              (traverse_)+import Data.List                  (nub, intercalate)+import Data.Maybe                 (fromMaybe, maybeToList)+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative        (Applicative((<*>), pure))+import Data.Monoid                (Monoid(mempty, mappend))+import Data.Foldable              (Foldable(foldMap))+import Data.Traversable           (Traversable(traverse))+#endif+import Data.Typeable               ( Typeable )+import Control.Applicative         (Alternative(..))+import Control.Monad               (MonadPlus(mplus,mzero), ap)+import GHC.Generics                (Generic) import Text.PrettyPrint as Disp import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.ReadP   ((<++)) import qualified Data.Char as Char (isAlphaNum, isDigit, toLower)+import qualified Data.Map as Map+import Data.Map                    (Map)  import Distribution.Package          ( PackageName(PackageName), PackageIdentifier(PackageIdentifier)-         , Dependency, Package(..) )+         , Dependency, Package(..), PackageName, packageName ) import Distribution.ModuleName ( ModuleName ) import Distribution.Version          ( Version(Version), VersionRange, anyVersion, orLaterVersion          , asVersionIntervals, LowerBound(..) )-import Distribution.License  (License(AllRightsReserved))+import Distribution.License  (License(UnspecifiedLicense)) import Distribution.Compiler (CompilerFlavor) import Distribution.System   (OS, Arch) import Distribution.Text@@ -163,7 +161,7 @@         -- the following are required by all packages:         package        :: PackageIdentifier,         license        :: License,-        licenseFile    :: FilePath,+        licenseFiles   :: [FilePath],         copyright      :: String,         maintainer     :: String,         author         :: String,@@ -179,6 +177,17 @@         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@@ -186,6 +195,7 @@         -- transitioning to specifying just a single version, not a range.         specVersionRaw :: Either Version VersionRange,         buildType      :: Maybe BuildType,+        setupBuildInfo :: Maybe SetupBuildInfo,         -- components         library        :: Maybe Library,         executables    :: [Executable],@@ -197,8 +207,10 @@         extraTmpFiles  :: [FilePath],         extraDocFiles  :: [FilePath]     }-    deriving (Show, Read, Eq, Typeable, Data)+    deriving (Generic, Show, Read, Eq, Typeable, Data) +instance Binary PackageDescription+ instance Package PackageDescription where   packageId = package @@ -233,8 +245,8 @@     =  PackageDescription {                       package      = PackageIdentifier (PackageName "")                                                        (Version [] []),-                      license      = AllRightsReserved,-                      licenseFile  = "",+                      license      = UnspecifiedLicense,+                      licenseFiles = [],                       specVersionRaw = Right anyVersion,                       buildType    = Nothing,                       copyright    = "",@@ -251,6 +263,7 @@                       description  = "",                       category     = "",                       customFieldsPD = [],+                      setupBuildInfo = Nothing,                       library      = Nothing,                       executables  = [],                       testSuites   = [],@@ -275,8 +288,10 @@                 --   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 (Show, Read, Eq, Typeable, Data)+                deriving (Generic, Show, Read, Eq, Typeable, Data) +instance Binary BuildType+ knownBuildTypes :: [BuildType] knownBuildTypes = [Simple, Configure, Make, Custom] @@ -294,23 +309,116 @@       _           -> 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 Monoid SetupBuildInfo where+  mempty = SetupBuildInfo {+    setupDepends = mempty+  }+  mappend a b = SetupBuildInfo {+    setupDepends = combine setupDepends+  }+    where combine field = field a `mappend` field b++-- ---------------------------------------------------------------------------+-- 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+    ModuleRenaming b rns `mappend` ModuleRenaming b' rns'+        = ModuleRenaming (b || b') (rns ++ rns') -- ToDo: dedupe?+    mempty = ModuleRenaming False []++-- 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 {         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 (Show, Eq, Read, Typeable, Data)+    deriving (Generic, Show, Eq, Read, Typeable, Data) +instance Binary Library+ instance Monoid Library where   mempty = Library {     exposedModules = mempty,+    reexportedModules = mempty,+    requiredSignatures = mempty,+    exposedSignatures = mempty,     libExposed     = True,     libBuildInfo   = mempty   }   mappend a b = Library {     exposedModules = combine exposedModules,+    reexportedModules = combine reexportedModules,+    requiredSignatures = combine requiredSignatures,+    exposedSignatures = combine exposedSignatures,     libExposed     = libExposed a && libExposed b, -- so False propagates     libBuildInfo   = combine libBuildInfo   }@@ -334,13 +442,50 @@ --  function with the library build info as argument. withLib :: PackageDescription -> (Library -> IO ()) -> IO () withLib pkg_descr f =-   maybe (return ()) f (maybeHasLibs pkg_descr)+   traverse_ f (maybeHasLibs pkg_descr)  -- | 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 @@ -349,8 +494,10 @@         modulePath :: FilePath,         buildInfo  :: BuildInfo     }-    deriving (Show, Read, Eq, Typeable, Data)+    deriving (Generic, Show, Read, Eq, Typeable, Data) +instance Binary Executable+ instance Monoid Executable where   mempty = Executable {     exeName    = mempty,@@ -403,8 +550,10 @@         -- a better solution is waiting on the next overhaul to the         -- GenericPackageDescription -> PackageDescription resolution process.     }-    deriving (Show, Read, Eq, Typeable, Data)+    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. --@@ -429,8 +578,10 @@      -- the given reason (e.g. unknown test type).      --    | TestSuiteUnsupported TestType-   deriving (Eq, Read, Show, Typeable, Data)+   deriving (Eq, Generic, Read, Show, Typeable, Data) +instance Binary TestSuiteInterface+ instance Monoid TestSuite where     mempty = TestSuite {         testName      = mempty,@@ -485,8 +636,10 @@ 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 (Show, Read, Eq, Typeable, Data)+    deriving (Generic, Show, Read, Eq, Typeable, Data) +instance Binary TestType+ knownTestTypes :: [TestType] knownTestTypes = [ TestTypeExe (Version [1,0] [])                  , TestTypeLib (Version [0,9] []) ]@@ -534,8 +687,10 @@         benchmarkEnabled   :: Bool         -- TODO: See TODO for 'testEnabled'.     }-    deriving (Show, Read, Eq, Typeable, Data)+    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. --@@ -556,8 +711,10 @@      -- interfaces for the given reason (e.g. unknown benchmark type).      --    | BenchmarkUnsupported BenchmarkType-   deriving (Eq, Read, Show, Typeable, Data)+   deriving (Eq, Generic, Read, Show, Typeable, Data) +instance Binary BenchmarkInterface+ instance Monoid Benchmark where     mempty = Benchmark {         benchmarkName      = mempty,@@ -610,8 +767,10 @@                      -- ^ \"type: exitcode-stdio-x.y\"                    | BenchmarkTypeUnknown String Version                      -- ^ Some unknown benchmark type e.g. \"type: foo\"-    deriving (Show, Read, Eq, Typeable, Data)+    deriving (Generic, Show, Read, Eq, Typeable, Data) +instance Binary BenchmarkType+ knownBenchmarkTypes :: [BenchmarkType] knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ] @@ -642,7 +801,8 @@         pkgconfigDepends  :: [Dependency], -- ^ pkg-config packages that are used         frameworks        :: [String], -- ^support frameworks for Mac OS X         cSources          :: [FilePath],-        hsSourceDirs      :: [FilePath], -- ^ where to look for the haskell module hierarchy+        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@@ -652,20 +812,24 @@         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])],-        ghcProfOptions    :: [String],-        ghcSharedOptions  :: [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+        targetBuildDepends :: [Dependency], -- ^ Dependencies specific to a library or executable target+        targetBuildRenaming :: Map PackageName ModuleRenaming     }-    deriving (Show,Read,Eq,Typeable,Data)+    deriving (Generic, Show, Read, Eq, Typeable, Data) +instance Binary BuildInfo+ instance Monoid BuildInfo where   mempty = BuildInfo {     buildable         = True,@@ -676,6 +840,7 @@     pkgconfigDepends  = [],     frameworks        = [],     cSources          = [],+    jsSources         = [],     hsSourceDirs      = [],     otherModules      = [],     defaultLanguage   = Nothing,@@ -684,15 +849,17 @@     otherExtensions   = [],     oldExtensions     = [],     extraLibs         = [],+    extraGHCiLibs     = [],     extraLibDirs      = [],     includeDirs       = [],     includes          = [],     installIncludes   = [],     options           = [],-    ghcProfOptions    = [],-    ghcSharedOptions  = [],+    profOptions       = [],+    sharedOptions     = [],     customFieldsBI    = [],-    targetBuildDepends = []+    targetBuildDepends = [],+    targetBuildRenaming = Map.empty   }   mappend a b = BuildInfo {     buildable         = buildable a && buildable b,@@ -703,6 +870,7 @@     pkgconfigDepends  = combine    pkgconfigDepends,     frameworks        = combineNub frameworks,     cSources          = combineNub cSources,+    jsSources         = combineNub jsSources,     hsSourceDirs      = combineNub hsSourceDirs,     otherModules      = combineNub otherModules,     defaultLanguage   = combineMby defaultLanguage,@@ -711,20 +879,23 @@     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,-    ghcProfOptions    = combine    ghcProfOptions,-    ghcSharedOptions  = combine    ghcSharedOptions,+    profOptions       = combine    profOptions,+    sharedOptions     = combine    sharedOptions,     customFieldsBI    = combine    customFieldsBI,-    targetBuildDepends = combineNub targetBuildDepends+    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@@ -775,10 +946,20 @@  -- |Select options for a particular Haskell compiler. hcOptions :: CompilerFlavor -> BuildInfo -> [String]-hcOptions hc bi = [ opt | (hc',opts) <- options bi-                        , hc' == hc-                        , opt <- opts ]+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 -- ------------------------------------------------------------@@ -838,8 +1019,10 @@   -- given the default is \".\" ie no subdirectory.   repoSubdir   :: Maybe FilePath }-  deriving (Eq, Read, Show, Typeable, Data)+  deriving (Eq, Generic, Read, Show, Typeable, Data) +instance Binary SourceRepo+ -- | What this repo info is for, what it represents. -- data RepoKind =@@ -854,8 +1037,10 @@   | RepoThis    | RepoKindUnknown String-  deriving (Eq, Ord, Read, Show, Typeable, Data)+  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.@@ -863,8 +1048,10 @@ data RepoType = Darcs | Git | SVN | CVS               | Mercurial | GnuArch | Bazaar | Monotone               | OtherRepoType String-  deriving (Eq, Ord, Read, Show, Typeable, Data)+  deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) +instance Binary RepoType+ knownRepoTypes :: [RepoType] knownRepoTypes = [Darcs, Git, SVN, CVS                  ,Mercurial, GnuArch, Bazaar, Monotone]@@ -928,7 +1115,7 @@        updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo)                        -> [Executable]        -- ^list of executables to update-                       -> [Executable]        -- ^libst with exeName updated+                       -> [Executable]        -- ^list with exeName updated       updateExecutable _                 []         = []       updateExecutable exe_bi'@(name,bi) (exe:exes)         | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes@@ -965,8 +1152,10 @@  -- | A 'FlagName' is the name of a user-defined configuration flag newtype FlagName = FlagName String-    deriving (Eq, Ord, Show, Read, Typeable, Data)+    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@@@ -981,13 +1170,6 @@              | Impl CompilerFlavor VersionRange     deriving (Eq, Show, Typeable, Data) ---instance Text ConfVar where---    disp (OS os) = "os(" ++ display os ++ ")"---    disp (Arch arch) = "arch(" ++ display arch ++ ")"---    disp (Flag (ConfFlag f)) = "flag(" ++ f ++ ")"---    disp (Impl c v) = "impl(" ++ display c---                       ++ " " ++ display v ++ ")"- -- | A boolean expression parameterized over the variable type used. data Condition c = Var c                  | Lit Bool@@ -996,13 +1178,58 @@                  | CAnd (Condition c) (Condition c)     deriving (Show, Eq, Typeable, Data) ---instance Text c => Text (Condition c) where---  disp (Var x) = text (show x)---  disp (Lit b) = text (show b)---  disp (CNot c) = char '!' <> parens (ppCond c)---  disp (COr c1 c2) = parens $ sep [ppCond c1, text "||" <+> ppCond c2]---  disp (CAnd c1 c2) = parens $ sep [ppCond c1, text "&&" <+> ppCond c2]+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   = 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  = return+  (<*>) = ap++instance Monad Condition where+  return = Var+  -- 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 = COr++instance Alternative Condition where+  empty = mempty+  (<|>) = mappend++instance MonadPlus Condition where+  mzero = mempty+  mplus = mappend+ data CondTree v c a = CondNode     { condTreeData        :: a     , condTreeConstraints :: c@@ -1011,16 +1238,3 @@                               , Maybe (CondTree v c a))]     }     deriving (Show, Eq, Typeable, Data)----instance (Text v, Text c) => Text (CondTree v c a) where---  disp (CondNode _dat cs ifs) =---    (text "build-depends: " <+>---      disp cs)---    $+$---    (vcat $ map ppIf ifs)---  where---    ppIf (c,thenTree,mElseTree) =---        ((text "if" <+> ppCond c <> colon) $$---          nest 2 (ppCondTree thenTree disp))---        $+$ (maybe empty (\t -> text "else: " $$ nest 2 (ppCondTree t disp))---                   mElseTree)

cabal/Cabal/Distribution/PackageDescription/Check.hs view

@@ -2,6 +2,7 @@ -- | -- Module      :  Distribution.PackageDescription.Check -- Copyright   :  Lennart Kolmodin 2008+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -14,41 +15,11 @@ -- different kinds of check so we can see which ones are appropriate to report -- in different situations. This code gets uses when configuring a package when -- we consider only basic problems. The higher standard is uses when when--- preparing a source tarball and by hackage when uploading new packages. The+-- preparing a source tarball and by Hackage when uploading new packages. The -- reason for this is that we want to hold packages that are expected to be -- distributed to a higher standard than packages that are only ever expected -- to be used on the author's own environment. -{- 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. -}- module Distribution.PackageDescription.Check (         -- * Package Checking         PackageCheck(..),@@ -69,12 +40,14 @@          ( filterM, liftM ) import qualified System.Directory as System          ( doesFileExist, doesDirectoryExist )+import qualified Data.Map as Map  import Distribution.PackageDescription import Distribution.PackageDescription.Configuration          ( flattenPackageDescription, finalizePackageDescription ) import Distribution.Compiler-         ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..) )+         ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..)+         , unknownCompilerInfo, AbiTag(..) ) import Distribution.System          ( OS(..), Arch(..), buildPlatform ) import Distribution.License@@ -82,7 +55,7 @@ import Distribution.Simple.CCompiler          ( filenameCDialect ) import Distribution.Simple.Utils-         ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase )+         ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase, startsWithBOM, fromUTF8 )  import Distribution.Version          ( Version(..)@@ -102,10 +75,13 @@  import qualified Language.Haskell.Extension as Extension (deprecatedExtensions) import Language.Haskell.Extension-         ( Language(UnknownLanguage), knownLanguages, Extension(..), KnownExtension(..) )+         ( Language(UnknownLanguage), knownLanguages+         , Extension(..), KnownExtension(..) )+import qualified System.Directory (getDirectoryContents)+import System.IO (openBinaryFile, IOMode(ReadMode), hGetContents) import System.FilePath          ( (</>), takeExtension, isRelative, isAbsolute-         , splitDirectories,  splitPath )+         , splitDirectories,  splitPath, splitExtension ) import System.FilePath.Windows as FilePath.Windows          ( isValid ) @@ -128,13 +104,17 @@      | PackageBuildWarning { explanation :: String }         -- | An issue that might not be a problem for the package author but-       -- might be annoying or determental when the package is distributed to+       -- might be annoying or detrimental when the package is distributed to        -- users. We should encourage distributed packages to be free from these        -- issues, but occasionally there are justifiable reasons so we cannot        -- ban them entirely.      | PackageDistSuspicious { explanation :: String } -       -- | An issue that is ok in the author's environment but is almost+       -- | Like PackageDistSuspicious but will only display warnings+       -- rather than causing abnormal exit.+     | PackageDistSuspiciousWarn { explanation :: String }++       -- | An issue that is OK in the author's environment but is almost        -- certain to be a portability problem for other environments. We can        -- quite legitimately refuse to publicly distribute packages with these        -- problems.@@ -148,19 +128,19 @@ check False _  = Nothing check True  pc = Just pc -checkSpecVersion :: PackageDescription -> [Int] -> Bool -> PackageCheck -> Maybe PackageCheck+checkSpecVersion :: PackageDescription -> [Int] -> Bool -> PackageCheck+                 -> Maybe PackageCheck checkSpecVersion pkg specver cond pc   | specVersion pkg >= Version specver [] = Nothing   | otherwise                             = check cond pc - -- ------------------------------------------------------------ -- * Standard checks -- ------------------------------------------------------------  -- | Check for common mistakes and problems in package descriptions. ----- This is the standard collection of checks covering all apsects except+-- This is the standard collection of checks covering all aspects except -- for checks that require looking at files within the package. For those -- see 'checkPackageFiles'. --@@ -175,6 +155,7 @@      checkConfiguredPackage pkg   ++ checkConditionals gpkg   ++ checkPackageVersions gpkg+  ++ checkDevelopmentOnlyFlags gpkg   where     pkg = fromMaybe (flattenPackageDescription gpkg) mpkg @@ -209,16 +190,20 @@   , check (null . versionBranch . packageVersion $ pkg) $       PackageBuildImpossible "No 'version' field." -  , check (null (executables pkg) && isNothing (library pkg)) $+  , check (all ($ pkg) [ null . executables+                       , null . testSuites+                       , null . benchmarks+                       , isNothing . library ]) $       PackageBuildImpossible-        "No executables and no library found. Nothing to do."+        "No executables, libraries, tests, or benchmarks found. Nothing to do."    , check (not (null duplicateNames)) $       PackageBuildImpossible $ "Duplicate sections: " ++ commaSep duplicateNames         ++ ". The name of every executable, test suite, and benchmark section in"         ++ " the package must be unique."   ]-  --TODO: check for name clashes case insensitively: windows file systems cannot cope.+  --TODO: check for name clashes case insensitively: windows file systems cannot+  --cope.    ++ maybe []  (checkLibrary    pkg) (library pkg)   ++ concatMap (checkExecutable pkg) (executables pkg)@@ -240,18 +225,35 @@     duplicateNames = dups $ exeNames ++ testNames ++ bmNames  checkLibrary :: PackageDescription -> Library -> [PackageCheck]-checkLibrary _pkg lib =+checkLibrary pkg lib =   catMaybes [      check (not (null moduleDuplicates)) $        PackageBuildImpossible $             "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'."++  , checkVersion [1,21] (not (null (exposedSignatures lib))) $+      PackageDistInexcusable $+           "To use the 'exposed-signatures' field the package needs to specify "+        ++ "at least 'cabal-version: >= 1.21'."   ]    where-    moduleDuplicates = dups (libModules lib)+    checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck+    checkVersion ver cond pc+      | specVersion pkg >= Version ver []      = Nothing+      | otherwise                              = check cond pc +    moduleDuplicates = dups (libModules lib +++                             map moduleReexportName (reexportedModules lib))+ checkExecutable :: PackageDescription -> Executable -> [PackageCheck] checkExecutable pkg exe =   catMaybes [@@ -414,6 +416,12 @@           ++ commaSep (map display knownBuildTypes)       _ -> Nothing +  , check (isJust (setupBuildInfo pkg) && buildType pkg /= Just Custom) $+      PackageBuildWarning $+           "Ignoring the 'custom-setup' section because the 'build-type' is "+        ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a "+        ++ "custom Setup.hs script."+   , check (not (null unknownCompilers)) $       PackageBuildWarning $         "Unknown compiler " ++ commaSep (map quote unknownCompilers)@@ -458,7 +466,7 @@   , check (null (synopsis pkg) && not (null (description pkg))) $       PackageDistSuspicious "No 'synopsis' field." -    --TODO: recommend the bug reports url, author and homepage fields+    --TODO: recommend the bug reports URL, author and homepage fields     --TODO: recommend not using the stability field     --TODO: recommend specifying a source repo @@ -502,10 +510,13 @@ checkLicense pkg =   catMaybes [ -    check (license pkg == AllRightsReserved) $+    check (license pkg == UnspecifiedLicense) $       PackageDistInexcusable-        "The 'license' field is missing or specified as AllRightsReserved."+        "The 'license' field is missing." +  , check (license pkg == AllRightsReserved) $+      PackageDistSuspicious+        "The 'license' is AllRightsReserved. Is that really what you want?"   , case license pkg of       UnknownLicense l -> Just $         PackageBuildWarning $@@ -530,10 +541,11 @@           ++ "version then please file a ticket."       _ -> Nothing -  , check (license pkg `notElem` [AllRightsReserved, PublicDomain]+  , check (license pkg `notElem` [ AllRightsReserved+                                 , UnspecifiedLicense, PublicDomain]            -- AllRightsReserved and PublicDomain are not strictly            -- licenses so don't need license files.-        && null (licenseFile pkg)) $+        && null (licenseFiles pkg)) $       PackageDistSuspicious "A 'license-file' is not specified."   ]   where@@ -591,19 +603,7 @@ checkGhcOptions pkg =   catMaybes [ -    check has_WerrorWall $-      PackageDistInexcusable $-           "'ghc-options: -Wall -Werror' makes the package very easy to "-        ++ "break with future GHC versions because new GHC versions often "-        ++ "add new warnings. Use just 'ghc-options: -Wall' instead."--  , check (not has_WerrorWall && has_Werror) $-      PackageDistSuspicious $-           "'ghc-options: -Werror' makes the package easy to "-        ++ "break with future GHC versions because new GHC versions often "-        ++ "add new warnings."--  , checkFlags ["-fasm"] $+    checkFlags ["-fasm"] $       PackageDistInexcusable $            "'ghc-options: -fasm' is unnecessary and will not work on CPU "         ++ "architectures other than x86, x86-64, ppc or sparc."@@ -615,18 +615,10 @@         ++ "is using the FFI incorrectly and will probably not work with GHC "         ++ "6.10 or later." -  , checkFlags ["-fdefer-type-errors"] $-      PackageDistInexcusable $-          "'ghc-options: -fdefer-type-errors' is fine during development but "-       ++ "is not appropriate for a distributed package."-   , checkFlags ["-fhpc"] $       PackageDistInexcusable $-        "'ghc-options: -fhpc' is not appropriate for a distributed package."--  , check (any ("-d" `isPrefixOf`) all_ghc_options) $-      PackageDistInexcusable $-        "'ghc-options: -d*' debug flags are not appropriate for a distributed package."+           "'ghc-options: -fhpc' is not not necessary. Use the configure flag "+        ++ " --enable-coverage instead."    , checkFlags ["-prof"] $       PackageBuildWarning $@@ -636,37 +628,43 @@    , checkFlags ["-o"] $       PackageBuildWarning $-        "'ghc-options: -o' is not needed. The output files are named automatically."+           "'ghc-options: -o' is not needed. "+        ++ "The output files are named automatically."    , checkFlags ["-hide-package"] $       PackageBuildWarning $-           "'ghc-options: -hide-package' is never needed. Cabal hides all packages."+      "'ghc-options: -hide-package' is never needed. "+      ++ "Cabal hides all packages."    , checkFlags ["--make"] $       PackageBuildWarning $-        "'ghc-options: --make' is never needed. Cabal uses this automatically."+      "'ghc-options: --make' is never needed. Cabal uses this automatically."    , checkFlags ["-main-is"] $       PackageDistSuspicious $-           "'ghc-options: -main-is' is not portable."+      "'ghc-options: -main-is' is not portable."    , checkFlags ["-O0", "-Onot"] $       PackageDistSuspicious $-        "'ghc-options: -O0' is not needed. Use the --disable-optimization configure flag."+      "'ghc-options: -O0' is not needed. "+      ++ "Use the --disable-optimization configure flag."    , checkFlags [ "-O", "-O1"] $       PackageDistInexcusable $-           "'ghc-options: -O' is not needed. Cabal automatically adds the '-O' flag. "-        ++ "Setting it yourself interferes with the --disable-optimization flag."+      "'ghc-options: -O' is not needed. "+      ++ "Cabal automatically adds the '-O' flag. "+      ++ "Setting it yourself interferes with the --disable-optimization flag."    , checkFlags ["-O2"] $-      PackageDistSuspicious $-           "'ghc-options: -O2' is rarely needed. Check that it is giving a real benefit "-        ++ "and not just imposing longer compile times on your users."+      PackageDistSuspiciousWarn $+      "'ghc-options: -O2' is rarely needed. "+      ++ "Check that it is giving a real benefit "+      ++ "and not just imposing longer compile times on your users."    , checkFlags ["-split-objs"] $       PackageBuildWarning $-        "'ghc-options: -split-objs' is not needed. Use the --enable-split-objs configure flag."+        "'ghc-options: -split-objs' is not needed. "+        ++ "Use the --enable-split-objs configure flag."    , checkFlags ["-optl-Wl,-s", "-optl-s"] $       PackageDistInexcusable $@@ -678,13 +676,24 @@    , checkFlags ["-fglasgow-exts"] $       PackageDistSuspicious $-        "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use the 'extensions' field."+        "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use "+        ++ "the 'extensions' field."    , check ("-threaded" `elem` lib_ghc_options) $-      PackageDistSuspicious $+      PackageBuildWarning $            "'ghc-options: -threaded' has no effect for libraries. It should "         ++ "only be used for executables." +  , check ("-rtsopts" `elem` lib_ghc_options) $+      PackageBuildWarning $+           "'ghc-options: -rtsopts' has no effect for libraries. It should "+        ++ "only be used for executables."++  , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $+      PackageBuildWarning $+           "'ghc-options: -with-rtsopts' has no effect for libraries. It "+        ++ "should only be used for executables."+   , checkAlternatives "ghc-options" "extensions"       [ (flag, display extension) | flag <- all_ghc_options                                   , Just extension <- [ghcExtension flag] ]@@ -707,54 +716,51 @@   ]    where-    has_WerrorWall = flip any ghc_options $ \opts ->-                               "-Werror" `elem` opts-                           && ("-Wall"   `elem` opts || "-W" `elem` opts)-    has_Werror     = any (\opts -> "-Werror" `elem` opts) ghc_options--    ghc_options = [ strs | bi <- allBuildInfo pkg-                         , (GHC, strs) <- options bi ]-    all_ghc_options = concat ghc_options-    lib_ghc_options = maybe [] (hcOptions GHC . libBuildInfo) (library pkg)+    all_ghc_options    = concatMap get_ghc_options (allBuildInfo pkg)+    lib_ghc_options    = maybe [] (get_ghc_options . libBuildInfo) (library pkg)+    get_ghc_options bi = hcOptions GHC bi ++ hcProfOptions GHC bi      checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck     checkFlags flags = check (any (`elem` flags) all_ghc_options)      ghcExtension ('-':'f':name) = case name of-      "allow-overlapping-instances"    -> Just (EnableExtension  OverlappingInstances)-      "no-allow-overlapping-instances" -> Just (DisableExtension OverlappingInstances)-      "th"                             -> Just (EnableExtension  TemplateHaskell)-      "no-th"                          -> Just (DisableExtension TemplateHaskell)-      "ffi"                            -> Just (EnableExtension  ForeignFunctionInterface)-      "no-ffi"                         -> Just (DisableExtension ForeignFunctionInterface)-      "fi"                             -> Just (EnableExtension  ForeignFunctionInterface)-      "no-fi"                          -> Just (DisableExtension ForeignFunctionInterface)-      "monomorphism-restriction"       -> Just (EnableExtension  MonomorphismRestriction)-      "no-monomorphism-restriction"    -> Just (DisableExtension MonomorphismRestriction)-      "mono-pat-binds"                 -> Just (EnableExtension  MonoPatBinds)-      "no-mono-pat-binds"              -> Just (DisableExtension MonoPatBinds)-      "allow-undecidable-instances"    -> Just (EnableExtension  UndecidableInstances)-      "no-allow-undecidable-instances" -> Just (DisableExtension UndecidableInstances)-      "allow-incoherent-instances"     -> Just (EnableExtension  IncoherentInstances)-      "no-allow-incoherent-instances"  -> Just (DisableExtension IncoherentInstances)-      "arrows"                         -> Just (EnableExtension  Arrows)-      "no-arrows"                      -> Just (DisableExtension Arrows)-      "generics"                       -> Just (EnableExtension  Generics)-      "no-generics"                    -> Just (DisableExtension Generics)-      "implicit-prelude"               -> Just (EnableExtension  ImplicitPrelude)-      "no-implicit-prelude"            -> Just (DisableExtension ImplicitPrelude)-      "implicit-params"                -> Just (EnableExtension  ImplicitParams)-      "no-implicit-params"             -> Just (DisableExtension ImplicitParams)-      "bang-patterns"                  -> Just (EnableExtension  BangPatterns)-      "no-bang-patterns"               -> Just (DisableExtension BangPatterns)-      "scoped-type-variables"          -> Just (EnableExtension  ScopedTypeVariables)-      "no-scoped-type-variables"       -> Just (DisableExtension ScopedTypeVariables)-      "extended-default-rules"         -> Just (EnableExtension  ExtendedDefaultRules)-      "no-extended-default-rules"      -> Just (DisableExtension ExtendedDefaultRules)+      "allow-overlapping-instances"    -> enable  OverlappingInstances+      "no-allow-overlapping-instances" -> disable OverlappingInstances+      "th"                             -> enable  TemplateHaskell+      "no-th"                          -> disable TemplateHaskell+      "ffi"                            -> enable  ForeignFunctionInterface+      "no-ffi"                         -> disable ForeignFunctionInterface+      "fi"                             -> enable  ForeignFunctionInterface+      "no-fi"                          -> disable ForeignFunctionInterface+      "monomorphism-restriction"       -> enable  MonomorphismRestriction+      "no-monomorphism-restriction"    -> disable MonomorphismRestriction+      "mono-pat-binds"                 -> enable  MonoPatBinds+      "no-mono-pat-binds"              -> disable MonoPatBinds+      "allow-undecidable-instances"    -> enable  UndecidableInstances+      "no-allow-undecidable-instances" -> disable UndecidableInstances+      "allow-incoherent-instances"     -> enable  IncoherentInstances+      "no-allow-incoherent-instances"  -> disable IncoherentInstances+      "arrows"                         -> enable  Arrows+      "no-arrows"                      -> disable Arrows+      "generics"                       -> enable  Generics+      "no-generics"                    -> disable Generics+      "implicit-prelude"               -> enable  ImplicitPrelude+      "no-implicit-prelude"            -> disable ImplicitPrelude+      "implicit-params"                -> enable  ImplicitParams+      "no-implicit-params"             -> disable ImplicitParams+      "bang-patterns"                  -> enable  BangPatterns+      "no-bang-patterns"               -> disable BangPatterns+      "scoped-type-variables"          -> enable  ScopedTypeVariables+      "no-scoped-type-variables"       -> disable ScopedTypeVariables+      "extended-default-rules"         -> enable  ExtendedDefaultRules+      "no-extended-default-rules"      -> disable ExtendedDefaultRules       _                                -> Nothing-    ghcExtension "-cpp"             = Just (EnableExtension CPP)+    ghcExtension "-cpp"             = enable CPP     ghcExtension _                  = Nothing +    enable  e = Just (EnableExtension e)+    disable e = Just (DisableExtension e)+ checkCCOptions :: PackageDescription -> [PackageCheck] checkCCOptions pkg =   catMaybes [@@ -818,7 +824,7 @@   , isOutsideTree path ]   ++   [ PackageDistInexcusable $-      quote (kind ++ ": " ++ path) ++ " is an absolute directory."+      quote (kind ++ ": " ++ path) ++ " is an absolute path."   | (path, kind) <- relPaths   , isAbsolute path ]   ++@@ -857,8 +863,10 @@       ++ [ (path, "extra-doc-files") | path <- extraDocFiles pkg ]       ++ [ (path, "data-files")      | path <- dataFiles     pkg ]       ++ [ (path, "data-dir")        | path <- [dataDir      pkg]]+      ++ [ (path, "license-file")    | path <- licenseFiles  pkg ]       ++ concat          [    [ (path, "c-sources")        | path <- cSources        bi ]+           ++ [ (path, "js-sources")       | path <- jsSources       bi ]            ++ [ (path, "install-includes") | path <- installIncludes bi ]            ++ [ (path, "hs-source-dirs")   | path <- hsSourceDirs    bi ]          | bi <- allBuildInfo pkg ]@@ -869,7 +877,7 @@         ++ [ (path, "extra-lib-dirs")   | path <- extraLibDirs    bi ]       | bi <- allBuildInfo pkg ] ---TODO: check sets of paths that would be interpreted differently between unix+--TODO: check sets of paths that would be interpreted differently between Unix -- and windows, ie case-sensitive or insensitive. Things that might clash, or -- conversely be distinguished. @@ -931,6 +939,22 @@         ++ "different modules then list the other ones in the "         ++ "'other-languages' field." +    -- check use of reexported-modules sections+  , checkVersion [1,21]+    (maybe False (not.null.reexportedModules) (library 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)) $+      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'."+     -- check use of default-extensions field     -- don't need to do the equivalent check for other-extensions   , checkVersion [1,10] (any (not . null) (buildInfoField defaultExtensions)) $@@ -965,7 +989,7 @@            "The package uses wildcard syntax in the 'build-depends' field: "         ++ commaSep (map display depsUsingWildcardSyntax)         ++ ". To use this new syntax the package need to specify at least "-        ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability "+        ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatibility "         ++ "is important then use: " ++ commaSep            [ display (Dependency name (eliminateWildcardSyntax versionRange))            | Dependency name versionRange <- depsUsingWildcardSyntax ]@@ -985,7 +1009,7 @@            "The package uses wildcard syntax in the 'tested-with' field: "         ++ commaSep (map display testedWithUsingWildcardSyntax)         ++ ". To use this new syntax the package need to specify at least "-        ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability "+        ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatibility "         ++ "is important then use: " ++ commaSep            [ display (Dependency name (eliminateWildcardSyntax versionRange))            | Dependency name versionRange <- testedWithUsingWildcardSyntax ]@@ -996,7 +1020,7 @@            "Using wildcards like "         ++ commaSep (map quote $ take 3 dataFilesUsingGlobSyntax)         ++ " in the 'data-files' field requires 'cabal-version: >= 1.6'. "-        ++ "Alternatively if you require compatability with earlier Cabal "+        ++ "Alternatively if you require compatibility with earlier Cabal "         ++ "versions then list all the files explicitly."      -- check use of "extra-source-files: mk/*.in" syntax@@ -1006,7 +1030,7 @@         ++ commaSep (map quote $ take 3 extraSrcFilesUsingGlobSyntax)         ++ " in the 'extra-source-files' field requires "         ++ "'cabal-version: >= 1.6'. Alternatively if you require "-        ++ "compatability with earlier Cabal versions then list all the files "+        ++ "compatibility with earlier Cabal versions then list all the files "         ++ "explicitly."      -- check use of "source-repository" section@@ -1022,7 +1046,7 @@            "Unfortunately the license " ++ quote (display (license pkg))         ++ " messes up the parser in earlier Cabal versions so you need to "         ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "-        ++ "compatability with earlier Cabal versions then use 'OtherLicense'."+        ++ "compatibility with earlier Cabal versions then use 'OtherLicense'."      -- check for new language extensions   , checkVersion [1,2,3] (not (null mentionedExtensionsThatNeedCabal12)) $@@ -1031,7 +1055,7 @@         ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal12)         ++ " break the parser in earlier Cabal versions so you need to "         ++ "specify 'cabal-version: >= 1.2.3'. Alternatively if you require "-        ++ "compatability with earlier Cabal versions then you may be able to "+        ++ "compatibility with earlier Cabal versions then you may be able to "         ++ "use an equivalent compiler-specific flag."    , checkVersion [1,4] (not (null mentionedExtensionsThatNeedCabal14)) $@@ -1040,8 +1064,29 @@         ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal14)         ++ " break the parser in earlier Cabal versions so you need to "         ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "-        ++ "compatability with earlier Cabal versions then you may be able to "+        ++ "compatibility with earlier Cabal versions then you may be able to "         ++ "use an equivalent compiler-specific flag."++  , check (specVersion pkg >= Version [1,23] []+           && isNothing (setupBuildInfo pkg)+           && buildType pkg == Just Custom) $+      PackageBuildWarning $+           "Packages using 'cabal-version: >= 1.23' with 'build-type: Custom' "+        ++ "must use a 'custom-setup' section with a 'setup-depends' field "+        ++ "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 < Version [1,23] []+           && isNothing (setupBuildInfo pkg)+           && buildType pkg == Just Custom) $+      PackageDistSuspicious $+           "From version 1.23 cabal supports specifiying explicit dependencies "+        ++ "for Custom setup scripts. Consider using cabal-version >= 1.23 and "+        ++ "adding a 'custom-setup' section with a 'setup-depends' field "+        ++ "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'."   ]   where     -- Perform a check on packages that use a version of the spec less than@@ -1101,10 +1146,20 @@     depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg                                     , usesWildcardSyntax vr ] -    testedWithUsingWildcardSyntax = [ Dependency (PackageName (display compiler)) vr-                                    | (compiler, vr) <- testedWith 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, rns) <- Map.toList (targetBuildRenaming bi)+      , rns /= ModuleRenaming True [] ] +    testedWithUsingWildcardSyntax =+      [ Dependency (PackageName (display compiler)) vr+      | (compiler, vr) <- testedWith pkg+      , usesWildcardSyntax vr ]+     usesWildcardSyntax :: VersionRange -> Bool     usesWildcardSyntax =       foldVersionRange'@@ -1123,7 +1178,8 @@         intersectVersionRanges unionVersionRanges id      compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4-                     , PublicDomain, AllRightsReserved, OtherLicense ]+                     , PublicDomain, AllRightsReserved+                     , UnspecifiedLicense, OtherLicense ]      mentionedExtensions = [ ext | bi <- allBuildInfo pkg                                 , ext <- allExtensions bi ]@@ -1168,7 +1224,7 @@  -- | 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 presense but do not pretty print them!+-- we complain of their presence but do not pretty print them! -- displayRawVersionRange :: VersionRange -> String displayRawVersionRange =@@ -1183,8 +1239,10 @@      (\v   -> (Disp.text ">=" <> disp v                   , 0))      (\v   -> (Disp.text "<=" <> disp v                   , 0))      (\v _ -> (Disp.text "==" <> dispWild 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))+     (\(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)) -- parens    where@@ -1224,7 +1282,7 @@         ++ "new major version of the 'base' package is released. If you are "         ++ "not sure what upper bound to use then use the next  major "         ++ "version. For example if you have tested your package with 'base' "-        ++ "version 2 and 3 then use 'build-depends: base >= 2 && < 4'."+        ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'."    ]   where@@ -1237,7 +1295,8 @@     -- using no package index and the current platform.     finalised = finalizePackageDescription                               [] (const True) buildPlatform-                              (CompilerId buildCompilerFlavor (Version [] []))+                              (unknownCompilerInfo+                                (CompilerId buildCompilerFlavor (Version [] [])) NoAbiTag)                               [] pkg     baseDependency = case finalised of       Right (pkg', _) | not (null baseDeps) ->@@ -1293,19 +1352,145 @@       COr  c1 c2 -> condfv c1 ++ condfv c2       CAnd c1 c2 -> condfv c1 ++ condfv c2 +checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck]+checkDevelopmentOnlyFlagsBuildInfo bi =+  catMaybes [++    check has_WerrorWall $+      PackageDistInexcusable $+           "'ghc-options: -Wall -Werror' makes the package very easy to "+        ++ "break with future GHC versions because new GHC versions often "+        ++ "add new warnings. Use just 'ghc-options: -Wall' instead."+        ++ extraExplanation++  , check (not has_WerrorWall && has_Werror) $+      PackageDistInexcusable $+           "'ghc-options: -Werror' makes the package easy to "+        ++ "break with future GHC versions because new GHC versions often "+        ++ "add new warnings. "+        ++ extraExplanation++  , checkFlags ["-fdefer-type-errors"] $+      PackageDistInexcusable $+           "'ghc-options: -fdefer-type-errors' is fine during development but "+        ++ "is not appropriate for a distributed package. "+        ++ extraExplanation++    -- -dynamic is not a debug flag+  , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic")+           ghc_options) $+      PackageDistInexcusable $+           "'ghc-options: -d*' debug flags are not appropriate "+        ++ "for a distributed package. "+        ++ extraExplanation++  , checkFlags ["-fprof-auto", "-fprof-auto-top", "-fprof-auto-calls",+               "-fprof-cafs", "-fno-prof-count-entries",+               "-auto-all", "-auto", "-caf-all"] $+      PackageDistSuspicious $+           "'ghc-options: -fprof*' profiling flags are typically not "+        ++ "appropriate for a distributed library package. These flags are "+        ++ "useful to profile this package, but when profiling other packages "+        ++ "that use this one these flags clutter the profile output with "+        ++ "excessive detail. If you think other packages really want to see "+        ++ "cost centres from this package then use '-fprof-auto-exported' "+        ++ "which puts cost centres only on exported functions. "+        ++ extraExplanation+  ]+  where+    extraExplanation =+         " Alternatively, if you want to use this, make it conditional based "+      ++ "on a Cabal configuration flag (with 'manual: True' and 'default: "+      ++ "False') and enable that flag during development."++    has_WerrorWall   = has_Werror && ( has_Wall || has_W )+    has_Werror       = "-Werror" `elem` ghc_options+    has_Wall         = "-Wall"   `elem` ghc_options+    has_W            = "-W"      `elem` ghc_options+    ghc_options      = hcOptions GHC bi ++ hcProfOptions GHC bi++    checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck+    checkFlags flags = check (any (`elem` flags) ghc_options)++checkDevelopmentOnlyFlags :: GenericPackageDescription -> [PackageCheck]+checkDevelopmentOnlyFlags pkg =+    concatMap checkDevelopmentOnlyFlagsBuildInfo+              [ bi+              | (conditions, bi) <- allConditionalBuildInfo+              , not (any guardedByManualFlag conditions) ]+  where+    guardedByManualFlag = definitelyFalse++    -- We've basically got three-values logic here: True, False or unknown+    -- hence this pattern to propagate the unknown cases properly.+    definitelyFalse (Var (Flag n)) = maybe False not (Map.lookup n manualFlags)+    definitelyFalse (Var _)        = False+    definitelyFalse (Lit  b)       = not b+    definitelyFalse (CNot c)       = definitelyTrue c+    definitelyFalse (COr  c1 c2)   = definitelyFalse c1 && definitelyFalse c2+    definitelyFalse (CAnd c1 c2)   = definitelyFalse c1 || definitelyFalse c2++    definitelyTrue (Var (Flag n)) = fromMaybe False (Map.lookup n manualFlags)+    definitelyTrue (Var _)        = False+    definitelyTrue (Lit  b)       = b+    definitelyTrue (CNot c)       = definitelyFalse c+    definitelyTrue (COr  c1 c2)   = definitelyTrue c1 || definitelyTrue c2+    definitelyTrue (CAnd c1 c2)   = definitelyTrue c1 && definitelyTrue c2++    manualFlags = Map.fromList+                    [ (flagName flag, flagDefault flag)+                    | flag <- genPackageFlags pkg+                    , flagManual flag ]++    allConditionalBuildInfo :: [([Condition ConfVar], BuildInfo)]+    allConditionalBuildInfo =+        concatMap (collectCondTreePaths libBuildInfo)+                  (maybeToList (condLibrary pkg))++     ++ concatMap (collectCondTreePaths buildInfo . snd)+                  (condExecutables pkg)++     ++ concatMap (collectCondTreePaths testBuildInfo . snd)+                  (condTestSuites pkg)++     ++ concatMap (collectCondTreePaths benchmarkBuildInfo . snd)+                  (condBenchmarks pkg)++    -- get all the leaf BuildInfo, paired up with the path (in the tree sense)+    -- of if-conditions that guard it+    collectCondTreePaths :: (a -> b)+                         -> CondTree v c a+                         -> [([Condition v], b)]+    collectCondTreePaths mapData = go []+      where+        go conditions condNode =+            -- the data at this level in the tree:+            (reverse conditions, mapData (condTreeData condNode))++          : concat+            [ go (condition:conditions) ifThen+            | (condition, ifThen, _) <- condTreeComponents condNode ]++         ++ concat+            [ go (condition:conditions) elseThen+            | (condition, _, Just elseThen) <- condTreeComponents condNode ]++ -- ------------------------------------------------------------ -- * Checks involving files in the package -- ------------------------------------------------------------  -- | 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 filepath.+-- package and expects to find the package unpacked in at the given file path. -- checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck] checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg   where     checkFilesIO = CheckPackageContentOps {-      doesFileExist      = System.doesFileExist      . relative,-      doesDirectoryExist = System.doesDirectoryExist . relative+      doesFileExist        = System.doesFileExist                  . relative,+      doesDirectoryExist   = System.doesDirectoryExist             . relative,+      getDirectoryContents = System.Directory.getDirectoryContents . relative,+      getFileContents      = \f -> openBinaryFile (relative f) ReadMode >>= hGetContents     }     relative path = root </> path @@ -1313,8 +1498,10 @@ -- Used by 'checkPackageContent'. -- data CheckPackageContentOps m = CheckPackageContentOps {-    doesFileExist      :: FilePath -> m Bool,-    doesDirectoryExist :: FilePath -> m Bool+    doesFileExist        :: FilePath -> m Bool,+    doesDirectoryExist   :: FilePath -> m Bool,+    getDirectoryContents :: FilePath -> m [FilePath],+    getFileContents      :: FilePath -> m String   }  -- | Sanity check things that requires looking at files in the package.@@ -1328,38 +1515,79 @@                     -> PackageDescription                     -> m [PackageCheck] checkPackageContent ops pkg = do-  licenseError    <- checkLicenseExists   ops pkg+  cabalBomError   <- checkCabalFileBOM    ops+  licenseErrors   <- checkLicensesExist   ops pkg   setupError      <- checkSetupExists     ops pkg   configureError  <- checkConfigureExists ops pkg   localPathErrors <- checkLocalPathsExist ops pkg   vcsLocation     <- checkMissingVcsInfo  ops pkg -  return $ catMaybes [licenseError, setupError, configureError]+  return $ licenseErrors+        ++ catMaybes [cabalBomError, setupError, configureError]         ++ localPathErrors         ++ vcsLocation -checkLicenseExists :: Monad m => CheckPackageContentOps m-                   -> PackageDescription-                   -> m (Maybe PackageCheck)-checkLicenseExists ops pkg-  | null (licenseFile pkg) = return Nothing-  | otherwise = do-    exists <- doesFileExist ops file-    return $ check (not exists) $-      PackageBuildWarning $-           "The 'license-file' field refers to the file " ++ quote file-        ++ " which does not exist."+checkCabalFileBOM :: Monad m => CheckPackageContentOps m+                  -> m (Maybe PackageCheck)+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." +-- |Find a package description file in the given directory.  Looks for+-- @.cabal@ files.+findPackageDesc :: Monad m => CheckPackageContentOps m+                 -> m (Either PackageCheck FilePath) -- ^<pkgname>.cabal+findPackageDesc ops+ = do let dir = "."+      files <- getDirectoryContents ops dir+      -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal+      -- file we filter to exclude dirs and null base file names:+      cabalFiles <- filterM (doesFileExist ops)+                       [ dir </> file+                       | file <- files+                       , let (name, ext) = splitExtension file+                       , not (null name) && ext == ".cabal" ]+      case cabalFiles of+        []          -> return (Left $ PackageBuildImpossible noDesc)+        [cabalFile] -> return (Right cabalFile)+        multiple    -> return (Left $ PackageBuildImpossible $ multiDesc multiple)+   where-    file = licenseFile pkg+    noDesc :: String+    noDesc = "No cabal file found.\n"+             ++ "Please create a package description file <pkgname>.cabal" +    multiDesc :: [String] -> String+    multiDesc l = "Multiple cabal files found.\n"+                  ++ "Please use only one of: "+                  ++ intercalate ", " l++checkLicensesExist :: Monad m => CheckPackageContentOps m+                   -> PackageDescription+                   -> m [PackageCheck]+checkLicensesExist ops pkg = do+    exists <- mapM (doesFileExist ops) (licenseFiles pkg)+    return+      [ PackageBuildWarning $+           "The '" ++ fieldname ++ "' field refers to the file "+        ++ quote file ++ " which does not exist."+      | (file, False) <- zip (licenseFiles pkg) exists ]+  where+    fieldname | length (licenseFiles pkg) == 1 = "license-file"+              | otherwise                      = "license-files"+ checkSetupExists :: Monad m => CheckPackageContentOps m                  -> PackageDescription                  -> m (Maybe PackageCheck)-checkSetupExists ops _ = do+checkSetupExists ops pkg = do+  let simpleBuild = buildType pkg == Just Simple   hsexists  <- doesFileExist ops "Setup.hs"   lhsexists <- doesFileExist ops "Setup.lhs"-  return $ check (not hsexists && not lhsexists) $+  return $ check (not simpleBuild && not hsexists && not lhsexists) $     PackageDistInexcusable $       "The package is missing a Setup.hs or Setup.lhs script." @@ -1370,7 +1598,8 @@   exists <- doesFileExist ops "configure"   return $ check (not exists) $     PackageBuildWarning $-      "The 'build-type' is 'Configure' but there is no 'configure' script."+      "The 'build-type' is 'Configure' but there is no 'configure' script. "+      ++ "You probably need to run 'autoreconf -i' to generate it." checkConfigureExists _ _ = return Nothing  checkLocalPathsExist :: Monad m => CheckPackageContentOps m

cabal/Cabal/Distribution/PackageDescription/Configuration.hs view

@@ -1,9 +1,11 @@+{-# LANGUAGE CPP #-} -- -fno-warn-deprecations for use of Map.foldWithKey {-# OPTIONS_GHC -fno-warn-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.PackageDescription.Configuration -- Copyright   :  Thomas Schilling, 2007+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -14,36 +16,6 @@ -- 'PackageDescription's. It has code for working with the tree of conditions -- and resolving or flattening conditions. -{- 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. -}- module Distribution.PackageDescription.Configuration (     finalizePackageDescription,     flattenPackageDescription,@@ -75,6 +47,8 @@          ( Platform(..), OS, Arch ) import Distribution.Simple.Utils          ( currentDir, lowercase )+import Distribution.Simple.Compiler+         ( CompilerInfo(..) )  import Distribution.Text          ( Text(parse) )@@ -86,7 +60,9 @@ import Data.Maybe ( catMaybes, maybeToList ) import Data.Map ( Map, fromListWith, toList ) import qualified Data.Map as Map+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid+#endif  ------------------------------------------------------------------------------ @@ -124,18 +100,25 @@       COr c1 c2  -> fv' c1 ++ fv' c2       CAnd c1 c2 -> fv' c1 ++ fv' c2 --- | Simplify a configuration condition using the os and arch names.  Returns+-- | Simplify a configuration condition using the OS and arch names.  Returns --   the names of all the flags occurring in the condition.-simplifyWithSysParams :: OS -> Arch -> CompilerId -> Condition ConfVar+simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar                       -> (Condition FlagName, [FlagName])-simplifyWithSysParams os arch (CompilerId comp compVer) cond = (cond', flags)+simplifyWithSysParams os arch cinfo cond = (cond', flags)   where     (cond', flags) = simplifyCondition cond interp     interp (OS os')    = Right $ os' == os     interp (Arch arch') = Right $ arch' == arch-    interp (Impl comp' vr) = Right $ comp' == comp-                                  && compVer `withinRange` vr-    interp (Flag  f)   = Left f+    interp (Impl comp vr)+      | matchImpl (compilerInfoId cinfo) = Right True+      | otherwise = case compilerInfoCompat cinfo of+          -- fixme: treat Nothing as unknown, rather than empty list once we+          --        support partial resolution of system parameters+          Nothing     -> Right False+          Just compat -> Right (any matchImpl compat)+          where+            matchImpl (CompilerId c v) = comp == c && v `withinRange` vr+    interp (Flag f) = Left f  -- TODO: Add instances and check --@@ -237,7 +220,7 @@         -- ^ Domain for each flag name, will be tested in order.   -> OS      -- ^ OS as returned by Distribution.System.buildOS   -> Arch    -- ^ Arch as returned by Distribution.System.buildArch-  -> CompilerId -- ^ Compiler flavour + version+  -> CompilerInfo  -- ^ Compiler information   -> [Dependency]  -- ^ Additional constraints   -> [CondTree ConfVar [Dependency] PDTagged]   -> ([Dependency] -> DepTestRslt [Dependency])  -- ^ Dependency test function.@@ -488,11 +471,11 @@ -- finalizePackageDescription ::      FlagAssignment  -- ^ Explicitly specified flag assignments-  -> (Dependency -> Bool) -- ^ Is a given depenency satisfiable from the set of+  -> (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'-  -> CompilerId    -- ^ Compiler + Version+  -> CompilerInfo  -- ^ Compiler information   -> [Dependency]  -- ^ Additional constraints   -> GenericPackageDescription   -> Either [Dependency]

cabal/Cabal/Distribution/PackageDescription/Parse.hs view

@@ -1,7 +1,10 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.PackageDescription.Parse -- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -11,36 +14,6 @@ -- backwards compatible with old @.cabal@ files, so there's code to translate -- into the newer structure. -{- 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. -}- module Distribution.PackageDescription.Parse (         -- * Package descriptions         readPackageDescription,@@ -68,20 +41,27 @@         flagFieldDescrs   ) where -import Data.Char  (isSpace)-import Data.Maybe (listToMaybe, isJust)-import Data.Monoid ( Monoid(..) )-import Data.List  (nub, unfoldr, partition, (\\))+import Data.Char     (isSpace)+import Data.Foldable (traverse_)+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(..))-import Control.Arrow (first)+#endif+import Control.Arrow    (first) import System.Directory (doesFileExist) import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import Data.Typeable+import Data.Data+import qualified Data.Map as Map  import Distribution.Text          ( Text(disp, parse), display, simpleParse ) import Distribution.Compat.ReadP          ((+++), option)+import qualified Distribution.Compat.ReadP as Parse import Text.PrettyPrint  import Distribution.ParseUtils hiding (parseFields)@@ -123,18 +103,30 @@  , simpleField "license"            disp                   parseLicenseQ            license                (\l pkg -> pkg{license=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.  , simpleField "license-file"            showFilePath           parseFilePathQ-           licenseFile            (\l pkg -> pkg{licenseFile=l})+           (\pkg -> case licenseFiles pkg of+                      [x] -> x+                      _   -> "")+           (\l pkg -> pkg{licenseFiles=licenseFiles pkg ++ [l]})+ , listField "license-files"+           showFilePath           parseFilePathQ+           (\pkg -> case licenseFiles pkg of+                      [_] -> []+                      xs  -> xs)+           (\ls pkg -> pkg{licenseFiles=ls})  , simpleField "copyright"            showFreeText           parseFreeText            copyright              (\val pkg -> pkg{copyright=val})  , simpleField "maintainer"            showFreeText           parseFreeText            maintainer             (\val pkg -> pkg{maintainer=val})- , commaListField  "build-depends"-           disp                   parse-           buildDepends           (\xs    pkg -> pkg{buildDepends=xs})  , simpleField "stability"            showFreeText           parseFreeText            stability              (\val pkg -> pkg{stability=val})@@ -162,19 +154,19 @@  , listField "tested-with"            showTestedWith         parseTestedWithQ            testedWith             (\val pkg -> pkg{testedWith=val})- , listField "data-files"+ , listFieldWithSep vcat "data-files"            showFilePath           parseFilePathQ            dataFiles              (\val pkg -> pkg{dataFiles=val})  , simpleField "data-dir"            showFilePath           parseFilePathQ            dataDir                (\val pkg -> pkg{dataDir=val})- , listField "extra-source-files"+ , listFieldWithSep vcat "extra-source-files"            showFilePath    parseFilePathQ            extraSrcFiles          (\val pkg -> pkg{extraSrcFiles=val})- , listField "extra-tmp-files"+ , listFieldWithSep vcat "extra-tmp-files"            showFilePath       parseFilePathQ            extraTmpFiles          (\val pkg -> pkg{extraTmpFiles=val})- , listField "extra-doc-files"+ , listFieldWithSep vcat "extra-doc-files"            showFilePath    parseFilePathQ            extraDocFiles          (\val pkg -> pkg{extraDocFiles=val})  ]@@ -192,9 +184,18 @@  libFieldDescrs :: [FieldDescr Library] libFieldDescrs =-  [ listField "exposed-modules" disp parseModuleNameQ+  [ listFieldWithSep vcat "exposed-modules" disp parseModuleNameQ       exposedModules (\mods lib -> lib{exposedModules=mods}) +  , 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})+   , boolField "exposed"       libExposed     (\val lib -> lib{libExposed=val})   ] ++ map biToLib binfoFieldDescrs@@ -399,6 +400,10 @@  , commaListField  "build-tools"            disp               parseBuildTool            buildTools         (\xs  binfo -> binfo{buildTools=xs})+ , commaListFieldWithSep vcat "build-depends"+           disp                   parse+           buildDependsWithRenaming+           setBuildDependsWithRenaming  , spaceListField "cpp-options"            showToken          parseTokenQ'            cppOptions          (\val binfo -> binfo{cppOptions=val})@@ -414,10 +419,12 @@  , listField "frameworks"            showToken          parseTokenQ            frameworks         (\val binfo -> binfo{frameworks=val})- , listField   "c-sources"+ , listFieldWithSep vcat "c-sources"            showFilePath       parseFilePathQ            cSources           (\paths binfo -> binfo{cSources=paths})-+ , listFieldWithSep vcat "js-sources"+           showFilePath       parseFilePathQ+           jsSources          (\paths binfo -> binfo{jsSources=paths})  , simpleField "default-language"            (maybe empty disp) (option Nothing (fmap Just parseLanguageQ))            defaultLanguage    (\lang  binfo -> binfo{defaultLanguage=lang})@@ -434,16 +441,19 @@            disp               parseExtensionQ            oldExtensions      (\exts  binfo -> binfo{oldExtensions=exts}) - , listField   "extra-libraries"+ , listFieldWithSep vcat "extra-libraries"            showToken          parseTokenQ            extraLibs          (\xs    binfo -> binfo{extraLibs=xs})+ , listFieldWithSep vcat "extra-ghci-libraries"+           showToken          parseTokenQ+           extraGHCiLibs      (\xs    binfo -> binfo{extraGHCiLibs=xs})  , listField   "extra-lib-dirs"            showFilePath       parseFilePathQ            extraLibDirs       (\xs    binfo -> binfo{extraLibDirs=xs})- , listField   "includes"+ , listFieldWithSep vcat "includes"            showFilePath       parseFilePathQ            includes           (\paths binfo -> binfo{includes=paths})- , listField   "install-includes"+ , listFieldWithSep vcat "install-includes"            showFilePath       parseFilePathQ            installIncludes    (\paths binfo -> binfo{installIncludes=paths})  , listField   "include-dirs"@@ -452,23 +462,30 @@  , listField   "hs-source-dirs"            showFilePath       parseFilePathQ            hsSourceDirs       (\paths binfo -> binfo{hsSourceDirs=paths})- , listField   "other-modules"+ , listFieldWithSep vcat "other-modules"            disp               parseModuleNameQ            otherModules       (\val binfo -> binfo{otherModules=val})- , listField   "ghc-prof-options"-           text               parseTokenQ-           ghcProfOptions        (\val binfo -> binfo{ghcProfOptions=val})- , listField   "ghc-shared-options"-           text               parseTokenQ-           ghcSharedOptions      (\val binfo -> binfo{ghcSharedOptions=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   "hugs-options" Hugs-           options            (\path  binfo -> binfo{options=path})- , optsField   "nhc98-options"  NHC+ , 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.+ , optsField   "hugs-options" Hugs+           options            (const id)+ , optsField   "nhc98-options" NHC+           options            (const id)  ]  storeXFieldsBI :: UnrecFieldParser BuildInfo@@ -512,6 +529,15 @@         repoSubdir                 (\val repo -> repo { repoSubdir = val })     ] +------------------------------------------------------------------------------++setupBInfoFieldDescrs :: [FieldDescr SetupBuildInfo]+setupBInfoFieldDescrs =+    [ commaListFieldWithSep vcat "setup-depends"+        disp         parse+        setupDepends (\xs binfo -> binfo{setupDepends=xs})+    ]+ -- --------------------------------------------------------------- -- Parsing @@ -579,7 +605,7 @@ -- they add and define an accessor that specifies what the dependencies -- are.  This way we would completely reuse the parsing knowledge from the -- field descriptor.-parseConstraint :: Field -> ParseResult [Dependency]+parseConstraint :: Field -> ParseResult [DependencyWithRenaming] parseConstraint (F l n v)     | n == "build-depends" = runP l n (parseCommaList parse) v parseConstraint f = userBug $ "Constraint was expected (got: " ++ show f ++ ")"@@ -609,10 +635,15 @@ instance Functor f => Functor (StT s f) where     fmap g (StT f) = StT $ fmap (first g)  . f +#if __GLASGOW_HASKELL__ >= 710+instance (Monad m) => Applicative (StT s m) where+#else instance (Monad m, Functor m) => Applicative (StT s m) where+#endif     pure = return     (<*>) = ap + instance Monad m => Monad (StT s m) where     return a = StT (\s -> return (a,s))     StT f >>= g = StT $ \s -> do@@ -718,13 +749,13 @@            -- 'getBody' assumes that the remaining fields only consist of           -- flags, lib and exe sections.-        (repos, flags, mlib, exes, tests, bms) <- getBody+        (repos, flags, mcsetup, mlib, exes, tests, bms) <- getBody         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 mlib exes tests         return $ GenericPackageDescription-                   pkg { sourceRepos = repos }+                   pkg { sourceRepos = repos, setupBuildInfo = mcsetup }                    flags mlib exes tests bms    where@@ -775,7 +806,7 @@     --  * an optional library section, and an arbitrary number of executable     --    sections (in any order).     ---    -- The current implementatition just gathers all library-specific fields+    -- The current implementation just gathers all library-specific fields     -- in a library section and wraps all executable stanzas in an executable     -- section.     sectionizeFields :: [Field] -> [Field]@@ -830,6 +861,7 @@     -- The body consists of an optional sequence of declarations of flags and     -- an arbitrary number of executables and at most one library.     getBody :: PM ([SourceRepo], [Flag]+                  ,Maybe SetupBuildInfo                   ,Maybe (CondTree ConfVar [Dependency] Library)                   ,[(String, CondTree ConfVar [Dependency] Executable)]                   ,[(String, CondTree ConfVar [Dependency] TestSuite)]@@ -842,8 +874,8 @@             exename <- lift $ runP line_no "executable" parseTokenQ sec_label             flds <- collectFields parseExeFields sec_fields             skipField-            (repos, flags, lib, exes, tests, bms) <- getBody-            return (repos, flags, lib, (exename, flds): exes, tests, bms)+            (repos, flags, csetup, lib, exes, tests, bms) <- getBody+            return (repos, flags, csetup, lib, (exename, flds): exes, tests, bms)          | sec_type == "test-suite" -> do             when (null sec_label) $ lift $ syntaxError line_no@@ -884,8 +916,9 @@             if checkTestType emptyTestSuite flds                 then do                     skipField-                    (repos, flags, lib, exes, tests, bms) <- getBody-                    return (repos, flags, lib, exes, (testname, flds) : tests, bms)+                    (repos, flags, csetup, lib, exes, tests, bms) <- getBody+                    return (repos, flags, csetup, lib, exes,+                            (testname, flds) : tests, bms)                 else lift $ syntaxError line_no $                          "Test suite \"" ++ testname                       ++ "\" is missing required field \"type\" or the field "@@ -932,8 +965,9 @@             if checkBenchmarkType emptyBenchmark flds                 then do                     skipField-                    (repos, flags, lib, exes, tests, bms) <- getBody-                    return (repos, flags, lib, exes, tests, (benchname, flds) : bms)+                    (repos, flags, csetup, lib, exes, tests, bms) <- getBody+                    return (repos, flags, csetup, lib, exes,+                            tests, (benchname, flds) : bms)                 else lift $ syntaxError line_no $                          "Benchmark \"" ++ benchname                       ++ "\" is missing required field \"type\" or the field "@@ -946,10 +980,10 @@               syntaxError line_no "'library' expects no argument"             flds <- collectFields parseLibFields sec_fields             skipField-            (repos, flags, lib, exes, tests, bms) <- getBody+            (repos, flags, csetup, lib, exes, tests, bms) <- getBody             when (isJust lib) $ lift $ syntaxError line_no               "There can only be one library section in a package description."-            return (repos, flags, Just flds, exes, tests, bms)+            return (repos, flags, csetup, Just flds, exes, tests, bms)          | sec_type == "flag" -> do             when (null sec_label) $ lift $@@ -960,8 +994,8 @@                     (MkFlag (FlagName (lowercase sec_label)) "" True False)                     sec_fields             skipField-            (repos, flags, lib, exes, tests, bms) <- getBody-            return (repos, flag:flags, lib, exes, tests, bms)+            (repos, flags, csetup, lib, exes, tests, bms) <- getBody+            return (repos, flag:flags, csetup, lib, exes, tests, bms)          | sec_type == "source-repository" -> do             when (null sec_label) $ lift $ syntaxError line_no $@@ -985,9 +1019,23 @@                     }                     sec_fields             skipField-            (repos, flags, lib, exes, tests, bms) <- getBody-            return (repo:repos, flags, lib, exes, tests, bms)+            (repos, flags, csetup, lib, exes, tests, bms) <- getBody+            return (repo:repos, flags, csetup, lib, exes, tests, bms) +        | sec_type == "custom-setup" -> do+            unless (null sec_label) $ lift $+              syntaxError line_no "'setup' expects no argument"+            flds <- lift $ parseFields+                             setupBInfoFieldDescrs+                             warnUnrec+                             mempty+                             sec_fields+            skipField+            (repos, flags, csetup0, lib, exes, tests, bms) <- getBody+            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)+         | otherwise -> do             lift $ warning $ "Ignoring unknown section type: " ++ sec_type             skipField@@ -1002,7 +1050,7 @@               "If-blocks are not allowed in between stanzas: " ++ show f             skipField             getBody-      Nothing -> return ([], [], Nothing, [], [], [])+      Nothing -> return ([], [], Nothing, Nothing, [], [], [])      -- Extracts all fields in a block and returns a 'CondTree'.     --@@ -1014,11 +1062,19 @@          let simplFlds = [ F l n v | F l n v <- allflds ]             condFlds = [ f | f@IfBlock{} <- allflds ]+            sections = [ s | s@Section{} <- allflds ] -        let (depFlds, dataFlds) = partition isConstraint simplFlds+        -- Put these through the normal parsing pass too, so that we+        -- collect the ModRenamings+        let depFlds = filter isConstraint simplFlds+        +        mapM_+            (\(Section l n _ _) -> lift . warning $+                "Unexpected section '" ++ n ++ "' on line " ++ show l)+            sections -        a <- parser dataFlds-        deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds+        a <- parser simplFlds+        deps <- liftM concat . mapM (lift . fmap (map dependency) .  parseConstraint) $ depFlds          ifs <- mapM processIfs condFlds @@ -1065,7 +1121,7 @@         PM ()     checkForUndefinedFlags flags mlib exes tests = do         let definedFlags = map flagName flags-        maybe (return ()) (checkCondTreeFlags definedFlags) mlib+        traverse_ (checkCondTreeFlags definedFlags) mlib         mapM_ (checkCondTreeFlags definedFlags . snd) exes         mapM_ (checkCondTreeFlags definedFlags . snd) tests @@ -1222,3 +1278,32 @@  --test_findIndentTabs = findIndentTabs $ unlines $ --    [ "foo", "  bar", " \t baz", "\t  biz\t", "\t\t \t mib" ]++-- | Dependencies plus module renamings.  This is what users specify; however,+-- renaming information is not used for dependency resolution.+data DependencyWithRenaming = DependencyWithRenaming Dependency ModuleRenaming+  deriving (Read, Show, Eq, Typeable, Data)++dependency :: DependencyWithRenaming -> Dependency+dependency (DependencyWithRenaming dep _) = dep++instance Text DependencyWithRenaming where+  disp (DependencyWithRenaming d rns) = disp d <+> disp rns+  parse = do d <- parse+             Parse.skipSpaces+             rns <- parse+             Parse.skipSpaces+             return (DependencyWithRenaming d rns)++buildDependsWithRenaming :: BuildInfo -> [DependencyWithRenaming]+buildDependsWithRenaming pkg =+    map (\dep@(Dependency n _) ->+            DependencyWithRenaming dep+                (Map.findWithDefault defaultRenaming n (targetBuildRenaming pkg)))+        (targetBuildDepends pkg)++setBuildDependsWithRenaming :: [DependencyWithRenaming] -> BuildInfo -> BuildInfo+setBuildDependsWithRenaming deps pkg = pkg {+    targetBuildDepends = map dependency deps,+    targetBuildRenaming = Map.fromList (map (\(DependencyWithRenaming (Dependency n _) rns) -> (n, rns)) deps)+  }

cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs view

@@ -1,73 +1,44 @@+{-# LANGUAGE CPP #-} --------------------------------------------------------------------------------+-- | -- Module      :  Distribution.PackageDescription.PrettyPrint -- Copyright   :  Jürgen Nicklisch-Franken 2010--- License     :  AllRightsReserved+-- License     :  BSD3 -- -- Maintainer  : cabal-devel@haskell.org -- Stability   : provisional -- Portability : portable ----- | Pretty printing for cabal files+-- Pretty printing for cabal files -- ------------------------------------------------------------------------------{- 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. -}- module Distribution.PackageDescription.PrettyPrint (     writeGenericPackageDescription,     showGenericPackageDescription, ) where +#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(mempty))+#endif import Distribution.PackageDescription        ( Benchmark(..), BenchmarkInterface(..), benchmarkType        , TestSuite(..), TestSuiteInterface(..), testType        , SourceRepo(..),-        customFieldsBI, CondTree(..), Condition(..),+        customFieldsBI, CondTree(..), Condition(..), cNot,         FlagName(..), ConfVar(..), Executable(..), Library(..),         Flag(..), PackageDescription(..),         GenericPackageDescription(..)) import Text.PrettyPrint-       (hsep, comma, punctuate, fsep, parens, char, nest, empty,-        isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render)+       (hsep, parens, char, nest, empty, isEmpty, ($$), (<+>),+        colon, (<>), text, vcat, ($+$), Doc, render) import Distribution.Simple.Utils (writeUTF8File)-import Distribution.ParseUtils (showFreeText, FieldDescr(..))+import Distribution.ParseUtils (showFreeText, FieldDescr(..), indentWith, ppField, ppFields) import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,-       sourceRepoFieldDescrs)+       sourceRepoFieldDescrs,flagFieldDescrs) import Distribution.Package (Dependency(..)) import Distribution.Text (Text(..))-import Data.Maybe (isJust, fromJust, isNothing)--indentWith :: Int-indentWith = 4+import Data.Maybe (isJust)  -- | Recompile with false for regression testing simplifiedPrinting :: Bool@@ -106,20 +77,29 @@   where     sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"] -ppFields :: [FieldDescr a] -> a -> Doc-ppFields fields x                        =-    vcat [ ppField name (getter x)-                         | FieldDescr name getter _ <- fields]+-- TODO: this is a temporary hack. Ideally, fields containing default values+-- would be filtered out when the @FieldDescr a@ list is generated.+ppFieldsFiltered :: [(String, String)] -> [FieldDescr a] -> a -> Doc+ppFieldsFiltered removable fields x = ppFields (filter nondefault fields) x+  where+    nondefault (FieldDescr name getter _) =+        maybe True (render (getter x) /=) (lookup name removable) -ppField :: String -> Doc -> Doc-ppField name fielddoc | isEmpty fielddoc = empty-                      | otherwise        = text name <> colon <+> fielddoc+binfoDefaults :: [(String, String)]+binfoDefaults = [("buildable", "True")] +libDefaults :: [(String, String)]+libDefaults = ("exposed", "True") : binfoDefaults++flagDefaults :: [(String, String)]+flagDefaults = [("default", "True"), ("manual", "False")]+ ppDiffFields :: [FieldDescr a] -> a -> a -> Doc ppDiffFields fields x y                  =-    vcat [ ppField name (getter x)-                         | FieldDescr name getter _ <- fields,-                            render (getter x) /= render (getter y)]+   vcat [ ppField name (getter x)+        | FieldDescr name getter _ <- fields+        , render (getter x) /= render (getter y)+        ]  ppCustomFields :: [(String,String)] -> Doc ppCustomFields flds                      = vcat [ppCustomField f | f <- flds]@@ -131,20 +111,17 @@ ppGenPackageFlags flds                   = vcat [ppFlag f | f <- flds]  ppFlag :: Flag -> Doc-ppFlag (MkFlag name desc dflt manual)    =-    emptyLine $ text "flag" <+> ppFlagName name $+$-            (nest indentWith ((if null desc-                                then empty-                                else  text "Description: " <+> showFreeText desc) $+$-                     (if dflt then empty else text "Default: False") $+$-                     (if manual then text "Manual: True" else empty)))+ppFlag flag@(MkFlag name _ _ _)    =+    emptyLine $ text "flag" <+> ppFlagName name $+$ nest indentWith fields+  where+    fields = ppFieldsFiltered flagDefaults flagFieldDescrs flag  ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc ppLibrary Nothing                        = empty ppLibrary (Just condTree)                =     emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib)   where-    ppLib lib Nothing     = ppFields libFieldDescrs lib+    ppLib lib Nothing     = ppFieldsFiltered libDefaults libFieldDescrs lib                             $$  ppCustomFields (customFieldsBI (libBuildInfo lib))     ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib                             $$  ppCustomFields (customFieldsBI (libBuildInfo lib))@@ -156,7 +133,7 @@   where     ppExe (Executable _ modulePath' buildInfo') Nothing =         (if modulePath' == "" then empty else text "main-is:" <+> text modulePath')-            $+$ ppFields binfoFieldDescrs buildInfo'+            $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs buildInfo'             $+$  ppCustomFields (customFieldsBI buildInfo')     ppExe (Executable _ modulePath' buildInfo')             (Just (Executable _ modulePath2 buildInfo2)) =@@ -178,7 +155,7 @@                             (testSuiteMainIs testsuite)             $+$ maybe empty (\m -> text "test-module:" <+> disp m)                             (testSuiteModule testsuite)-            $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite)+            $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (testBuildInfo testsuite)             $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))       where         maybeTestType | testInterface testsuite == mempty = Nothing@@ -208,7 +185,7 @@                             maybeBenchmarkType             $+$ maybe empty (\f -> text "main-is:"     <+> text f)                             (benchmarkMainIs benchmark)-            $+$ ppFields binfoFieldDescrs (benchmarkBuildInfo benchmark)+            $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (benchmarkBuildInfo benchmark)             $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark))       where         maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing@@ -241,31 +218,45 @@ ppFlagName (FlagName name)               = text name  ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) ->  Doc-ppCondTree ct@(CondNode it deps ifs) mbIt ppIt =-    let res = ppDeps deps-                $+$ (vcat $ map ppIf ifs)+ppCondTree ct@(CondNode it _ ifs) mbIt ppIt =+    let res = (vcat $ map ppIf ifs)                 $+$ ppIt it mbIt     in if isJust mbIt && isEmpty res         then ppCondTree ct Nothing ppIt         else res   where-    ppIf (c,thenTree,mElseTree)          =-        ((emptyLine $ text "if" <+> ppCondition c) $$-          nest indentWith (ppCondTree thenTree-                    (if simplifiedPrinting then (Just it) else Nothing) ppIt))-        $+$ (if isNothing mElseTree-                then empty-                else text "else"-                    $$ nest indentWith (ppCondTree (fromJust mElseTree)-                        (if simplifiedPrinting then (Just it) else Nothing) ppIt))+    -- TODO: this ends up printing trailing spaces when combined with nest.+    ppIf (c, thenTree, Just elseTree) = ppIfElse it ppIt c thenTree elseTree+    ppIf (c, thenTree, Nothing)       = ppIf' it ppIt c thenTree -ppDeps :: [Dependency] -> Doc-ppDeps []                                = empty-ppDeps deps                              =-    text "build-depends:" <+> fsep (punctuate comma (map disp deps))+ppIfCondition :: (Condition ConfVar) -> Doc+ppIfCondition c = (emptyLine $ text "if" <+> ppCondition c) -emptyLine :: Doc -> Doc-emptyLine d                              = text " " $+$ d+ppIf' :: a -> (a -> Maybe a -> Doc)+           -> Condition ConfVar+           -> CondTree ConfVar [Dependency] a+           -> Doc+ppIf' it ppIt c thenTree = +  if isEmpty thenDoc+     then mempty+     else ppIfCondition c $$ nest indentWith thenDoc+  where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt +ppIfElse :: a -> (a -> Maybe a -> Doc)+              -> Condition ConfVar+              -> CondTree ConfVar [Dependency] a+              -> CondTree ConfVar [Dependency] a+              -> Doc+ppIfElse it ppIt c thenTree elseTree =+  case (isEmpty thenDoc, isEmpty elseDoc) of+    (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)+                      $+$ (text "else" $$ nest indentWith elseDoc)+  where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt+        elseDoc = ppCondTree elseTree (if simplifiedPrinting then (Just it) else Nothing) ppIt +emptyLine :: Doc -> Doc+emptyLine d                              = text "" $+$ d

cabal/Cabal/Distribution/ParseUtils.hs view

@@ -1,7 +1,9 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.ParseUtils -- Copyright   :  (c) The University of Glasgow 2004+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -15,36 +17,6 @@ -- many of the formats we get in various @.cabal@ file fields, like module -- names, comma separated lists etc. -{- 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 the University 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. -}- -- This module is meant to be local-only to Distribution...  {-# OPTIONS_HADDOCK hide #-}@@ -61,8 +33,9 @@         parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ,         parseSepList, parseCommaList, parseOptCommaList,         showFilePath, showToken, showTestedWith, showFreeText, parseFreeText,-        field, simpleField, listField, spaceListField, commaListField,-        optsField, liftField, boolField, parseQuoted,+        field, simpleField, listField, listFieldWithSep, spaceListField,+        commaListField, commaListFieldWithSep, commaNewLineListField,+        optsField, liftField, boolField, parseQuoted, indentWith,          UnrecFieldParser, warnUnrec, ignoreUnrec,   ) where@@ -78,7 +51,8 @@ import Distribution.Text          ( Text(..) ) import Distribution.Simple.Utils-         ( comparing, intercalate, lowercase, normaliseLineEndings )+         ( comparing, dropWhileEndLE, intercalate, lowercase+         , normaliseLineEndings ) import Language.Haskell.Extension          ( Language, Extension ) @@ -88,13 +62,16 @@ import Data.Tree as Tree (Tree(..), flatten) import qualified Data.Map as Map import Control.Monad (foldM, ap)+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..))+#endif import System.FilePath (normalise) import Data.List (sortBy)  -- ----------------------------------------------------------------------------- -type LineNo = Int+type LineNo    = Int+type Separator = ([Doc] -> Doc)  data PError = AmbiguousParse String LineNo             | NoParse String LineNo@@ -217,37 +194,51 @@ simpleField name showF readF get set   = liftField get set $ field name showF readF +commaListFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a+                      -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+commaListFieldWithSep separator name showF readF get set =+   liftField get set' $+     field name showF' (parseCommaList readF)+   where+     set' xs b = set (get b ++ xs) b+     showF'    = separator . punctuate comma . map showF+ commaListField :: String -> (a -> Doc) -> ReadP [a] a                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-commaListField name showF readF get set =-  liftField get set' $-    field name (fsep . punctuate comma . map showF) (parseCommaList readF)-  where-    set' xs b = set (get b ++ xs) b+commaListField = commaListFieldWithSep fsep +commaNewLineListField :: String -> (a -> Doc) -> ReadP [a] a+                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+commaNewLineListField = commaListFieldWithSep sep+ spaceListField :: String -> (a -> Doc) -> ReadP [a] a                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b spaceListField name showF readF get set =   liftField get set' $-    field name (fsep . map showF) (parseSpaceList readF)+    field name showF' (parseSpaceList readF)   where     set' xs b = set (get b ++ xs) b+    showF'    = fsep . map showF -listField :: String -> (a -> Doc) -> ReadP [a] a+listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-listField name showF readF get set =+listFieldWithSep separator name showF readF get set =   liftField get set' $-    field name (fsep . map showF) (parseOptCommaList readF)+    field name showF' (parseOptCommaList readF)   where     set' xs b = set (get b ++ xs) b+    showF'    = separator . map showF +listField :: String -> (a -> Doc) -> ReadP [a] a+          -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+listField = listFieldWithSep fsep+ optsField :: String -> 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 (hsep . map text)-                   (sepBy parseTokenQ' (munch1 isSpace))+        field name showF (sepBy parseTokenQ' (munch1 isSpace))   where         update _ opts l | all null opts = l  --empty opts as if no opts         update f opts [] = [(f,opts)]@@ -255,6 +246,7 @@            | f == f'   = (f, opts' ++ opts) : rest            | otherwise = (f',opts') : update f opts rest         reorder = sortBy (comparing fst)+        showF   = hsep . map text  -- TODO: this is a bit smelly hack. It's because we want to parse bool fields --       liberally but not accept new parses. We cannot do that with ReadP@@ -275,11 +267,30 @@           "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'."  ppFields :: [FieldDescr a] -> a -> Doc-ppFields fields x = vcat [ ppField name (getter x)-                         | FieldDescr name getter _ <- fields]+ppFields fields x =+   vcat [ ppField name (getter x) | FieldDescr name getter _ <- fields ]  ppField :: String -> Doc -> Doc-ppField name fielddoc = text name <> colon <+> fielddoc+ppField name fielddoc+   | isEmpty fielddoc         = empty+   | name `elem` nestedFields = text name <> colon $+$ nest indentWith fielddoc+   | otherwise                = text name <> colon <+> fielddoc+   where+      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"+         ]  showFields :: [FieldDescr a] -> a -> String showFields fields = render . ($+$ text "") . ppFields fields@@ -436,7 +447,7 @@        -- > else        -- >    other        ---       -- this is ok+       -- this is OK        Line LineNo Indent HasTabs String      | Span LineNo                String  -- ^ span in a line, following brackets      | OpenBracket LineNo | CloseBracket LineNo@@ -444,7 +455,7 @@ type Indent = Int type HasTabs = Bool --- | Tokenise a single line, splitting on '{' '}' and the spans inbetween.+-- | Tokenise a single line, splitting on '{' '}' and the spans in between. -- Also trims leading & trailing space on those spans within the line. tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token] tokeniseLine (n0, i, t, l) = case split n0 l of@@ -471,7 +482,7 @@  trimLeading, trimTrailing :: String -> String trimLeading  = dropWhile isSpace-trimTrailing = reverse . dropWhile isSpace . reverse+trimTrailing = dropWhileEndLE isSpace   type SyntaxTree = Tree (LineNo, HasTabs, String)@@ -481,8 +492,8 @@ mkTree toks =   layout 0 [] toks >>= \(trees, trailing) -> case trailing of     []               -> return trees-    OpenBracket  n:_ -> syntaxError n "mismatched backets, unexpected {"-    CloseBracket n:_ -> syntaxError n "mismatched backets, unexpected }"+    OpenBracket  n:_ -> syntaxError n "mismatched brackets, unexpected {"+    CloseBracket n:_ -> syntaxError n "mismatched brackets, unexpected }"     -- the following two should never happen:     Span n     l  :_ -> syntaxError n $ "unexpected span: " ++ show l     Line n _ _ l  :_ -> syntaxError n $ "unexpected line: " ++ show l@@ -650,7 +661,7 @@ parseOptVersion = parseQuoted ver <++ ver   where ver :: ReadP r Version         ver = parse <++ return noVersion-        noVersion = Version{ versionBranch=[], versionTags=[] }+        noVersion = Version [] []  parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) parseTestedWithQ = parseQuoted tw <++ tw@@ -711,7 +722,8 @@ -- ** Pretty printing  showFilePath :: FilePath -> Doc-showFilePath = showToken+showFilePath "" = empty+showFilePath x  = showToken x  showToken :: String -> Doc showToken str@@ -727,7 +739,6 @@ -- and with blank lines replaced by dots for correct re-parsing. showFreeText :: String -> Doc showFreeText "" = empty-showFreeText ('\n' :r)  = text " " $+$ text "." $+$ showFreeText r 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@@ -738,3 +749,7 @@                             in  l : case s' of                                         []    -> []                                         (_:s'') -> lines_ s''++-- | the indentation used for pretty printing+indentWith :: Int+indentWith = 4

cabal/Cabal/Distribution/ReadE.hs view

@@ -2,42 +2,12 @@ -- | -- Module      :  Distribution.ReadE -- Copyright   :  Jose Iborra 2008+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable -- -- Simple parsing with failure--{- Copyright (c) 2007, Jose Iborra-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. -}  module Distribution.ReadE (    -- * ReadE

cabal/Cabal/Distribution/Simple.hs view

@@ -2,6 +2,7 @@ -- | -- Module      :  Distribution.Simple -- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -24,36 +25,6 @@ -- presented the same compatible command line interfaces. There is still a -- "Distribution.Make" system but in practice no packages use it. -{- 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. -}- {- Work around this warning: libraries/Cabal/Distribution/Simple.hs:78:0:@@ -85,7 +56,7 @@ -- local import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.UserHooks-import Distribution.Package --must not specify imports, since we're exporting moule.+import Distribution.Package --must not specify imports, since we're exporting module. import Distribution.PackageDescription          ( PackageDescription(..), GenericPackageDescription, Executable(..)          , updatePackageDescription, hasLibs@@ -109,7 +80,7 @@ import Distribution.Simple.Configure          ( getPersistBuildConfig, maybeGetPersistBuildConfig          , writePersistBuildConfig, checkPersistBuildConfigOutdated-         , configure, checkForeignDeps )+         , configure, checkForeignDeps, findDistPrefOrDefault )  import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) import Distribution.Simple.Bench (bench)@@ -134,13 +105,14 @@ import System.Environment(getArgs, getProgName) import System.Directory(removeFile, doesFileExist,                         doesDirectoryExist, removeDirectoryRecursive)-import System.Exit+import System.Exit       (exitWith,ExitCode(..)) import System.IO.Error   (isDoesNotExistError) import Control.Exception (throwIO) import Distribution.Compat.Environment (getEnvironment) import Distribution.Compat.Exception (catchIO)  import Control.Monad   (when)+import Data.Foldable   (traverse_) import Data.List       (intercalate, unionBy, nub, (\\))  -- | A simple implementation of @main@ for a Cabal setup script.@@ -172,7 +144,7 @@  defaultMainHelper :: UserHooks -> Args -> IO () defaultMainHelper hooks args = topHandler $-  case commandsRun globalCommand commands args of+  case commandsRun (globalCommand commands) commands args of     CommandHelp   help                 -> printHelp help     CommandList   opts                 -> printOptionsList opts     CommandErrors errs                 -> printErrors errs@@ -225,187 +197,202 @@  configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo configureAction hooks flags args = do-                let distPref = fromFlag $ configDistPref flags-                pbi <- preConf hooks args flags+    distPref <- findDistPrefOrDefault (configDistPref flags)+    let flags' = flags { configDistPref = toFlag distPref }+    pbi <- preConf hooks args flags' -                (mb_pd_file, pkg_descr0) <- confPkgDescr+    (mb_pd_file, pkg_descr0) <- confPkgDescr -                --    get_pkg_descr (configVerbosity flags')-                --let pkg_descr = updatePackageDescription pbi pkg_descr0-                let epkg_descr = (pkg_descr0, pbi)+    --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+    --(warns, ers) <- sanityCheckPackage pkg_descr+    --errorOut (configVerbosity flags') warns ers -                localbuildinfo0 <- confHook hooks epkg_descr flags+    localbuildinfo0 <- confHook hooks epkg_descr flags' -                -- remember the .cabal filename if we know it-                -- and all the extra command line args-                let localbuildinfo = localbuildinfo0 {-                                       pkgDescrFile = mb_pd_file,-                                       extraConfigArgs = args-                                     }-                writePersistBuildConfig distPref localbuildinfo+    -- remember the .cabal filename if we know it+    -- and all the extra command line args+    let localbuildinfo = localbuildinfo0 {+                           pkgDescrFile = mb_pd_file,+                           extraConfigArgs = args+                         }+    writePersistBuildConfig distPref localbuildinfo -                let pkg_descr = localPkgDescr localbuildinfo-                postConf hooks args flags pkg_descr localbuildinfo-                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)+    let pkg_descr = localPkgDescr localbuildinfo+    postConf hooks args flags' pkg_descr localbuildinfo+    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)  buildAction :: UserHooks -> BuildFlags -> Args -> IO () buildAction hooks flags args = do-  let distPref  = fromFlag $ buildDistPref flags-      verbosity = fromFlag $ buildVerbosity flags+  distPref <- findDistPrefOrDefault (buildDistPref flags)+  let verbosity = fromFlag $ buildVerbosity flags+      flags' = flags { buildDistPref = toFlag distPref }    lbi <- getBuildConfig hooks verbosity distPref   progs <- reconfigurePrograms verbosity-             (buildProgramPaths flags)-             (buildProgramArgs flags)+             (buildProgramPaths flags')+             (buildProgramArgs flags')              (withPrograms lbi)    hookedAction preBuild buildHook postBuild                (return lbi { withPrograms = progs })-               hooks flags { buildArgs = args } args+               hooks flags' { buildArgs = args } args  replAction :: UserHooks -> ReplFlags -> Args -> IO () replAction hooks flags args = do-  let distPref  = fromFlag $ replDistPref flags-      verbosity = fromFlag $ replVerbosity flags+  distPref <- findDistPrefOrDefault (replDistPref flags)+  let verbosity = fromFlag $ replVerbosity flags+      flags' = flags { replDistPref = toFlag distPref }    lbi <- getBuildConfig hooks verbosity distPref   progs <- reconfigurePrograms verbosity-             (replProgramPaths flags)-             (replProgramArgs flags)+             (replProgramPaths flags')+             (replProgramArgs flags')              (withPrograms lbi) -  pbi <- preRepl hooks args flags+  pbi <- preRepl hooks args flags'   let lbi' = lbi { withPrograms = progs }       pkg_descr0 = localPkgDescr lbi'       pkg_descr = updatePackageDescription pbi pkg_descr0-  replHook hooks pkg_descr lbi' hooks flags args-  postRepl hooks args flags pkg_descr lbi'+  replHook hooks pkg_descr lbi' hooks flags' args+  postRepl hooks args flags' pkg_descr lbi'  hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO ()-hscolourAction hooks flags args-    = do let distPref  = fromFlag $ hscolourDistPref flags-             verbosity = fromFlag $ hscolourVerbosity flags-         hookedAction preHscolour hscolourHook postHscolour-                      (getBuildConfig hooks verbosity distPref)-                      hooks flags args+hscolourAction hooks flags args = do+    distPref <- findDistPrefOrDefault (hscolourDistPref flags)+    let verbosity = fromFlag $ hscolourVerbosity flags+        flags' = flags { hscolourDistPref = toFlag distPref }+    hookedAction preHscolour hscolourHook postHscolour+                 (getBuildConfig hooks verbosity distPref)+                 hooks flags' args  haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () haddockAction hooks flags args = do-  let distPref  = fromFlag $ haddockDistPref flags-      verbosity = fromFlag $ haddockVerbosity flags+  distPref <- findDistPrefOrDefault (haddockDistPref flags)+  let verbosity = fromFlag $ haddockVerbosity flags+      flags' = flags { haddockDistPref = toFlag distPref }    lbi <- getBuildConfig hooks verbosity distPref   progs <- reconfigurePrograms verbosity-             (haddockProgramPaths flags)-             (haddockProgramArgs flags)+             (haddockProgramPaths flags')+             (haddockProgramArgs flags')              (withPrograms lbi)    hookedAction preHaddock haddockHook postHaddock                (return lbi { withPrograms = progs })-               hooks flags args+               hooks flags' args  cleanAction :: UserHooks -> CleanFlags -> Args -> IO () cleanAction hooks flags args = do-                pbi <- preClean hooks args flags+    distPref <- findDistPrefOrDefault (cleanDistPref flags)+    let flags' = flags { cleanDistPref = toFlag distPref } -                pdfile <- defaultPackageDesc verbosity-                ppd <- readPackageDescription verbosity pdfile-                let pkg_descr0 = flattenPackageDescription ppd-                -- We don't sanity check for clean as an error-                -- here would prevent cleaning:-                --sanityCheckHookedBuildInfo pkg_descr0 pbi-                let pkg_descr = updatePackageDescription pbi pkg_descr0+    pbi <- preClean hooks args flags' -                cleanHook hooks pkg_descr () hooks flags-                postClean hooks args flags pkg_descr ()-  where verbosity = fromFlag (cleanVerbosity flags)+    pdfile <- defaultPackageDesc verbosity+    ppd <- readPackageDescription verbosity pdfile+    let pkg_descr0 = flattenPackageDescription ppd+    -- We don't sanity check for clean as an error+    -- here would prevent cleaning:+    --sanityCheckHookedBuildInfo pkg_descr0 pbi+    let pkg_descr = updatePackageDescription pbi pkg_descr0 +    cleanHook hooks pkg_descr () hooks flags'+    postClean hooks args flags' pkg_descr ()+  where+    verbosity = fromFlag (cleanVerbosity flags)+ copyAction :: UserHooks -> CopyFlags -> Args -> IO ()-copyAction hooks flags args-    = do let distPref  = fromFlag $ copyDistPref flags-             verbosity = fromFlag $ copyVerbosity flags-         hookedAction preCopy copyHook postCopy-                      (getBuildConfig hooks verbosity distPref)-                      hooks flags args+copyAction hooks flags args = do+    distPref <- findDistPrefOrDefault (copyDistPref flags)+    let verbosity = fromFlag $ copyVerbosity flags+        flags' = flags { copyDistPref = toFlag distPref }+    hookedAction preCopy copyHook postCopy+                 (getBuildConfig hooks verbosity distPref)+                 hooks flags' args  installAction :: UserHooks -> InstallFlags -> Args -> IO ()-installAction hooks flags args-    = do let distPref  = fromFlag $ installDistPref flags-             verbosity = fromFlag $ installVerbosity flags-         hookedAction preInst instHook postInst-                      (getBuildConfig hooks verbosity distPref)-                      hooks flags args+installAction hooks flags args = do+    distPref <- findDistPrefOrDefault (installDistPref flags)+    let verbosity = fromFlag $ installVerbosity flags+        flags' = flags { installDistPref = toFlag distPref }+    hookedAction preInst instHook postInst+                 (getBuildConfig hooks verbosity distPref)+                 hooks flags' args  sdistAction :: UserHooks -> SDistFlags -> Args -> IO () sdistAction hooks flags args = do-                let distPref = fromFlag $ sDistDistPref flags-                pbi <- preSDist hooks args flags+    distPref <- findDistPrefOrDefault (sDistDistPref flags)+    let flags' = flags { sDistDistPref = toFlag distPref }+    pbi <- preSDist hooks args flags' -                mlbi <- maybeGetPersistBuildConfig distPref-                pdfile <- defaultPackageDesc verbosity-                ppd <- readPackageDescription verbosity pdfile-                let pkg_descr0 = flattenPackageDescription ppd-                sanityCheckHookedBuildInfo pkg_descr0 pbi-                let pkg_descr = updatePackageDescription pbi pkg_descr0+    mlbi <- maybeGetPersistBuildConfig distPref+    pdfile <- defaultPackageDesc verbosity+    ppd <- readPackageDescription verbosity pdfile+    let pkg_descr0 = flattenPackageDescription ppd+    sanityCheckHookedBuildInfo pkg_descr0 pbi+    let pkg_descr = updatePackageDescription pbi pkg_descr0 -                sDistHook hooks pkg_descr mlbi hooks flags-                postSDist hooks args flags pkg_descr mlbi-  where verbosity = fromFlag (sDistVerbosity flags)+    sDistHook hooks pkg_descr mlbi hooks flags'+    postSDist hooks args flags' pkg_descr mlbi+  where+    verbosity = fromFlag (sDistVerbosity flags)  testAction :: UserHooks -> TestFlags -> Args -> IO () testAction hooks flags args = do-    let distPref  = fromFlag $ testDistPref flags-        verbosity = fromFlag $ testVerbosity flags+    distPref <- findDistPrefOrDefault (testDistPref flags)+    let verbosity = fromFlag $ testVerbosity flags+        flags' = flags { testDistPref = toFlag distPref }+     localBuildInfo <- getBuildConfig hooks verbosity distPref     let pkg_descr = localPkgDescr localBuildInfo     -- It is safe to do 'runTests' before the new test handler because the     -- default action is a no-op and if the package uses the old test interface     -- the new handler will find no tests.     runTests hooks args False pkg_descr localBuildInfo-    --FIXME: this is a hack, passing the args inside the flags-    -- it's because the args to not get passed to the main test hook-    let flags' = flags { testList = Flag args }-    hookedAction preTest testHook postTest+    hookedActionWithArgs preTest testHook postTest             (getBuildConfig hooks verbosity distPref)             hooks flags' args  benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO () benchAction hooks flags args = do-    let distPref  = fromFlag $ benchmarkDistPref flags-        verbosity = fromFlag $ benchmarkVerbosity flags+    distPref <- findDistPrefOrDefault (benchmarkDistPref flags)+    let verbosity = fromFlag $ benchmarkVerbosity flags+        flags' = flags { benchmarkDistPref = toFlag distPref }     hookedActionWithArgs preBench benchHook postBench             (getBuildConfig hooks verbosity distPref)-            hooks flags args+            hooks flags' args  registerAction :: UserHooks -> RegisterFlags -> Args -> IO ()-registerAction hooks flags args-    = do let distPref  = fromFlag $ regDistPref flags-             verbosity = fromFlag $ regVerbosity flags-         hookedAction preReg regHook postReg-                      (getBuildConfig hooks verbosity distPref)-                      hooks flags args+registerAction hooks flags args = do+    distPref <- findDistPrefOrDefault (regDistPref flags)+    let verbosity = fromFlag $ regVerbosity flags+        flags' = flags { regDistPref = toFlag distPref }+    hookedAction preReg regHook postReg+                 (getBuildConfig hooks verbosity distPref)+                 hooks flags' args  unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO ()-unregisterAction hooks flags args-    = do let distPref  = fromFlag $ regDistPref flags-             verbosity = fromFlag $ regVerbosity flags-         hookedAction preUnreg unregHook postUnreg-                      (getBuildConfig hooks verbosity distPref)-                      hooks flags args+unregisterAction hooks flags args = do+    distPref <- findDistPrefOrDefault (regDistPref flags)+    let verbosity = fromFlag $ regVerbosity flags+        flags' = flags { regDistPref = toFlag distPref }+    hookedAction preUnreg unregHook postUnreg+                 (getBuildConfig hooks verbosity distPref)+                 hooks flags' args  hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo)         -> (UserHooks -> PackageDescription -> LocalBuildInfo@@ -482,7 +469,7 @@       let cFlags' = cFlags {             -- Since the list of unconfigured programs is not serialized,             -- restore it to the same value as normally used at the beginning-            -- of a conigure run:+            -- of a configure run:             configPrograms = restoreProgramConfiguration                                (builtinPrograms ++ hookedPrograms hooks)                                (configPrograms cFlags),@@ -498,7 +485,7 @@  clean :: PackageDescription -> CleanFlags -> IO () clean pkg_descr flags = do-    let distPref = fromFlag $ cleanDistPref flags+    let distPref = fromFlagOrDefault defaultDistPref $ cleanDistPref flags     notice verbosity "cleaning..."      maybeConfig <- if fromFlag (cleanSaveConf flags)@@ -515,7 +502,7 @@     mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr)      -- If the user wanted to save the config, write it back-    maybe (return ()) (writePersistBuildConfig distPref) maybeConfig+    traverse_ (writePersistBuildConfig distPref) maybeConfig    where         removeFileOrDirectory :: FilePath -> IO ()@@ -539,7 +526,7 @@        buildHook = defaultBuildHook,        replHook  = defaultReplHook,        copyHook  = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params-       testHook = defaultTestHook,+       testHook  = defaultTestHook,        benchHook = defaultBenchHook,        instHook  = defaultInstallHook,        sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h),@@ -600,7 +587,10 @@     = simpleUserHooks       {        postConf    = defaultPostConf,-       preBuild    = readHook buildVerbosity,+       preBuild    = \_ flags ->+                       -- not using 'readHook' here because 'build' takes+                       -- extra args+                       getHookedBuildInfo $ fromFlag $ buildVerbosity flags,        preClean    = readHook cleanVerbosity,        preCopy     = readHook copyVerbosity,        preInst     = readHook installVerbosity,@@ -682,10 +672,10 @@       info verbosity $ "Reading parameters from " ++ infoFile       readHookedBuildInfo verbosity infoFile -defaultTestHook :: PackageDescription -> LocalBuildInfo+defaultTestHook :: Args -> PackageDescription -> LocalBuildInfo                 -> UserHooks -> TestFlags -> IO ()-defaultTestHook pkg_descr localbuildinfo _ flags =-    test pkg_descr localbuildinfo flags+defaultTestHook args pkg_descr localbuildinfo _ flags =+    test args pkg_descr localbuildinfo flags  defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo                  -> UserHooks -> BenchmarkFlags -> IO ()

cabal/Cabal/Distribution/Simple/Bench.hs view

@@ -2,6 +2,7 @@ -- | -- Module      :  Distribution.Simple.Bench -- Copyright   :  Johan Tibell 2011+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -10,36 +11,6 @@ -- package. It performs the \"@.\/setup bench@\" action. It runs -- benchmarks designated in the package description. -{- 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. -}- module Distribution.Simple.Bench     ( bench     ) where@@ -48,12 +19,12 @@     ( PackageDescription(..), BuildInfo(buildable)     , Benchmark(..), BenchmarkInterface(..), benchmarkType, hasBenchmarks ) import Distribution.Simple.BuildPaths ( exeExtension )-import Distribution.Simple.Compiler ( Compiler(..) )+import Distribution.Simple.Compiler ( compilerInfo ) import Distribution.Simple.InstallDirs     ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)     , substPathTemplate , toPathTemplate, PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI-    ( LocalBuildInfo(..) )+    ( LocalBuildInfo(..), localLibraryName ) import Distribution.Simple.Setup ( BenchmarkFlags(..), fromFlag ) import Distribution.Simple.UserHooks ( Args ) import Distribution.Simple.Utils ( die, notice, rawSystemExitCode )@@ -141,8 +112,8 @@                                         ExitFailure _ -> "ERROR")  --- TODO: This is abusing the notion of a 'PathTemplate'.  The result--- isn't neccesarily a path.+-- TODO: This is abusing the notion of a 'PathTemplate'.  The result isn't+-- necessarily a path. benchOption :: PD.PackageDescription             -> LBI.LocalBuildInfo             -> PD.Benchmark@@ -152,6 +123,6 @@     fromPathTemplate $ substPathTemplate env template   where     env = initialPathTemplateEnv-          (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)-          (LBI.hostPlatform lbi) +++          (PD.package pkg_descr) (LBI.localLibraryName lbi)+          (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++           [(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)]

cabal/Cabal/Distribution/Simple/Build.hs view

@@ -4,6 +4,7 @@ -- Copyright   :  Isaac Jones 2003-2005, --                Ross Paterson 2006, --                Duncan Coutts 2007-2008, 2012+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -14,37 +15,6 @@ -- running pre-processors. -- -{- Copyright (c) 2003-2005, Isaac Jones-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. -}- module Distribution.Simple.Build (     build, repl,     startInterpreter,@@ -53,12 +23,11 @@     writeAutogenFiles,   ) where -import qualified Distribution.Simple.GHC  as GHC-import qualified Distribution.Simple.JHC  as JHC-import qualified Distribution.Simple.LHC  as LHC-import qualified Distribution.Simple.NHC  as NHC-import qualified Distribution.Simple.Hugs as Hugs-import qualified Distribution.Simple.UHC  as UHC+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.Build.Macros      as Build.Macros@@ -66,14 +35,15 @@  import Distribution.Package          ( Package(..), PackageName(..), PackageIdentifier(..)-         , Dependency(..), thisPackageVersion )+         , Dependency(..), thisPackageVersion, PackageKey(..), packageName+         , LibraryName(..) ) import Distribution.Simple.Compiler          ( Compiler, CompilerFlavor(..), compilerFlavor          , PackageDB(..), PackageDBStack ) import Distribution.PackageDescription          ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)          , TestSuite(..), TestSuiteInterface(..), Benchmark(..)-         , BenchmarkInterface(..) )+         , BenchmarkInterface(..), allBuildInfo, defaultRenaming ) import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.ModuleName as ModuleName import Distribution.ModuleName (ModuleName)@@ -83,7 +53,7 @@ import Distribution.Simple.BuildTarget          ( BuildTarget(..), readBuildTargets ) import Distribution.Simple.PreProcess-         ( preprocessComponent, PPSuffixHandler )+         ( preprocessComponent, preprocessExtras, PPSuffixHandler ) import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms)          , Component(..), componentName, getComponent, componentBuildInfo@@ -91,14 +61,15 @@          , withComponentsInBuildOrder, componentsInBuildOrder          , ComponentName(..), showComponentName          , ComponentDisabledReason(..), componentDisabledReason-         , inplacePackageId, LibraryName(..) )+         , inplacePackageId ) import Distribution.Simple.Program.Types import Distribution.Simple.Program.Db+import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.BuildPaths          ( autogenModulesDir, autogenModuleName, cppHeaderName, exeExtension ) import Distribution.Simple.Register          ( registerPackage, inplaceInstalledPackageInfo )-import Distribution.Simple.Test ( stubFilePath, stubName )+import Distribution.Simple.Test.LibV09 ( stubFilePath, stubName ) import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, rewriteFile          , die, info, debug, warn, setupMessage )@@ -108,8 +79,8 @@ import Distribution.Text          ( display ) -import Data.Maybe-         ( maybeToList )+import qualified Data.Map as Map+import qualified Data.Set as Set import Data.Either          ( partitionEithers ) import Data.List@@ -119,7 +90,8 @@ import System.FilePath          ( (</>), (<.>) ) import System.Directory-         ( getCurrentDirectory )+         ( getCurrentDirectory, removeDirectoryRecursive, removeFile+         , doesDirectoryExist, doesFileExist )  -- ----------------------------------------------------------------------------- -- |Build the libraries and executables in this package.@@ -144,7 +116,7 @@     -- Only bother with this message if we're building the whole package     setupMessage verbosity "Building" (packageId pkg_descr) -  internalPackageDB <- createInternalPackageDB distPref+  internalPackageDB <- createInternalPackageDB verbosity lbi distPref    withComponentsInBuildOrder pkg_descr lbi componentsToBuild $ \comp clbi ->     let bi     = componentBuildInfo comp@@ -181,7 +153,8 @@    initialBuildSteps distPref pkg_descr lbi verbosity -  internalPackageDB <- createInternalPackageDB distPref+  internalPackageDB <- createInternalPackageDB verbosity lbi distPref+   let lbiForComponent comp lbi' =         lbi' {           withPackageDB = withPackageDB lbi ++ [internalPackageDB],@@ -197,7 +170,7 @@                          pkg_descr lbi' suffixes comp clbi distPref     | (cname, clbi) <- init componentsToBuild ] -  -- repl for target components+  -- REPL for target components   let (cname, clbi) = componentForRepl       comp = getComponent pkg_descr cname       lbi' = lbiForComponent comp lbi@@ -208,8 +181,9 @@ startInterpreter :: Verbosity -> ProgramDb -> Compiler -> PackageDBStack -> IO () startInterpreter verbosity programDb comp packageDBs =   case compilerFlavor comp of-    GHC -> GHC.startInterpreter verbosity programDb comp packageDBs-    _   -> die "A REPL is not supported with this compiler."+    GHC   -> GHC.startInterpreter   verbosity programDb comp packageDBs+    GHCJS -> GHCJS.startInterpreter verbosity programDb comp packageDBs+    _     -> die "A REPL is not supported with this compiler."  buildComponent :: Verbosity                -> Flag (Maybe Int)@@ -223,28 +197,32 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes                comp@(CLib lib) clbi distPref = do     preprocessComponent pkg_descr comp lbi False verbosity suffixes+    extras <- preprocessExtras comp lbi     info verbosity "Building library..."-    buildLib verbosity numJobs pkg_descr lbi lib clbi+    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 installedPkgInfo =-          (inplaceInstalledPackageInfo pwd distPref pkg_descr lib lbi clbi) {-            -- The inplace registration uses the "-inplace" suffix,-            -- not an ABI hash.-            IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo)-          }+    let -- The in place registration uses the "-inplace" suffix, not an ABI hash+        ipkgid           = inplacePackageId (packageId installedPkgInfo)+        installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr+                                                       ipkgid lib' lbi clbi+     registerPackage verbosity-      installedPkgInfo pkg_descr lbi True -- True meaning inplace+      installedPkgInfo pkg_descr lbi True -- True meaning in place       (withPackageDB lbi) - buildComponent verbosity numJobs pkg_descr lbi suffixes                comp@(CExe exe) clbi _ = do     preprocessComponent pkg_descr comp lbi False verbosity suffixes+    extras <- preprocessExtras comp lbi     info verbosity $ "Building executable " ++ exeName exe ++ "..."-    buildExe verbosity numJobs pkg_descr lbi exe clbi+    let ebi = buildInfo exe+        exe' = exe { buildInfo = addExtraCSources ebi extras }+    buildExe verbosity numJobs pkg_descr lbi exe' clbi   buildComponent verbosity numJobs pkg_descr lbi suffixes@@ -252,11 +230,14 @@                clbi _distPref = do     let exe = testSuiteExeV10AsExe test     preprocessComponent pkg_descr comp lbi False verbosity suffixes+    extras <- preprocessExtras comp lbi     info verbosity $ "Building test suite " ++ testName test ++ "..."-    buildExe verbosity numJobs pkg_descr lbi exe clbi+    let ebi = buildInfo exe+        exe' = exe { buildInfo = addExtraCSources ebi extras }+    buildExe verbosity numJobs pkg_descr lbi exe' clbi  -buildComponent verbosity numJobs pkg_descr lbi suffixes+buildComponent verbosity numJobs pkg_descr lbi0 suffixes                comp@(CTest                  test@TestSuite { testInterface = TestSuiteLibV09{} })                clbi -- This ComponentLocalBuildInfo corresponds to a detailed@@ -266,13 +247,16 @@                     -- built.                distPref = do     pwd <- getCurrentDirectory-    let (pkg, lib, libClbi, ipi, exe, exeClbi) =-          testSuiteLibV09AsLibAndExe pkg_descr lbi test clbi distPref pwd+    let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) =+          testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd     preprocessComponent pkg_descr comp lbi False verbosity suffixes+    extras <- preprocessExtras comp lbi     info verbosity $ "Building test suite " ++ testName test ++ "..."     buildLib verbosity numJobs pkg lbi lib libClbi     registerPackage verbosity ipi pkg lbi True $ withPackageDB lbi-    buildExe verbosity numJobs pkg_descr lbi exe exeClbi+    let ebi = buildInfo exe+        exe' = exe { buildInfo = addExtraCSources ebi extras }+    buildExe verbosity numJobs pkg_descr lbi exe' exeClbi   buildComponent _ _ _ _ _@@ -286,8 +270,11 @@                clbi _ = do     let (exe, exeClbi) = benchmarkExeV10asExe bm clbi     preprocessComponent pkg_descr comp lbi False verbosity suffixes+    extras <- preprocessExtras comp lbi     info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..."-    buildExe verbosity numJobs pkg_descr lbi exe exeClbi+    let ebi = buildInfo exe+        exe' = exe { buildInfo = addExtraCSources ebi extras }+    buildExe verbosity numJobs pkg_descr lbi exe' exeClbi   buildComponent _ _ _ _ _@@ -296,6 +283,15 @@     die $ "No support for building benchmark type " ++ display tt  +-- | Add extra C sources generated by preprocessing to build+-- information.+addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo+addExtraCSources bi extras = bi { cSources = new }+  where new = Set.toList $ old `Set.union` exs+        old = Set.fromList $ cSources bi+        exs = Set.fromList extras++ replComponent :: Verbosity               -> PackageDescription               -> LocalBuildInfo@@ -307,12 +303,18 @@ replComponent verbosity pkg_descr lbi suffixes                comp@(CLib lib) clbi _ = do     preprocessComponent pkg_descr comp lbi False verbosity suffixes-    replLib verbosity pkg_descr lbi lib clbi+    extras <- preprocessExtras comp lbi+    let libbi = libBuildInfo lib+        lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } }+    replLib verbosity pkg_descr lbi lib' clbi  replComponent verbosity pkg_descr lbi suffixes                comp@(CExe exe) clbi _ = do     preprocessComponent pkg_descr comp lbi False verbosity suffixes-    replExe verbosity pkg_descr lbi exe clbi+    extras <- preprocessExtras comp lbi+    let ebi = buildInfo exe+        exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }+    replExe verbosity pkg_descr lbi exe' clbi   replComponent verbosity pkg_descr lbi suffixes@@ -320,18 +322,24 @@                clbi _distPref = do     let exe = testSuiteExeV10AsExe test     preprocessComponent pkg_descr comp lbi False verbosity suffixes-    replExe verbosity pkg_descr lbi exe clbi+    extras <- preprocessExtras comp lbi+    let ebi = buildInfo exe+        exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }+    replExe verbosity pkg_descr lbi exe' clbi  -replComponent verbosity pkg_descr lbi suffixes+replComponent verbosity pkg_descr lbi0 suffixes                comp@(CTest                  test@TestSuite { testInterface = TestSuiteLibV09{} })                clbi distPref = do     pwd <- getCurrentDirectory-    let (pkg, lib, libClbi, _, _, _) =-          testSuiteLibV09AsLibAndExe pkg_descr lbi test clbi distPref pwd+    let (pkg, lib, libClbi, lbi, _, _, _) =+          testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd     preprocessComponent pkg_descr comp lbi False verbosity suffixes-    replLib verbosity pkg lbi lib libClbi+    extras <- preprocessExtras comp lbi+    let libbi = libBuildInfo lib+        lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } }+    replLib verbosity pkg lbi lib' libClbi   replComponent _ _ _ _@@ -345,7 +353,10 @@                clbi _ = do     let (exe, exeClbi) = benchmarkExeV10asExe bm clbi     preprocessComponent pkg_descr comp lbi False verbosity suffixes-    replExe verbosity pkg_descr lbi exe exeClbi+    extras <- preprocessExtras comp lbi+    let ebi = buildInfo exe+        exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }+    replExe verbosity pkg_descr lbi exe' exeClbi   replComponent _ _ _ _@@ -369,29 +380,36 @@  -- | Translate a lib-style 'TestSuite' component into a lib + exe for building testSuiteLibV09AsLibAndExe :: PackageDescription-                           -> LocalBuildInfo                            -> TestSuite                            -> ComponentLocalBuildInfo+                           -> LocalBuildInfo                            -> FilePath                            -> FilePath                            -> (PackageDescription,                                Library, ComponentLocalBuildInfo,-                               IPI.InstalledPackageInfo_ ModuleName,+                               LocalBuildInfo,+                               IPI.InstalledPackageInfo,                                Executable, ComponentLocalBuildInfo)-testSuiteLibV09AsLibAndExe pkg_descr lbi+testSuiteLibV09AsLibAndExe pkg_descr                      test@TestSuite { testInterface = TestSuiteLibV09 _ m }-                     clbi distPref pwd =-    (pkg, lib, libClbi, ipi, exe, exeClbi)+                     clbi lbi distPref pwd =+    (pkg, lib, libClbi, lbi, ipi, exe, exeClbi)   where     bi  = testBuildInfo test     lib = Library {             exposedModules = [ m ],+            reexportedModules = [],+            requiredSignatures = [],+            exposedSignatures = [],             libExposed     = True,             libBuildInfo   = bi           }     libClbi = LibComponentLocalBuildInfo                 { componentPackageDeps = componentPackageDeps clbi-                , componentLibraries = [LibraryName (testName test)]+                , componentPackageRenaming = componentPackageRenaming clbi+                , componentLibraryName = LibraryName (testName test)+                , componentExposedModules = [IPI.ExposedModule m Nothing Nothing]+                , componentPackageKey = OldPackageKey (PackageIdentifier (PackageName (testName test)) (pkgVersion (package pkg_descr)))                 }     pkg = pkg_descr {             package      = (package pkg_descr) {@@ -402,9 +420,8 @@           , testSuites   = []           , library      = Just lib           }-    ipi = (inplaceInstalledPackageInfo pwd distPref pkg lib lbi libClbi) {-            IPI.installedPackageId = inplacePackageId $ packageId ipi-          }+    ipkgid = inplacePackageId (packageId pkg)+    ipi    = inplaceInstalledPackageInfo pwd distPref pkg ipkgid lib lbi libClbi     testDir = buildDir lbi </> stubName test           </> stubName test ++ "-tmp"     testLibDep = thisPackageVersion $ package pkg@@ -414,7 +431,10 @@             buildInfo  = (testBuildInfo test) {                            hsSourceDirs       = [ testDir ],                            targetBuildDepends = testLibDep-                             : (targetBuildDepends $ testBuildInfo test)+                             : (targetBuildDepends $ testBuildInfo test),+                           targetBuildRenaming =+                            Map.insert (packageName pkg) defaultRenaming+                                (targetBuildRenaming $ testBuildInfo test)                          }           }     -- | The stub executable needs a new 'ComponentLocalBuildInfo'@@ -424,9 +444,12 @@                     (IPI.installedPackageId ipi, packageId ipi)                   : (filter (\(_, x) -> let PackageName name = pkgName x                                         in name == "Cabal" || name == "base")-                            (componentPackageDeps clbi))+                            (componentPackageDeps clbi)),+                componentPackageRenaming =+                    Map.insert (packageName ipi) defaultRenaming+                               (componentPackageRenaming clbi)               }-testSuiteLibV09AsLibAndExe _ _ TestSuite{} _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"+testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"   -- | Translate a exe-style 'Benchmark' component into an exe for building@@ -442,18 +465,34 @@             buildInfo  = benchmarkBuildInfo bm           }     exeClbi = ExeComponentLocalBuildInfo {-                componentPackageDeps = componentPackageDeps clbi+                componentPackageDeps = componentPackageDeps clbi,+                componentPackageRenaming = componentPackageRenaming clbi               } benchmarkExeV10asExe Benchmark{} _ = error "benchmarkExeV10asExe: wrong kind"  -- | Initialize a new package db file for libraries defined -- internally to the package.-createInternalPackageDB :: FilePath -> IO PackageDB-createInternalPackageDB distPref = do-    let dbFile = distPref </> "package.conf.inplace"-        packageDB = SpecificPackageDB dbFile-    writeFile dbFile "[]"-    return packageDB+createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath+                        -> IO PackageDB+createInternalPackageDB verbosity lbi distPref = do+    case compilerFlavor (compiler lbi) of+      GHC   -> createWith $ GHC.hcPkgInfo   (withPrograms lbi)+      GHCJS -> createWith $ GHCJS.hcPkgInfo (withPrograms lbi)+      LHC   -> createWith $ LHC.hcPkgInfo   (withPrograms lbi)+      _     -> return packageDB+    where+      dbPath = distPref </> "package.conf.inplace"+      packageDB = SpecificPackageDB dbPath+      createWith hpi = do+        dir_exists <- doesDirectoryExist dbPath+        if dir_exists+            then removeDirectoryRecursive dbPath+            else do file_exists <- doesFileExist dbPath+                    when file_exists $ removeFile dbPath+        if HcPkg.useSingleFileDb hpi+            then writeFile dbPath "[]"+            else HcPkg.init hpi verbosity dbPath+        return packageDB  addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo                       -> ProgramDb -> ProgramDb@@ -472,18 +511,17 @@   -- TODO: build separate libs in separate dirs so that we can build--- multiple libs, e.g. for 'LibTest' library-style testsuites+-- multiple libs, e.g. for 'LibTest' library-style test suites buildLib :: Verbosity -> Flag (Maybe Int)                       -> PackageDescription -> LocalBuildInfo                       -> Library            -> ComponentLocalBuildInfo -> IO () buildLib verbosity numJobs pkg_descr lbi lib clbi =   case compilerFlavor (compiler lbi) of-    GHC  -> GHC.buildLib  verbosity numJobs pkg_descr lbi lib clbi-    JHC  -> JHC.buildLib  verbosity         pkg_descr lbi lib clbi-    LHC  -> LHC.buildLib  verbosity         pkg_descr lbi lib clbi-    Hugs -> Hugs.buildLib verbosity         pkg_descr lbi lib clbi-    NHC  -> NHC.buildLib  verbosity         pkg_descr lbi lib clbi-    UHC  -> UHC.buildLib  verbosity         pkg_descr lbi lib clbi+    GHC   -> GHC.buildLib   verbosity numJobs pkg_descr lbi lib clbi+    GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi+    JHC   -> JHC.buildLib   verbosity         pkg_descr lbi lib clbi+    LHC   -> LHC.buildLib   verbosity         pkg_descr lbi lib clbi+    UHC   -> UHC.buildLib   verbosity         pkg_descr lbi lib clbi     HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi     _    -> die "Building is not supported with this compiler." @@ -492,14 +530,12 @@                       -> Executable         -> ComponentLocalBuildInfo -> IO () buildExe verbosity numJobs pkg_descr lbi exe clbi =   case compilerFlavor (compiler lbi) of-    GHC  -> GHC.buildExe  verbosity numJobs pkg_descr lbi exe clbi-    JHC  -> JHC.buildExe  verbosity         pkg_descr lbi exe clbi-    LHC  -> LHC.buildExe  verbosity         pkg_descr lbi exe clbi-    Hugs -> Hugs.buildExe verbosity         pkg_descr lbi exe clbi-    NHC  -> NHC.buildExe  verbosity         pkg_descr lbi exe clbi-    UHC  -> UHC.buildExe  verbosity         pkg_descr lbi exe clbi-    _    -> die "Building is not supported with this compiler."-+    GHC   -> GHC.buildExe   verbosity numJobs pkg_descr lbi exe clbi+    GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi+    JHC   -> JHC.buildExe   verbosity         pkg_descr lbi exe clbi+    LHC   -> LHC.buildExe   verbosity         pkg_descr lbi exe clbi+    UHC   -> UHC.buildExe   verbosity         pkg_descr lbi exe clbi+    _     -> die "Building is not supported with this compiler."  replLib :: Verbosity -> PackageDescription -> LocalBuildInfo                      -> Library            -> ComponentLocalBuildInfo -> IO ()@@ -507,15 +543,17 @@   case compilerFlavor (compiler lbi) of     -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass     -- NoFlag as the numJobs parameter.-    GHC  -> GHC.replLib verbosity NoFlag pkg_descr lbi lib clbi-    _    -> die "A REPL is not supported for this compiler."+    GHC   -> GHC.replLib   verbosity NoFlag pkg_descr lbi lib clbi+    GHCJS -> GHCJS.replLib verbosity NoFlag pkg_descr lbi lib clbi+    _     -> die "A REPL is not supported for this compiler."  replExe :: Verbosity -> PackageDescription -> LocalBuildInfo                      -> Executable         -> ComponentLocalBuildInfo -> IO () replExe verbosity pkg_descr lbi exe clbi =   case compilerFlavor (compiler lbi) of-    GHC  -> GHC.replExe verbosity NoFlag pkg_descr lbi exe clbi-    _    -> die "A REPL is not supported for this compiler."+    GHC   -> GHC.replExe   verbosity NoFlag pkg_descr lbi exe clbi+    GHCJS -> GHCJS.replExe verbosity NoFlag pkg_descr lbi exe clbi+    _     -> die "A REPL is not supported for this compiler."   initialBuildSteps :: FilePath -- ^"dist" prefix@@ -525,12 +563,10 @@                   -> IO () initialBuildSteps _distPref pkg_descr lbi verbosity = do   -- check that there's something to build-  let buildInfos =-          map libBuildInfo (maybeToList (library pkg_descr)) ++-          map buildInfo (executables pkg_descr)-  unless (any buildable buildInfos) $ do+  unless (not . null $ allBuildInfo pkg_descr) $ do     let name = display (packageId pkg_descr)-    die ("Package " ++ name ++ " can't be built on this system.")+    die $ "No libraries, executables, tests, or benchmarks "+       ++ "are enabled for package " ++ name ++ "."    createDirectoryIfMissingVerbose verbosity True (buildDir lbi)

cabal/Cabal/Distribution/Simple/Build/Macros.hs view

@@ -30,8 +30,10 @@          ( Version(versionBranch) ) import Distribution.PackageDescription          ( PackageDescription )+import Distribution.Simple.Compiler+         ( packageKeySupported ) import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(withPrograms), externalPackageDeps )+         ( LocalBuildInfo(compiler, withPrograms), externalPackageDeps, localPackageKey ) import Distribution.Simple.Program.Db          ( configuredPrograms ) import Distribution.Simple.Program.Types@@ -49,7 +51,8 @@ generate _pkg_descr lbi =   "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" ++   generatePackageVersionMacros (map snd (externalPackageDeps lbi)) ++-  generateToolVersionMacros (configuredPrograms . withPrograms $ lbi)+  generateToolVersionMacros (configuredPrograms . withPrograms $ lbi) +++  generatePackageKeyMacro lbi  -- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@ -- macros for a list of package ids (usually used with the specific deps of@@ -92,6 +95,15 @@   ]   where     (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)++-- | Generate the @CURRENT_PACKAGE_KEY@ definition for the package key+--   of the current package, if supported by the compiler.+--   NB: this only makes sense for definite packages.+generatePackageKeyMacro :: LocalBuildInfo -> String+generatePackageKeyMacro lbi+  | packageKeySupported (compiler lbi) =+      "#define CURRENT_PACKAGE_KEY \"" ++ display (localPackageKey lbi) ++ "\"\n\n"+  | otherwise = ""  fixchar :: Char -> Char fixchar '-' = '_'

cabal/Cabal/Distribution/Simple/Build/PathsModule.hs view

@@ -32,6 +32,8 @@ import Distribution.Simple.Setup ( CopyDest(NoCopyDest) ) import Distribution.Simple.BuildPaths          ( autogenModuleName )+import Distribution.Simple.Utils+         ( shortRelativePath ) import Distribution.Text          ( display ) import Distribution.Version@@ -48,21 +50,33 @@  generate :: PackageDescription -> LocalBuildInfo -> String generate pkg_descr lbi =-   let pragmas-        | absolute || isHugs = ""+   let pragmas = cpp_pragma ++ ffi_pragmas ++ warning_pragmas++       cpp_pragma | supports_cpp = "{-# LANGUAGE CPP #-}"+                  | otherwise    = ""++       ffi_pragmas+        | absolute = ""         | supports_language_pragma =           "{-# LANGUAGE ForeignFunctionInterface #-}\n"         | otherwise =           "{-# OPTIONS_GHC -fffi #-}\n"++           "{-# OPTIONS_JHC -fffi #-}\n" +       warning_pragmas =+        "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n"+        foreign_imports         | absolute = ""-        | isHugs = "import System.Environment\n"         | otherwise =           "import Foreign\n"++           "import Foreign.C\n" +       reloc_imports+        | reloc =+          "import System.Environment (getExecutablePath)\n"+        | otherwise = ""+        header =         pragmas++         "module " ++ display paths_modulename ++ " (\n"++@@ -75,15 +89,50 @@         "import qualified Control.Exception as Exception\n"++         "import Data.Version (Version(..))\n"++         "import System.Environment (getEnv)\n"+++        reloc_imports ++         "import Prelude\n"++         "\n"++-        "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"+++        (if supports_cpp+         then+           ("#if defined(VERSION_base)\n"+++            "\n"+++            "#if MIN_VERSION_base(4,0,0)\n"+++            "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"+++            "#else\n"+++            "catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a\n"+++            "#endif\n"+++            "\n"+++            "#else\n"+++            "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"+++            "#endif\n")+         else+           "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n")++         "catchIO = Exception.catch\n" ++         "\n"++-        "\nversion :: Version"++-        "\nversion = " ++ show (packageVersion pkg_descr)+        "version :: Version"+++        "\nversion = Version " ++ show branch ++ " " ++ show tags+          where Version branch tags = packageVersion pkg_descr         body+        | reloc =+          "\n\nbindirrel :: FilePath\n" +++          "bindirrel = " ++ show flat_bindirreloc +++          "\n"+++          "\ngetBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"+++          "getBinDir = "++mkGetEnvOrReloc "bindir" flat_bindirreloc++"\n"+++          "getLibDir = "++mkGetEnvOrReloc "libdir" flat_libdirreloc++"\n"+++          "getDataDir = "++mkGetEnvOrReloc "datadir" flat_datadirreloc++"\n"+++          "getLibexecDir = "++mkGetEnvOrReloc "libexecdir" flat_libexecdirreloc++"\n"+++          "getSysconfDir = "++mkGetEnvOrReloc "sysconfdir" flat_sysconfdirreloc++"\n"+++          "\n"+++          "getDataFileName :: FilePath -> IO FilePath\n"+++          "getDataFileName name = do\n"+++          "  dir <- getDataDir\n"+++          "  return (dir `joinFileName` name)\n"+++          "\n"+++          get_prefix_reloc_stuff+++          "\n"+++          filename_stuff         | absolute =           "\nbindir, libdir, datadir, libexecdir, sysconfdir :: FilePath\n"++           "\nbindir     = " ++ show flat_bindir ++@@ -143,13 +192,23 @@           libdir     = flat_libdirrel,           datadir    = flat_datadirrel,           libexecdir = flat_libexecdirrel,-          sysconfdir = flat_sysconfdirrel,-          progdir    = flat_progdirrel+          sysconfdir = flat_sysconfdirrel         } = prefixRelativeInstallDirs (packageId pkg_descr) lbi +        flat_bindirreloc = shortRelativePath flat_prefix flat_bindir+        flat_libdirreloc = shortRelativePath flat_prefix flat_libdir+        flat_datadirreloc = shortRelativePath flat_prefix flat_datadir+        flat_libexecdirreloc = shortRelativePath flat_prefix flat_libexecdir+        flat_sysconfdirreloc = shortRelativePath flat_prefix flat_sysconfdir+         mkGetDir _   (Just dirrel) = "getPrefixDirRel " ++ show dirrel         mkGetDir dir Nothing       = "return " ++ show dir +        mkGetEnvOrReloc var dirrel = "catchIO (getEnv \""++var'++"\")" +++                                     " (\\_ -> getPrefixDirReloc \"" ++ dirrel +++                                     "\")"+          where var' = pkgPathEnvVar pkg_descr var+         mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++                               " (\\_ -> "++expr++")"           where var' = pkgPathEnvVar pkg_descr var@@ -158,30 +217,31 @@         absolute =              hasLibs pkg_descr        -- we can only make progs relocatable           || isNothing flat_bindirrel -- if the bin dir is an absolute path-          || (isHugs && isNothing flat_progdirrel)           || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) -        supportsRelocatableProgs Hugs = True+        reloc = relocatable lbi+         supportsRelocatableProgs GHC  = case buildOS of                            Windows   -> True                            _         -> False+        supportsRelocatableProgs GHCJS = case buildOS of+                           Windows   -> True+                           _         -> False         supportsRelocatableProgs _    = False          paths_modulename = autogenModuleName pkg_descr -        isHugs = compilerFlavor (compiler lbi) == Hugs-        get_prefix_stuff-          | isHugs    = "progdirrel :: String\n"++-                        "progdirrel = "++show (fromJust flat_progdirrel)++"\n\n"++-                        get_prefix_hugs-          | otherwise = get_prefix_win32 buildArch+        get_prefix_stuff = get_prefix_win32 buildArch          path_sep = show [pathSeparator] +        supports_cpp = compilerFlavor (compiler lbi) == GHC+         supports_language_pragma =-          compilerFlavor (compiler lbi) == GHC &&+          (compilerFlavor (compiler lbi) == GHC &&             (compilerVersion (compiler lbi)-              `withinRange` orLaterVersion (Version [6,6,1] []))+              `withinRange` orLaterVersion (Version [6,6,1] []))) ||+           compilerFlavor (compiler lbi) == GHCJS  -- | Generates the name of the environment variable controlling the path -- component of interest.@@ -196,6 +256,14 @@         fixchar '-' = '_'         fixchar c   = c +get_prefix_reloc_stuff :: String+get_prefix_reloc_stuff =+  "getPrefixDirReloc :: FilePath -> IO FilePath\n"+++  "getPrefixDirReloc dirRel = do\n"+++  "  exePath <- getExecutablePath\n"+++  "  let (bindir,_) = splitFileName exePath\n"+++  "  return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"+ get_prefix_win32 :: Arch -> String get_prefix_win32 arch =   "getPrefixDirRel :: FilePath -> IO FilePath\n"++@@ -217,15 +285,6 @@                   I386 -> "stdcall"                   X86_64 -> "ccall"                   _ -> error "win32 supported only with I386, X86_64"--get_prefix_hugs :: String-get_prefix_hugs =-  "getPrefixDirRel :: FilePath -> IO FilePath\n"++-  "getPrefixDirRel dirRel = do\n"++-  "  mainPath <- getProgName\n"++-  "  let (progPath,_) = splitFileName mainPath\n"++-  "  let (progdir,_) = splitFileName progPath\n"++-  "  return ((progdir `minusFileName` progdirrel) `joinFileName` dirRel)\n"  filename_stuff :: String filename_stuff =

cabal/Cabal/Distribution/Simple/BuildPaths.hs view

@@ -3,6 +3,7 @@ -- Module      :  Distribution.Simple.BuildPaths -- Copyright   :  Isaac Jones 2003-2004, --                Duncan Coutts 2008+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -10,36 +11,6 @@ -- A bunch of dirs, paths and file names used for intermediate build steps. -- -{- 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. -}- module Distribution.Simple.BuildPaths (     defaultDistPref, srcPref,     hscolourPref, haddockPref,@@ -63,14 +34,14 @@ import System.FilePath ((</>), (<.>))  import Distribution.Package-         ( packageName )+         ( packageName, LibraryName, getHSLibraryName ) import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName import Distribution.Compiler          ( CompilerId(..) ) import Distribution.PackageDescription (PackageDescription) import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(buildDir), LibraryName(..) )+         ( LocalBuildInfo(buildDir) ) import Distribution.Simple.Setup (defaultDistPref) import Distribution.Text          ( display )@@ -111,17 +82,17 @@ -- Library file names  mkLibName :: LibraryName -> String-mkLibName (LibraryName lib) = "lib" ++ lib <.> "a"+mkLibName lib = "lib" ++ getHSLibraryName lib <.> "a"  mkProfLibName :: LibraryName -> String-mkProfLibName (LibraryName lib) =  "lib" ++ lib ++ "_p" <.> "a"+mkProfLibName lib =  "lib" ++ getHSLibraryName lib ++ "_p" <.> "a"  -- Implement proper name mangling for dynamical shared objects -- libHS<packagename>-<compilerFlavour><compilerVersion> -- e.g. libHSbase-2.1-ghc6.6.1.so mkSharedLibName :: CompilerId -> LibraryName -> String-mkSharedLibName (CompilerId compilerFlavor compilerVersion) (LibraryName lib)-  = "lib" ++ lib ++ "-" ++ comp <.> dllExtension+mkSharedLibName (CompilerId compilerFlavor compilerVersion) lib+  = "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> dllExtension   where comp = display compilerFlavor ++ display compilerVersion  -- ------------------------------------------------------------@@ -136,9 +107,8 @@                    Windows -> "exe"                    _       -> "" --- ToDo: This should be determined via autoconf (AC_OBJEXT)--- | Extension for object files. For GHC and NHC the extension is @\"o\"@.--- Hugs uses either @\"o\"@ or @\"obj\"@ depending on the used C compiler.+-- TODO: This should be determined via autoconf (AC_OBJEXT)+-- | Extension for object files. For GHC the extension is @\"o\"@. objExtension :: String objExtension = "o"

cabal/Cabal/Distribution/Simple/BuildTarget.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.BuildTargets@@ -55,7 +56,10 @@          ( partitionEithers ) import qualified Data.Map as Map import Control.Monad-import Control.Applicative (Applicative(..), Alternative(..))+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative (Applicative(..))+#endif+import Control.Applicative (Alternative(..)) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP          ( (+++), (<++) )@@ -261,7 +265,7 @@ resolveBuildTarget pkg userTarget fexists =     case findMatch (matchBuildTarget pkg userTarget fexists) of       Unambiguous target  -> Right target-      Ambiguous   targets -> Left (BuildTargetAmbigious userTarget targets')+      Ambiguous   targets -> Left (BuildTargetAmbiguous userTarget targets')                                where targets' = disambiguateBuildTargets                                                     (packageId pkg) userTarget                                                     targets@@ -283,7 +287,7 @@      -- ^  [expected thing] (actually got)    | BuildTargetNoSuch    UserBuildTarget [(String, String)]      -- ^ [(no such thing,  actually got)]-   | BuildTargetAmbigious UserBuildTarget [(UserBuildTarget, BuildTarget)]+   | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)]   deriving Show  @@ -362,7 +366,7 @@           mungeThing "file" = "file target"           mungeThing thing  = thing -    case [ (t, ts) | BuildTargetAmbigious t ts <- problems ] of+    case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of       []      -> return ()       targets ->         die $ unlines@@ -426,7 +430,8 @@        cinfoSrcDirs :: [FilePath],        cinfoModules :: [ModuleName],        cinfoHsFiles :: [FilePath],   -- other hs files (like main.hs)-       cinfoCFiles  :: [FilePath]+       cinfoCFiles  :: [FilePath],+       cinfoJsFiles :: [FilePath]      }  type ComponentStringName = String@@ -439,7 +444,8 @@         cinfoSrcDirs = hsSourceDirs bi,         cinfoModules = componentModules c,         cinfoHsFiles = componentHsFiles c,-        cinfoCFiles  = cSources bi+        cinfoCFiles  = cSources bi,+        cinfoJsFiles = jsSources bi       }     | c <- pkgComponents pkg     , let bi = componentBuildInfo c ]@@ -658,12 +664,14 @@                 , matchOtherFileRooted    dirs hsFiles str ])           (msum [ matchModuleFileUnrooted      ms      str                 , matchOtherFileUnrooted       hsFiles str-                , matchOtherFileUnrooted       cFiles  str ]))+                , matchOtherFileUnrooted       cFiles  str+                , matchOtherFileUnrooted       jsFiles str ]))   where     dirs = cinfoSrcDirs c     ms   = cinfoModules c     hsFiles = cinfoHsFiles c     cFiles  = cinfoCFiles c+    jsFiles = cinfoJsFiles c   -- utils@@ -726,10 +734,10 @@ --  -- | A matcher embodies a way to match some input as being some recognised--- value. In particular it deals with multiple and ambigious matches.+-- value. In particular it deals with multiple and ambiguous matches. -- -- There are various matcher primitives ('matchExactly', 'matchInexactly'),--- ways to combine matchers ('ambigiousWith', 'shadows') and finally we can+-- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can -- run a matcher against an input using 'findMatch'. -- @@ -758,7 +766,7 @@  -- | Combine two matchers. Exact matches are used over inexact matches -- but if we have multiple exact, or inexact then the we collect all the--- ambigious matches.+-- ambiguous matches. -- matchPlus :: Match a -> Match a -> Match a matchPlus   (ExactMatch   d1 xs)   (ExactMatch   d2 xs') =@@ -776,7 +784,7 @@                                              | d1 <  d2  = b                                              | otherwise = NoMatch d1 (ms ++ ms') --- | Combine two matchers. This is similar to 'ambigiousWith' with the+-- | Combine two matchers. This is similar to 'ambiguousWith' with the -- difference that an exact match from the left matcher shadows any exact -- match on the right. Inexact matches are still collected however. --@@ -864,18 +872,18 @@ -- possible matches. There may be 'None', a single 'Unambiguous' match or -- you may have an 'Ambiguous' match with several possibilities. ---findMatch :: Eq b => Match b -> MaybeAmbigious b+findMatch :: Eq b => Match b -> MaybeAmbiguous b findMatch match =     case match of       NoMatch    _ msgs -> None (nub msgs)-      ExactMatch   _ xs -> checkAmbigious xs-      InexactMatch _ xs -> checkAmbigious xs+      ExactMatch   _ xs -> checkAmbiguous xs+      InexactMatch _ xs -> checkAmbiguous xs   where-    checkAmbigious xs = case nub xs of+    checkAmbiguous xs = case nub xs of                           [x] -> Unambiguous x                           xs' -> Ambiguous   xs' -data MaybeAmbigious a = None [MatchError] | Unambiguous a | Ambiguous [a]+data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a]   deriving Show

cabal/Cabal/Distribution/Simple/CCompiler.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.CCompiler@@ -46,8 +47,10 @@    filenameCDialect   ) where +#if __GLASGOW_HASKELL__ < 710 import Data.Monoid      ( Monoid(..) )+#endif import System.FilePath      ( takeExtension ) @@ -59,7 +62,7 @@               | ObjectiveC               | CPlusPlus               | ObjectiveCPlusPlus-              deriving (Show)+              deriving (Eq, Show)  instance Monoid CDialect where   mempty = C

cabal/Cabal/Distribution/Simple/Command.hs view

@@ -1,7 +1,9 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Command -- Copyright   :  Duncan Coutts 2007+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -14,36 +16,6 @@ -- command line completion flags. It is designed to allow other tools make -- derived commands. This feature is used heavily in @cabal-install@. -{- 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. -}- module Distribution.Simple.Command (    -- * Command interface@@ -51,10 +23,14 @@   commandShowOptions,   CommandParse(..),   commandParseArgs,+  getNormalCommandDescriptions,+  helpCommandUI,    -- ** Constructing commands   ShowOrParseArgs(..),-  makeCommand,+  usageDefault,+  usageAlternatives,+  mkCommandUI,   hiddenCommand,    -- ** Associating actions with commands@@ -88,14 +64,17 @@ import Data.Char (isAlpha, toLower) import Data.List (sortBy) import Data.Maybe+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid+#endif import qualified Distribution.GetOpt as GetOpt import Distribution.Text          ( Text(disp, parse) ) import Distribution.ParseUtils import Distribution.ReadE import Distribution.Simple.Utils (die, intercalate)-import Text.PrettyPrint    ( punctuate, cat, comma, text, empty)+import Text.PrettyPrint ( punctuate, cat, comma, text )+import Text.PrettyPrint as PP ( empty )  data CommandUI flags = CommandUI {     -- | The name of the command as it would be entered on the command line.@@ -108,6 +87,8 @@     commandUsage    :: String -> String,     -- | Additional explanation of the command to use in help texts.     commandDescription :: Maybe (String -> String),+    -- | Post-Usage notes and examples in help texts+    commandNotes :: Maybe (String -> String),     -- | Initial \/ empty flags     commandDefaultFlags :: flags,     -- | All the Option fields for this command@@ -118,11 +99,11 @@ type Name        = String type Description = String --- | We usually have a datatype for storing configuration values, where+-- | We usually have a data type for storing configuration values, where --   every field stores a configuration option, and the user sets --   the value either via command line flags or a configuration file. --   An individual OptionField models such a field, and we usually---   build a list of options associated to a configuration datatype.+--   build a list of options associated to a configuration data type. data OptionField a = OptionField {   optionName        :: Name,   optionDescr       :: [OptDescr a] }@@ -197,7 +178,7 @@     optArg ad (succeedReadE (mkflag . Just)) def showflag       where def = mkflag Nothing -noArg :: (Eq b, Monoid b) => b -> MkOptDescr (a -> b) (b -> a -> a) a+noArg :: (Eq b) => b -> MkOptDescr (a -> b) (b -> a -> a) a noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d  boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags@@ -251,7 +232,11 @@                    set' (Just txt) = readEOrFail set txt     optDescrToGetOpt (ChoiceOpt alts) =          [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ]-    optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) =+    optDescrToGetOpt (BoolOpt d (sfT, lfT) ([],  [])  set _) =+         [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True))  d ]+    optDescrToGetOpt (BoolOpt d ([],  [])  (sfF, lfF) set _) =+         [ GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d ]+    optDescrToGetOpt (BoolOpt d (sfT,lfT)  (sfF, lfF) set _) =          [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True))  ("Enable " ++ d)          , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ] @@ -283,15 +268,15 @@           (cat . punctuate comma . map text . ppr) t          OptArg _ _ _ _ _ ppr ->-          case ppr t of []        -> empty+          case ppr t of []        -> PP.empty                         (Nothing : _) -> text "True"                         (Just a  : _) -> text a          ChoiceOpt alts ->-          fromMaybe empty $ listToMaybe+          fromMaybe PP.empty $ listToMaybe           [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t] -        BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t+        BoolOpt _ _ _ _ enabled -> (maybe PP.empty disp . enabled) t  --    set :: LineNo -> String -> a -> ParseResult a       set line val a =@@ -358,12 +343,15 @@   [ showOptDescr v  od | o <- commandOptions command ParseArgs                        , od <- optionDescr o]   where+    maybePrefix []       = []+    maybePrefix (lOpt:_) = ["--" ++ lOpt]+     showOptDescr :: a -> OptDescr a -> [String]-    showOptDescr x (BoolOpt _ (_,lfT:_) (_,lfF:_) _ enabled)+    showOptDescr x (BoolOpt _ (_,lfTs) (_,lfFs) _ enabled)       = case enabled x of           Nothing -> []-          Just True  -> ["--" ++ lfT]-          Just False -> ["--" ++ lfF]+          Just True  -> maybePrefix lfTs+          Just False -> maybePrefix lfFs     showOptDescr x c@ChoiceOpt{}       = ["--" ++ val | val <- getCurrentChoice c x]     showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag)@@ -393,32 +381,55 @@ -- | The help text for this command with descriptions of all the options. commandHelp :: CommandUI flags -> String -> String commandHelp command pname =-    commandUsage command pname- ++ (GetOpt.usageInfo ""-  . addCommonFlags ShowArgs-  $ commandGetOpts ShowArgs command)- ++ case commandDescription command of-      Nothing   -> ""-      Just desc -> '\n': desc pname+    commandSynopsis command+ ++ "\n\n"+ ++ commandUsage command pname+ ++ ( case commandDescription command of+        Nothing   -> ""+        Just desc -> '\n': desc pname)+ ++ "\n"+ ++ ( if cname == ""+        then "Global flags:"+        else "Flags for " ++ cname ++ ":" )+ ++ ( GetOpt.usageInfo ""+    . addCommonFlags ShowArgs+    $ commandGetOpts ShowArgs command )+ ++ ( case commandNotes command of+        Nothing   -> ""+        Just notes -> '\n': notes pname)+  where cname = commandName command +-- | Default "usage" documentation text for commands.+usageDefault :: String -> String -> String+usageDefault name pname =+     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"+  ++ "Flags for " ++ name ++ ":"++-- | Create "usage" documentation from a list of parameter+--   configurations.+usageAlternatives :: String -> [String] -> String -> String+usageAlternatives name strs pname = unlines+  [ start ++ pname ++ " " ++ name ++ " " ++ s+  | let starts = "Usage: " : repeat "   or: "+  , (start, s) <- zip starts strs+  ]+ -- | Make a Command from standard 'GetOpt' options.-makeCommand :: String                         -- ^ name-            -> String                         -- ^ short description-            -> Maybe (String -> String)       -- ^ long description-            -> flags                          -- ^ initial\/empty flags+mkCommandUI :: String          -- ^ name+            -> String          -- ^ synopsis+            -> [String]        -- ^ usage alternatives+            -> flags           -- ^ initial\/empty flags             -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options             -> CommandUI flags-makeCommand name shortDesc longDesc defaultFlags options =-  CommandUI {-    commandName         = name,-    commandSynopsis     = shortDesc,-    commandDescription  = longDesc,-    commandUsage        = usage,-    commandDefaultFlags = defaultFlags,-    commandOptions      = options+mkCommandUI name synopsis usages flags options = CommandUI+  { commandName         = name+  , commandSynopsis     = synopsis+  , commandDescription  = Nothing+  , commandNotes        = Nothing+  , commandUsage        = usageAlternatives name usages+  , commandDefaultFlags = flags+  , commandOptions      = options   }-  where usage pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"-                   ++ "Flags for " ++ name ++ ":"  -- | Common flags that apply to every command data CommonFlag = HelpFlag | ListOptionsFlag@@ -472,9 +483,11 @@    where -- Note: It is crucial to use reverse function composition here or to         -- reverse the flags here as we want to process the flags left to right-        -- but data flow in function compsition is right to left.+        -- but data flow in function composition is right to left.         accum flags = foldr (flip (.)) id [ f | Right f <- flags ]-        unrecognised opts = [ "unrecognized option `" ++ opt ++ "'\n"+        unrecognised opts = [ "unrecognized "+                              ++ "'" ++ (commandName command) ++ "'"+                              ++ " option `" ++ opt ++ "'\n"                             | opt <- opts ]         -- For unrecognised global flags we put them in the position just after         -- the command, if there is one. This gives us a chance to parse them@@ -521,7 +534,7 @@             -> [String]             -> CommandParse (a, CommandParse action) commandsRun globalCommand commands args =-  case commandParseArgs globalCommand' True args of+  case commandParseArgs globalCommand True args of     CommandHelp      help          -> CommandHelp help     CommandList      opts          -> CommandList (opts ++ commandNames)     CommandErrors    errs          -> CommandErrors errs@@ -542,25 +555,6 @@                                    ++ " (try --help)\n"]     commands'      = commands ++ [commandAddAction helpCommandUI undefined]     commandNames   = [ name | (Command name _ _ NormalCommand) <- commands' ]-    globalCommand' = globalCommand {-      commandUsage = \pname ->-           (case commandUsage globalCommand pname of-             ""       -> ""-             original -> original ++ "\n")-        ++ "Usage: " ++ pname ++ " COMMAND [FLAGS]\n"-        ++ "   or: " ++ pname ++ " [GLOBAL FLAGS]\n\n"-        ++ "Global flags:",-      commandDescription = Just $ \pname ->-           "Commands:\n"-        ++ unlines [ "  " ++ align name ++ "    " ++ description-                   | Command name description _ NormalCommand <- commands' ]-        ++ case commandDescription globalCommand of-             Nothing   -> ""-             Just desc -> '\n': desc pname-    }-      where maxlen = maximum-                    [ length name | Command name _ _ NormalCommand <- commands' ]-            align str = str ++ replicate (maxlen - length str) ' '      -- A bit of a hack: support "prog help" as a synonym of "prog --help"     -- furthermore, support "prog help command" as "prog command --help"@@ -579,14 +573,7 @@                 _                -> CommandHelp globalHelp             _                    -> badCommand name -     where globalHelp = commandHelp globalCommand'-    helpCommandUI =-      (makeCommand "help" "Help about commands." Nothing () (const [])) {-        commandUsage = \pname ->-             "Usage: " ++ pname ++ " help [FLAGS]\n"-          ++ "   or: " ++ pname ++ " help COMMAND [FLAGS]\n\n"-          ++ "Flags for help:"-      }+     where globalHelp = commandHelp globalCommand  -- | Utility function, many commands do not accept additional flags. This -- action fails with a helpful error message if the user supplies any extra.@@ -597,3 +584,24 @@   die $ "Unrecognised flags: " ++ intercalate ", " extraFlags --TODO: eliminate this function and turn it into a variant on commandAddAction --      instead like commandAddActionNoArgs that doesn't supply the [String]++-- | Helper function for creating globalCommand description+getNormalCommandDescriptions :: [Command action] -> [(String, String)]+getNormalCommandDescriptions cmds = +  [ (name, description)+  | Command name description _ NormalCommand <- cmds ]++helpCommandUI :: CommandUI ()+helpCommandUI =+  (mkCommandUI+    "help"+    "Help about commands."+    ["[FLAGS]", "COMMAND [FLAGS]"]+    ()+    (const []))+  {+    commandNotes = Just $ \pname ->+       "Examples:\n"+    ++ "  " ++ pname ++ " help help\n"+    ++ "    Oh, appararently you already know this.\n"+  }

cabal/Cabal/Distribution/Simple/Compiler.hs view

@@ -1,7 +1,10 @@+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Compiler -- Copyright   :  Isaac Jones 2003-2004+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -17,41 +20,14 @@ -- per-user one and it lets you create arbitrary other package databases. We do -- not yet fully support this latter feature. -{- 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. -}- module Distribution.Simple.Compiler (         -- * Haskell implementations         module Distribution.Compiler,         Compiler(..),-        showCompilerId, compilerFlavor, compilerVersion,+        showCompilerId, showCompilerIdWithAbi,+        compilerFlavor, compilerVersion,+        compilerCompatVersion,+        compilerInfo,          -- * Support for package databases         PackageDB(..),@@ -64,29 +40,48 @@         OptimisationLevel(..),         flagToOptimisationLevel, +        -- * Support for debug info levels+        DebugInfoLevel(..),+        flagToDebugInfoLevel,+         -- * Support for language extensions         Flag,         languageToFlags,         unsupportedLanguages,         extensionsToFlags,         unsupportedExtensions,-        parmakeSupported+        parmakeSupported,+        reexportedModulesSupported,+        renamingPackageFlagsSupported,+        packageKeySupported,++        -- * Support for profiling detail levels+        ProfDetailLevel(..),+        knownProfDetailLevels,+        flagToProfDetailLevel,   ) where  import Distribution.Compiler import Distribution.Version (Version(..)) import Distribution.Text (display) import Language.Haskell.Extension (Language(Haskell98), Extension)+import Distribution.Simple.Utils (lowercase)  import Control.Monad (liftM)+import Distribution.Compat.Binary (Binary) import Data.List (nub) import qualified Data.Map as M (Map, lookup)-import Data.Maybe (catMaybes, isNothing)+import Data.Maybe (catMaybes, isNothing, listToMaybe)+import GHC.Generics (Generic) 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.+        compilerCompat          :: [CompilerId],+        -- ^ Other implementations that this compiler claims to be compatible with.         compilerLanguages       :: [(Language, Flag)],         -- ^ Supported language standards.         compilerExtensions      :: [(Extension, Flag)],@@ -94,17 +89,39 @@         compilerProperties      :: M.Map String String         -- ^ A key-value map for properties not covered by the above fields.     }-    deriving (Show, Read)+    deriving (Generic, Show, Read) +instance Binary Compiler+ showCompilerId :: Compiler -> String showCompilerId = display . compilerId +showCompilerIdWithAbi :: Compiler -> String+showCompilerIdWithAbi comp =+  display (compilerId comp) +++  case compilerAbiTag comp of+    NoAbiTag  -> []+    AbiTag xs -> '-':xs+ compilerFlavor ::  Compiler -> CompilerFlavor compilerFlavor = (\(CompilerId f _) -> f) . compilerId  compilerVersion :: Compiler -> Version compilerVersion = (\(CompilerId _ v) -> v) . compilerId +compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version+compilerCompatVersion flavor comp+  | compilerFlavor comp == flavor = Just (compilerVersion comp)+  | otherwise    =+      listToMaybe [ v | CompilerId fl v <- compilerCompat comp, fl == flavor ]++compilerInfo :: Compiler -> CompilerInfo+compilerInfo c = CompilerInfo (compilerId c)+                              (compilerAbiTag c)+                              (Just . compilerCompat $ c)+                              (Just . map fst . compilerLanguages $ c)+                              (Just . map fst . compilerExtensions $ c)+ -- ------------------------------------------------------------ -- * Package databases -- ------------------------------------------------------------@@ -119,8 +136,10 @@ data PackageDB = GlobalPackageDB                | UserPackageDB                | SpecificPackageDB FilePath-    deriving (Eq, Ord, Show, Read)+    deriving (Eq, Generic, Ord, Show, Read) +instance Binary PackageDB+ -- | We typically get packages from several databases, and stack them -- together. This type lets us be explicit about that stacking. For example -- typical stacks include:@@ -163,14 +182,16 @@ -- ------------------------------------------------------------  -- | Some compilers support optimising. Some have different levels.--- For compliers that do not the level is just capped to the level+-- For compilers that do not the level is just capped to the level -- they do support. -- data OptimisationLevel = NoOptimisation                        | NormalOptimisation                        | MaximumOptimisation-    deriving (Eq, Show, Read, Enum, Bounded)+    deriving (Bounded, Enum, Eq, Generic, Read, Show) +instance Binary OptimisationLevel+ flagToOptimisationLevel :: Maybe String -> OptimisationLevel flagToOptimisationLevel Nothing  = NormalOptimisation flagToOptimisationLevel (Just s) = case reads s of@@ -183,6 +204,33 @@   _             -> error $ "Can't parse optimisation level " ++ s  -- ------------------------------------------------------------+-- * Debug info levels+-- ------------------------------------------------------------++-- | Some compilers support emitting debug info. Some have different+-- levels.  For compilers that do not the level is just capped to the+-- level they do support.+--+data DebugInfoLevel = NoDebugInfo+                    | MinimalDebugInfo+                    | NormalDebugInfo+                    | MaximalDebugInfo+    deriving (Bounded, Enum, Eq, Generic, Read, Show)++instance Binary DebugInfoLevel++flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel+flagToDebugInfoLevel Nothing  = NormalDebugInfo+flagToDebugInfoLevel (Just s) = case reads s of+  [(i, "")]+    | i >= fromEnum (minBound :: DebugInfoLevel)+   && i <= fromEnum (maxBound :: DebugInfoLevel)+                -> toEnum i+    | otherwise -> error $ "Bad debug info level: " ++ show i+                        ++ ". Valid values are 0..3"+  _             -> error $ "Can't parse debug info level " ++ s++-- ------------------------------------------------------------ -- * Languages and Extensions -- ------------------------------------------------------------ @@ -218,9 +266,69 @@  -- | Does this compiler support parallel --make mode? parmakeSupported :: Compiler -> Bool-parmakeSupported comp =+parmakeSupported = ghcSupported "Support parallel --make"++-- | Does this compiler support reexported-modules?+reexportedModulesSupported :: Compiler -> Bool+reexportedModulesSupported = ghcSupported "Support reexported-modules"++-- | Does this compiler support thinning/renaming on package flags?+renamingPackageFlagsSupported :: Compiler -> Bool+renamingPackageFlagsSupported = ghcSupported "Support thinning and renaming package flags"++-- | Does this compiler support package keys?+packageKeySupported :: Compiler -> Bool+packageKeySupported = ghcSupported "Uses package keys"++-- | Utility function for GHC only features+ghcSupported :: String -> Compiler -> Bool+ghcSupported key comp =   case compilerFlavor comp of-    GHC -> case M.lookup "Support parallel --make" (compilerProperties comp) of-      Just "YES" -> True-      _          -> False-    _   -> False+    GHC   -> checkProp+    GHCJS -> checkProp+    _     -> False+  where checkProp =+          case M.lookup key (compilerProperties comp) of+            Just "YES" -> True+            _          -> False++-- ------------------------------------------------------------+-- * Profiling detail level+-- ------------------------------------------------------------++-- | Some compilers (notably GHC) support profiling and can instrument+-- programs so the system can account costs to different functions. There are+-- different levels of detail that can be used for this accounting.+-- For compilers that do not support this notion or the particular detail+-- levels, this is either ignored or just capped to some similar level+-- they do support.+--+data ProfDetailLevel = ProfDetailNone+                     | ProfDetailDefault+                     | ProfDetailExportedFunctions+                     | ProfDetailToplevelFunctions+                     | ProfDetailAllFunctions+                     | ProfDetailOther String+    deriving (Eq, Generic, Read, Show)++instance Binary ProfDetailLevel++flagToProfDetailLevel :: String -> ProfDetailLevel+flagToProfDetailLevel "" = ProfDetailDefault+flagToProfDetailLevel s  =+    case lookup (lowercase s)+                [ (name, value)+                | (primary, aliases, value) <- knownProfDetailLevels+                , name <- primary : aliases ]+      of Just value -> value+         Nothing    -> ProfDetailOther s++knownProfDetailLevels :: [(String, [String], ProfDetailLevel)]+knownProfDetailLevels =+  [ ("default",            [],                  ProfDetailDefault)+  , ("none",               [],                  ProfDetailNone)+  , ("exported-functions", ["exported"],        ProfDetailExportedFunctions)+  , ("toplevel-functions", ["toplevel", "top"], ProfDetailToplevelFunctions)+  , ("all-functions",      ["all"],             ProfDetailAllFunctions)+  ]+

cabal/Cabal/Distribution/Simple/Configure.hs view

@@ -1,7 +1,16 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+#if __GLASGOW_HASKELL__ >= 711+{-# LANGUAGE PatternSynonyms #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Configure -- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -20,42 +29,14 @@ -- the user, the amount of information displayed depending on the verbosity -- level. -{- 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. -}- module Distribution.Simple.Configure (configure,                                       writePersistBuildConfig,+                                      getConfigStateFile,                                       getPersistBuildConfig,                                       checkPersistBuildConfigOutdated,                                       tryGetPersistBuildConfig,                                       maybeGetPersistBuildConfig,+                                      findDistPref, findDistPrefOrDefault,                                       localBuildInfoFile,                                       getInstalledPackages, getPackageDBContents,                                       configCompiler, configCompilerAux,@@ -63,9 +44,7 @@                                       ccLdOptionsBuildInfo,                                       checkForeignDeps,                                       interpretPackageDbFlags,--                                      ConfigStateFileErrorType(..),-                                      ConfigStateFileError,+                                      ConfigStateFileError(..),                                       tryGetConfigStateFile,                                       platformDefines,                                      )@@ -73,46 +52,51 @@  import Distribution.Compiler     ( CompilerId(..) )+import Distribution.Utils.NubList import Distribution.Simple.Compiler-    ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion+    ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion+    , compilerInfo, ProfDetailLevel(..), knownProfDetailLevels     , showCompilerId, unsupportedLanguages, unsupportedExtensions-    , PackageDB(..), PackageDBStack )+    , PackageDB(..), PackageDBStack, reexportedModulesSupported+    , packageKeySupported, renamingPackageFlagsSupported ) import Distribution.Simple.PreProcess ( platformDefines ) import Distribution.Package     ( PackageName(PackageName), PackageIdentifier(..), PackageId     , packageName, packageVersion, Package(..)     , Dependency(Dependency), simplifyDependency-    , InstalledPackageId(..), thisPackageVersion )-import Distribution.InstalledPackageInfo as Installed-    ( InstalledPackageInfo, InstalledPackageInfo_(..)-    , emptyInstalledPackageInfo )+    , InstalledPackageId(..), thisPackageVersion+    , mkPackageKey, packageKeyLibraryName )+import qualified Distribution.InstalledPackageInfo as Installed+import Distribution.InstalledPackageInfo (InstalledPackageInfo, emptyInstalledPackageInfo) import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.PackageDescription as PD     ( PackageDescription(..), specVersion, GenericPackageDescription(..)     , Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions     , HookedBuildInfo, updatePackageDescription, allBuildInfo-    , Flag(flagName), FlagName(..), TestSuite(..), Benchmark(..) )+    , Flag(flagName), FlagName(..), TestSuite(..), Benchmark(..)+    , ModuleReexport(..) , defaultRenaming )+import Distribution.ModuleName+    ( ModuleName ) import Distribution.PackageDescription.Configuration     ( finalizePackageDescription, mapTreeData ) import Distribution.PackageDescription.Check     ( PackageCheck(..), checkPackage, checkPackageFiles )-import Distribution.Simple.Hpc ( enableCoverage ) import Distribution.Simple.Program     ( Program(..), ProgramLocation(..), ConfiguredProgram(..)     , ProgramConfiguration, defaultProgramConfiguration     , ProgramSearchPathEntry(..), getProgramSearchPath, setProgramSearchPath     , configureAllKnownPrograms, knownPrograms, lookupKnownProgram     , userSpecifyArgss, userSpecifyPaths-    , requireProgram, requireProgramVersion+    , lookupProgram, requireProgram, requireProgramVersion     , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf )-import Distribution.Simple.Setup-    ( ConfigFlags(..), CopyDest(..), fromFlag, fromFlagOrDefault, flagToMaybe )+import Distribution.Simple.Setup as Setup+    ( ConfigFlags(..), CopyDest(..), Flag(..), defaultDistPref+    , fromFlag, fromFlagOrDefault, flagToMaybe, toFlag ) import Distribution.Simple.InstallDirs     ( InstallDirs(..), defaultInstallDirs, combineInstallDirs ) import Distribution.Simple.LocalBuildInfo     ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)-    , LibraryName(..)     , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId     , ComponentName(..), showComponentName, pkgEnabledComponents     , componentBuildInfo, componentName, checkComponentsCyclic )@@ -122,33 +106,53 @@     ( die, warn, info, setupMessage     , createDirectoryIfMissingVerbose, moreRecentFile     , intercalate, cabalVersion-    , withFileContents, writeFileAtomic+    , writeFileAtomic     , withTempFile ) import Distribution.System-    ( OS(..), buildOS, Platform, buildPlatform )+    ( OS(..), buildOS, Platform (..), buildPlatform ) import Distribution.Version          ( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion ) import Distribution.Verbosity     ( Verbosity, lessVerbose ) -import qualified Distribution.Simple.GHC  as GHC-import qualified Distribution.Simple.JHC  as JHC-import qualified Distribution.Simple.LHC  as LHC-import qualified Distribution.Simple.NHC  as NHC-import qualified Distribution.Simple.Hugs as Hugs-import qualified Distribution.Simple.UHC  as UHC+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 )+#if __GLASGOW_HASKELL__ >= 711+import Control.Exception ( pattern ErrorCall )+#else+import Control.Exception ( ErrorCall(..) )+#endif import Control.Monad-    ( when, unless, foldM, filterM )+    ( liftM, when, unless, foldM, filterM )+import Distribution.Compat.Binary ( decodeOrFailIO, encode )+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 )+    ( (\\), nub, partition, isPrefixOf, inits, stripPrefix ) import Data.Maybe-    ( isNothing, catMaybes, fromMaybe )+    ( isNothing, catMaybes, fromMaybe, isJust )+import Data.Either+    ( partitionEithers )+import qualified Data.Set as Set+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid     ( Monoid(..) )+#endif import qualified Data.Map as Map import Data.Map (Map)+import Data.Traversable+    ( mapM )+import Data.Typeable import System.Directory     ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) import System.FilePath@@ -162,128 +166,185 @@ import Text.PrettyPrint     ( render, (<>), ($+$), char, text, comma     , quotes, punctuate, nest, sep, hsep )+import Distribution.Compat.Environment ( lookupEnv ) import Distribution.Compat.Exception ( catchExit, catchIO ) -import qualified Data.ByteString.Lazy.Char8 as BS.Char8+-- | 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) -data ConfigStateFileErrorType = ConfigStateFileCantParse-                              | ConfigStateFileMissing-                              | ConfigStateFileBadVersion-                              deriving Eq-type ConfigStateFileError = (String, ConfigStateFileErrorType)+instance Show ConfigStateFileError where+    show ConfigStateFileNoHeader =+        "Saved package config file header is missing. "+        ++ "Try re-running the 'configure' command."+    show ConfigStateFileBadHeader =+        "Saved package config file header is corrupt. "+        ++ "Try re-running the 'configure' command."+    show ConfigStateFileNoParse =+        "Saved package config file body is corrupt. "+        ++ "Try re-running the 'configure' command."+    show ConfigStateFileMissing = "Run the 'configure' command first."+    show (ConfigStateFileBadVersion oldCabal oldCompiler _) =+        "You need to re-run the 'configure' command. "+        ++ "The version of Cabal being used has changed (was "+        ++ display oldCabal ++ ", now "+        ++ display currentCabalId ++ ")."+        ++ badCompiler+      where+        badCompiler+          | oldCompiler == currentCompilerId = ""+          | otherwise =+              " Additionally the compiler is different (was "+              ++ display oldCompiler ++ ", now "+              ++ display currentCompilerId+              ++ ") which is probably the cause of the problem." -tryGetConfigStateFile :: (Read a) => FilePath-                         -> IO (Either ConfigStateFileError a)-tryGetConfigStateFile filename = do-  exists <- doesFileExist filename-  if not exists-    then return (Left (missing, ConfigStateFileMissing))-    else withFileContents filename $ \str ->-      case lines str of-        [header, rest] -> case checkHeader header of-          Just err -> return (Left err)-          Nothing  -> case reads rest of-            [(bi,_)] -> return (Right bi)-            _        -> return (Left (cantParse, ConfigStateFileCantParse))-        _            -> return (Left (cantParse, ConfigStateFileCantParse))-  where-    checkHeader :: String -> Maybe ConfigStateFileError-    checkHeader header = case parseHeader header of-      Just (cabalId, compId)-        | cabalId-       == currentCabalId -> Nothing-        | otherwise      -> Just (badVersion cabalId compId-                                 ,ConfigStateFileBadVersion)-      Nothing            -> Just (cantParse-                                 ,ConfigStateFileCantParse)+instance Exception ConfigStateFileError -    missing   = "Run the 'configure' command first."-    cantParse = "Saved package config file seems to be corrupt. "-             ++ "Try re-running the 'configure' command."-    badVersion cabalId compId-              = "You need to re-run the 'configure' command. "-             ++ "The version of Cabal being used has changed (was "-             ++ display cabalId ++ ", now "-             ++ display currentCabalId ++ ")."-             ++ badcompiler compId-    badcompiler compId | compId == currentCompilerId = ""-                       | otherwise-              = " Additionally the compiler is different (was "-             ++ display compId ++ ", now "-             ++ display currentCompilerId-             ++ ") which is probably the cause of the problem."+-- | 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]) --- |Try to read the 'localBuildInfoFile'.-tryGetPersistBuildConfig :: FilePath-                            -> IO (Either ConfigStateFileError LocalBuildInfo)-tryGetPersistBuildConfig distPref-    = tryGetConfigStateFile (localBuildInfoFile distPref)+    headerParseResult <- try $ evaluate $ parseHeader header+    let (cabalId, compId) =+            case headerParseResult of+              Left (ErrorCall _) -> throw ConfigStateFileBadHeader+              Right x -> x --- |Read the 'localBuildInfoFile'.  Error if it doesn't exist.  Also--- fail if the file containing LocalBuildInfo is older than the .cabal--- file, indicating that a re-configure is required.-getPersistBuildConfig :: FilePath -> IO LocalBuildInfo-getPersistBuildConfig distPref = do-  lbi <- tryGetPersistBuildConfig distPref-  either (die . fst) return lbi+    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 --- |Try to read the 'localBuildInfoFile'.-maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo)-maybeGetPersistBuildConfig distPref = do-  lbi <- tryGetPersistBuildConfig distPref-  return $ either (const Nothing) Just lbi+-- | 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 --- |After running configure, output the 'LocalBuildInfo' to the+-- | 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 -> LocalBuildInfo -> IO ()+writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path.+                        -> LocalBuildInfo -- ^ The 'LocalBuildInfo' to write.+                        -> IO () writePersistBuildConfig distPref lbi = do-  createDirectoryIfMissing False distPref-  writeFileAtomic (localBuildInfoFile distPref)-                  (BS.Char8.pack $ showHeader pkgid ++ '\n' : show lbi)-  where-    pkgid   = packageId (localPkgDescr lbi)--showHeader :: PackageIdentifier -> String-showHeader pkgid =-     "Saved package config for " ++ display pkgid-  ++ " written by " ++ display currentCabalId-  ++      " using " ++ display currentCompilerId+    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 -parseHeader :: String -> Maybe (PackageIdentifier, PackageIdentifier)-parseHeader header = case words header of-  ["Saved", "package", "config", "for", pkgid,-   "written", "by", cabalid, "using", compilerid]-    -> case (simpleParse pkgid :: Maybe PackageIdentifier,-             simpleParse cabalid,-             simpleParse compilerid) of-        (Just _,-         Just cabalid',-         Just compilerid') -> Just (cabalid', compilerid')-        _                  -> Nothing-  _                        -> Nothing+-- | 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 --- |Check that localBuildInfoFile is up-to-date with respect to the+-- | 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) --- |@dist\/setup-config@-localBuildInfoFile :: FilePath -> FilePath+-- | 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)@@ -291,10 +352,23 @@ configure (pkg_descr0, pbi) cfg   = do  let distPref = fromFlag (configDistPref cfg)             buildDir' = distPref </> "build"-            verbosity = fromFlag (configVerbosity cfg)          setupMessage verbosity "Configuring" (packageId pkg_descr0) +        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.")+         createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref          let programsConfig = mkProgramsConfig cfg (configPrograms cfg)@@ -383,7 +457,7 @@                        (configConfigurationsFlags cfg)                        dependencySatisfiable                        compPlatform-                       (compilerId comp)+                       (compilerInfo comp)                        allConstraints                        pkg_descr0''                 of Right r -> return r@@ -406,18 +480,32 @@          -- add extra include/lib dirs as specified in cfg         -- we do it here so that those get checked too-        let pkg_descr =-                enableCoverage (fromFlag (configLibCoverage cfg)) distPref-                $ addExtraIncludeLibDirs pkg_descr0'+        let pkg_descr = addExtraIncludeLibDirs pkg_descr0' +        unless (renamingPackageFlagsSupported comp ||+                    and [ rn == defaultRenaming+                        | bi <- allBuildInfo pkg_descr+                        , rn <- 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 (not (null flags)) $           info verbosity $ "Flags chosen: "                         ++ intercalate ", " [ name ++ "=" ++ display value                                             | (FlagName name, value) <- flags ] +        when (maybe False (not.null.PD.reexportedModules) (PD.library 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."+         checkPackageProblems verbosity pkg_descr0           (updatePackageDescription pbi pkg_descr) +        -- Handle hole instantiation+        (holeDeps, hole_insts) <- configureInstantiateWith pkg_descr cfg installedPackageSet+         let selectDependencies :: [Dependency] ->                                   ([FailedDependency], [ResolvedDependency])             selectDependencies =@@ -444,9 +532,14 @@         reportFailedDependencies failedDeps         reportSelectedDependencies verbosity allPkgDeps +        let installDeps = Map.elems+                        . Map.fromList+                        . map (\v -> (Installed.installedPackageId v, v))+                        $ externalPkgDeps ++ holeDeps+         packageDependsIndex <-           case PackageIndex.dependencyClosure installedPackageSet-                  (map Installed.installedPackageId externalPkgDeps) of+                  (map Installed.installedPackageId installDeps) of             Left packageDependsIndex -> return packageDependsIndex             Right broken ->               die $ "The following installed packages are broken because other"@@ -463,7 +556,7 @@                    InstalledPackageId (display (packageId pkg_descr)),                 Installed.sourcePackageId = packageId pkg_descr,                 Installed.depends =-                  map Installed.installedPackageId externalPkgDeps+                  map Installed.installedPackageId installDeps               }         case PackageIndex.dependencyInconsistencies            . PackageIndex.insert pseudoTopPkg@@ -478,13 +571,6 @@                          | (name, uses) <- inconsistencies                          , (pkg, ver) <- uses ] -        -- internal component graph-        buildComponents <--          case mkComponentsLocalBuildInfo pkg_descr-                 internalPkgDeps externalPkgDeps of-            Left  componentCycle -> reportComponentCycle componentCycle-            Right components     -> return components-         -- installation directories         defaultDirs <- defaultInstallDirs flavor userInstall (hasLibs pkg_descr)         let installDirs = combineInstallDirs fromFlagOrDefault@@ -529,26 +615,102 @@         (pkg_descr', programsConfig''') <-           configurePkgconfigPackages verbosity pkg_descr programsConfig'' +        -- internal component graph+        buildComponents <-+          case mkComponentsGraph pkg_descr internalPkgDeps of+            Left  componentCycle -> reportComponentCycle componentCycle+            Right components     ->+              mkComponentsLocalBuildInfo comp packageDependsIndex pkg_descr+                                         internalPkgDeps externalPkgDeps holeDeps+                                         (Map.fromList hole_insts)+                                         components+         split_objs <-            if not (fromFlag $ configSplitObjs cfg)                 then return False                 else case flavor of                             GHC | version >= Version [6,5] [] -> return True+                            GHCJS                             -> return True                             _ -> do warn verbosity                                          ("this compiler does not support " ++                                           "--enable-split-objs; ignoring")                                     return False -        let sharedLibsByDefault =+        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.ghcDynamic comp+                  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,+                    configFlags         = cfg',                     extraConfigArgs     = [],  -- Currently configure does not                                                -- take extra args, but if it                                                -- did they would go here.@@ -556,30 +718,34 @@                     compiler            = comp,                     hostPlatform        = compPlatform,                     buildDir            = buildDir',-                    scratchDir          = fromFlagOrDefault-                                            (distPref </> "scratch")-                                            (configScratchDir cfg),                     componentsConfigs   = buildComponents,                     installedPkgs       = packageDependsIndex,                     pkgDescrFile        = Nothing,                     localPkgDescr       = pkg_descr',+                    instantiatedWith    = hole_insts,                     withPrograms        = programsConfig''',                     withVanillaLib      = fromFlag $ configVanillaLib cfg,-                    withProfLib         = fromFlag $ configProfLib cfg,-                    withSharedLib       = fromFlagOrDefault sharedLibsByDefault $-                                          configSharedLib cfg,-                    withDynExe          = fromFlag $ configDynExe cfg,-                    withProfExe         = fromFlag $ configProfExe cfg,+                    withProfLib         = profEnabledLib,+                    withSharedLib       = withSharedLib_,+                    withDynExe          = withDynExe_,+                    withProfExe         = profEnabledExe,+                    withProfLibDetail   = profDetailLib,+                    withProfExeDetail   = profDetailExe,                     withOptimization    = fromFlag $ configOptimization cfg,-                    withGHCiLib         = fromFlag $ configGHCiLib 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+                    progSuffix          = fromFlag $ configProgSuffix cfg,+                    relocatable         = reloc                   } +        when reloc (checkRelocatable verbosity pkg_descr lbi)+         let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest             relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi @@ -612,6 +778,8 @@         return lbi      where+      verbosity = fromFlag (configVerbosity cfg)+       addExtraIncludeLibDirs pkg_descr =           let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg                                , PD.includeDirs = configExtraIncludeDirs cfg}@@ -623,6 +791,15 @@                       , executables = modifyExecutable  `map`                                       executables pkg_descr} +      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@@ -631,7 +808,7 @@                    . setProgramSearchPath searchpath                    $ initialProgramsConfig     searchpath     = getProgramSearchPath (initialProgramsConfig)-                  ++ map ProgramSearchPathDir (configProgramPathExtra cfg)+                  ++ map ProgramSearchPathDir (fromNubList $ configProgramPathExtra cfg)  -- ----------------------------------------------------------------------------- -- Configuring package dependencies@@ -653,14 +830,14 @@  data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo                         | InternalDependency Dependency PackageId -- should be a-                                                                  -- lib name+                                                                      -- lib name  data FailedDependency = DependencyNotExists PackageName                       | DependencyNoVersion Dependency  -- | Test for a package dependency and record the version we have installed.-selectDependency :: PackageIndex  -- ^ Internally defined packages-                 -> PackageIndex  -- ^ Installed packages+selectDependency :: InstalledPackageIndex  -- ^ Internally defined packages+                 -> InstalledPackageIndex  -- ^ Installed packages                  -> Map PackageName InstalledPackageInfo                     -- ^ Packages for which we have been given specific deps to use                  -> Dependency@@ -720,9 +897,11 @@     reportFailedDependency (DependencyNoVersion dep) =         "cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n" +-- | List all installed packages in the given package databases. getInstalledPackages :: Verbosity -> Compiler-                     -> PackageDBStack -> ProgramConfiguration-                     -> IO PackageIndex+                     -> 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 "@@ -731,12 +910,11 @@    info verbosity "Reading installed packages..."   case compilerFlavor comp of-    GHC -> GHC.getInstalledPackages verbosity packageDBs progconf-    Hugs->Hugs.getInstalledPackages verbosity packageDBs progconf-    JHC -> JHC.getInstalledPackages verbosity packageDBs progconf-    LHC -> LHC.getInstalledPackages verbosity packageDBs progconf-    NHC -> NHC.getInstalledPackages verbosity packageDBs progconf-    UHC -> UHC.getInstalledPackages verbosity comp packageDBs progconf+    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 "@@ -745,12 +923,12 @@ -- | Like 'getInstalledPackages', but for a single package DB. getPackageDBContents :: Verbosity -> Compiler                      -> PackageDB -> ProgramConfiguration-                     -> IO PackageIndex+                     -> 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 @@ -772,8 +950,7 @@     extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs  newPackageDepsBehaviourMinVersion :: Version-newPackageDepsBehaviourMinVersion = Version { versionBranch = [1,7,1],-                                              versionTags = [] }+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@@ -796,7 +973,7 @@ -- pick. combinedConstraints :: [Dependency] ->                        [(PackageName, InstalledPackageId)] ->-                       PackageIndex ->+                       InstalledPackageIndex ->                        Either String ([Dependency],                                       Map PackageName InstalledPackageInfo) combinedConstraints constraints dependencies installedPackages = do@@ -858,6 +1035,58 @@            | (pkgname, ipkgid) <- deps ]  -- -----------------------------------------------------------------------------+-- Configuring hole instantiation++configureInstantiateWith :: PackageDescription+                         -> ConfigFlags+                         -> InstalledPackageIndex -- ^ installed packages+                         -> IO ([InstalledPackageInfo],+                                [(ModuleName, (InstalledPackageInfo, ModuleName))])+configureInstantiateWith pkg_descr cfg installedPackageSet = do+        -- Holes: First, check and make sure the provided instantiation covers+        -- all the holes we know about.  Indefinite package installation is+        -- not handled at all at this point.+        -- NB: We union together /all/ of the requirements when calculating+        -- the package key.+        -- NB: For now, we assume that dependencies don't contribute signatures.+        -- This will be handled by cabal-install; as far as ./Setup is+        -- concerned, the most important thing is to be provided correctly+        -- built dependencies.+        let signatures =+              maybe [] (\lib -> requiredSignatures lib ++ exposedSignatures lib)+                (PD.library pkg_descr)+            signatureSet = Set.fromList signatures+            instantiateMap = Map.fromList (configInstantiateWith cfg)+            missing_impls = filter (not . flip Map.member instantiateMap) signatures+            hole_insts0 = filter (\(k,_) -> Set.member k signatureSet) (configInstantiateWith cfg)++        when (not (null missing_impls)) $+          die $ "Missing signature implementations for these modules: "+            ++ intercalate ", " (map display missing_impls)++        -- Holes: Next, we need to make sure we have packages to actually+        -- provide the implementations we're talking about.  This is on top+        -- of the normal dependency resolution process.+        -- TODO: internal dependencies (e.g. the test package depending on the+        -- main library) is not currently supported+        let selectHoleDependency (k,(i,m)) =+              case PackageIndex.lookupInstalledPackageId installedPackageSet i of+                Just pkginst -> Right (k,(pkginst, m))+                Nothing -> Left i+            (failed_hmap, hole_insts) = partitionEithers (map selectHoleDependency hole_insts0)+            holeDeps = map (fst.snd) hole_insts -- could have dups++        -- Holes: Finally, any dependencies selected this way have to be+        -- included in the allPkgs index, as well as the buildComponents.+        -- But don't report these as potential inconsistencies!++        when (not (null failed_hmap)) $+          die $ "Could not resolve these package IDs (from signature implementations): "+            ++ intercalate ", " (map display failed_hmap)++        return (holeDeps, hole_insts)++-- ----------------------------------------------------------------------------- -- Configuring program dependencies  configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration@@ -895,9 +1124,12 @@                        (lessVerbose verbosity) pkgConfigProgram                        (orLaterVersion $ Version [0,9,0] []) conf     mapM_ requirePkg allpkgs-    lib'  <- updateLibrary (library pkg_descr)-    exes' <- mapM updateExecutable (executables pkg_descr)-    let pkg_descr' = pkg_descr { library = lib', executables = exes' }+    lib' <- mapM addPkgConfigBILib (library 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 { library = lib', executables = exes',+                                 testSuites = tests', benchmarks = benches' }     return (pkg_descr', conf')    where@@ -914,9 +1146,11 @@         Just v | not (withinRange v range) -> die (badVersion v)                | otherwise                 -> info verbosity (depSatisfied v)       where-        notFound     = "The pkg-config package " ++ pkg ++ versionRequirement+        notFound     = "The pkg-config package '" ++ pkg ++ "'"+                    ++ versionRequirement                     ++ " is required but it could not be found."-        badVersion v = "The pkg-config package " ++ pkg ++ versionRequirement+        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@@ -926,15 +1160,27 @@           | isAnyVersion range = ""           | otherwise          = " version " ++ display range -    updateLibrary Nothing    = return Nothing-    updateLibrary (Just lib) = do-      bi <- pkgconfigBuildInfo (pkgconfigDepends (libBuildInfo lib))-      return $ Just lib { libBuildInfo = libBuildInfo lib `mappend` bi }+    -- 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) -    updateExecutable exe = do-      bi <- pkgconfigBuildInfo (pkgconfigDepends (buildInfo exe))-      return exe { buildInfo = buildInfo exe `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 mempty     pkgconfigBuildInfo pkgdeps = do@@ -985,13 +1231,12 @@ 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-    JHC  -> JHC.configure  verbosity hcPath hcPkg conf-    LHC  -> do (_, _, ghcConf) <- GHC.configure  verbosity Nothing hcPkg conf-               LHC.configure  verbosity hcPath Nothing ghcConf-    Hugs -> Hugs.configure verbosity hcPath hcPkg conf-    NHC  -> NHC.configure  verbosity hcPath hcPkg conf-    UHC  -> UHC.configure  verbosity hcPath hcPkg conf+    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)@@ -1019,19 +1264,16 @@ -- Making the internal component graph  -mkComponentsLocalBuildInfo :: PackageDescription-                           -> [PackageId] -> [InstalledPackageInfo]-                           -> Either [ComponentName]-                                     [(ComponentName,-                                       ComponentLocalBuildInfo, [ComponentName])]-mkComponentsLocalBuildInfo pkg_descr internalPkgDeps externalPkgDeps =+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 [ (cname, clbi, cdeps)-                               | (c, cname, cdeps) <- graph-                               , let clbi = componentLocalBuildInfo c ]+          Nothing     -> Right [ (c, cdeps) | (c, _, cdeps) <- graph ]   where     -- The dependencies for the given component     componentDeps component =@@ -1045,6 +1287,31 @@       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] ]++mkComponentsLocalBuildInfo :: Compiler+                           -> InstalledPackageIndex+                           -> PackageDescription+                           -> [PackageId] -- internal package deps+                           -> [InstalledPackageInfo] -- external package deps+                           -> [InstalledPackageInfo] -- hole package deps+                           -> Map ModuleName (InstalledPackageInfo, ModuleName)+                           -> [(Component, [ComponentName])]+                           -> IO [(ComponentName, ComponentLocalBuildInfo,+                                                  [ComponentName])]+mkComponentsLocalBuildInfo comp installedPackages pkg_descr+                           internalPkgDeps externalPkgDeps holePkgDeps hole_insts+                           graph =+    sequence+      [ do clbi <- componentLocalBuildInfo c+           return (componentName c, clbi, cdeps)+      | (c, cdeps) <- graph ]+  where     -- 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@@ -1052,48 +1319,207 @@     -- versions of the same package.     componentLocalBuildInfo component =       case component of-      CLib _ ->-        LibComponentLocalBuildInfo {+      CLib lib -> do+        let exports = map (\n -> Installed.ExposedModule n Nothing Nothing)+                          (PD.exposedModules lib)+            esigs = map (\n -> Installed.ExposedModule n Nothing+                                (fmap (\(pkg,m) -> Installed.OriginalModule+                                                      (Installed.installedPackageId pkg) m)+                                      (Map.lookup n hole_insts)))+                        (PD.exposedSignatures lib)+        let mb_reexports = resolveModuleReexports installedPackages+                                                  (packageId pkg_descr)+                                                  externalPkgDeps lib+        reexports <- case mb_reexports of+            Left problems -> reportModuleReexportProblems problems+            Right r -> return r++        -- Calculate the version hash and package key.+        let externalPkgs = selectSubset bi externalPkgDeps+            pkg_key = mkPackageKey (packageKeySupported comp)+                        (package pkg_descr)+                        (map Installed.libraryName externalPkgs)+            version_hash = packageKeyLibraryName (package pkg_descr) pkg_key++        return LibComponentLocalBuildInfo {           componentPackageDeps = cpds,-          componentLibraries = [LibraryName-                                ("HS" ++ display (package pkg_descr))]+          componentPackageKey = pkg_key,+          componentLibraryName = version_hash,+          componentPackageRenaming = cprns,+          componentExposedModules = exports ++ reexports ++ esigs         }       CExe _ ->-        ExeComponentLocalBuildInfo {-          componentPackageDeps = cpds+        return ExeComponentLocalBuildInfo {+          componentPackageDeps = cpds,+          componentPackageRenaming = cprns         }       CTest _ ->-        TestComponentLocalBuildInfo {-          componentPackageDeps = cpds+        return TestComponentLocalBuildInfo {+          componentPackageDeps = cpds,+          componentPackageRenaming = cprns         }       CBench _ ->-        BenchComponentLocalBuildInfo {-          componentPackageDeps = cpds+        return BenchComponentLocalBuildInfo {+          componentPackageDeps = cpds,+          componentPackageRenaming = cprns         }       where         bi = componentBuildInfo component+        dedup = Map.toList . Map.fromList         cpds = if newPackageDepsBehaviour pkg_descr-               then [ (installedPackageId pkg, packageId pkg)+               then dedup $+                    [ (Installed.installedPackageId pkg, packageId pkg)                     | pkg <- selectSubset bi externalPkgDeps ]                  ++ [ (inplacePackageId pkgid, pkgid)                     | pkgid <- selectSubset bi internalPkgDeps ]-               else [ (installedPackageId pkg, packageId pkg)+               else [ (Installed.installedPackageId pkg, packageId pkg)                     | pkg <- externalPkgDeps ]+        cprns = if newPackageDepsBehaviour pkg_descr+                then Map.unionWith mappend+                        -- We need hole dependencies passed to GHC, so add them here+                        -- (but note that they're fully thinned out.  If they+                        -- appeared legitimately the monoid instance will+                        -- fill them out.+                        (Map.fromList [(packageName pkg, mempty) | pkg <- holePkgDeps])+                        (targetBuildRenaming bi)+                -- Hack: if we have old package-deps behavior, it's impossible+                -- for non-default renamings to be used, because the Cabal+                -- version is too early.  This is a good, because while all the+                -- deps were bundled up in buildDepends, we didn't do this for+                -- renamings, so it's not even clear how to get the merged+                -- version.  So just assume that all of them are the default..+                else Map.fromList (map (\(_,pid) -> (packageName pid, defaultRenaming)) cpds)      selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg]     selectSubset bi pkgs =-        [ pkg | pkg <- pkgs, packageName pkg `elem` names ]-      where-        names = [ name | Dependency name _ <- targetBuildDepends bi ]+        [ pkg | pkg <- pkgs, packageName pkg `elem` names bi ] -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] ]+    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+                       -> [InstalledPackageInfo]+                       -> Library+                       -> Either [(ModuleReexport, String)] -- errors+                                 [Installed.ExposedModule] -- ok+resolveModuleReexports installedPackages srcpkgid 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.installedPackageId externalPkgDeps)+        , pkg <- PackageIndex.allPackages installedPackages+        , Installed.installedPackageId 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+              -- we don't know the InstalledPackageId of this package yet+              -- we will fill it in later, before registration.+              definingPackageId    = InstalledPackageId ""+              originalModule = Installed.OriginalModule definingPackageId+                                                        definingModuleName+              exposedModule  = Installed.ExposedModule visibleModuleName+                                                       (Just originalModule)+                                                             Nothing+        ] +    -- 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 (Installed.OriginalModule (Installed.installedPackageId 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 @@ -1191,6 +1617,16 @@            `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:"@@ -1254,3 +1690,69 @@   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+        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 ()+        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

cabal/Cabal/Distribution/Simple/GHC.hs view

@@ -1,1369 +1,1160 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.GHC--- Copyright   :  Isaac Jones 2003-2007------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This is a fairly large module. It contains most of the GHC-specific code for--- configuring, building and installing packages. It also exports a function--- for finding out what packages are already installed. Configuring involves--- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions--- this version of ghc supports and returning a 'Compiler' value.------ 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out--- what packages are installed.------ Building is somewhat complex as there is quite a bit of information to take--- into account. We have to build libs and programs, possibly for profiling and--- shared libs. We have to support building libraries that will be usable by--- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files--- using ghc. Linking, especially for @split-objs@ is remarkably complex,--- partly because there tend to be 1,000's of @.o@ files and this can often be--- more than we can pass to the @ld@ or @ar@ programs in one go.------ Installing for libs and exes involves finding the right files and copying--- them to the right places. One of the more tricky things about this module is--- remembering the layout of files in the build directory (which is not--- explicitly documented) and thus what search dirs are used for various kinds--- of files.--{- Copyright (c) 2003-2005, Isaac Jones-All rights reserved.--Redistribution and use in source and binary forms, with or without-modiication, 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. -}--module Distribution.Simple.GHC (-        getGhcInfo,-        configure, getInstalledPackages, getPackageDBContents,-        buildLib, buildExe,-        replLib, replExe,-        startInterpreter,-        installLib, installExe,-        libAbiHash,-        initPackageDB,-        invokeHcPkg,-        registerPackage,-        componentGhcOptions,-        ghcLibDir,-        ghcDynamic,- ) where--import qualified Distribution.Simple.GHC.IPI641 as IPI641-import qualified Distribution.Simple.GHC.IPI642 as IPI642-import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..), Executable(..)-         , Library(..), libModules, exeModules, hcOptions-         , usedExtensions, allExtensions )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-                                ( InstalledPackageInfo_(..) )-import Distribution.Simple.PackageIndex (PackageIndex)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-         , LibraryName(..), absoluteInstallDirs )-import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs )-import Distribution.Simple.BuildPaths-import Distribution.Simple.Utils-import Distribution.Package-         ( Package(..), PackageName(..) )-import qualified Distribution.ModuleName as ModuleName-import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), ProgramConfiguration-         , ProgramLocation(..), ProgramSearchPath, ProgramSearchPathEntry(..)-         , rawSystemProgram-         , rawSystemProgramStdout, rawSystemProgramStdoutConf-         , getProgramOutput, getProgramInvocationOutput, suppressOverrideArgs-         , requireProgramVersion, requireProgram-         , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram-         , ghcProgram, ghcPkgProgram, hsc2hsProgram-         , arProgram, ldProgram-         , gccProgram, stripProgram )-import qualified Distribution.Simple.Program.HcPkg as HcPkg-import qualified Distribution.Simple.Program.Ar    as Ar-import qualified Distribution.Simple.Program.Ld    as Ld-import qualified Distribution.Simple.Program.Strip as Strip-import Distribution.Simple.Program.GHC-import Distribution.Simple.Setup-         ( toFlag, fromFlag, fromFlagOrDefault )-import qualified Distribution.Simple.Setup as Cabal-        ( Flag )-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion-         , OptimisationLevel(..), PackageDB(..), PackageDBStack-         , Flag )-import Distribution.Version-         ( Version(..), anyVersion, orLaterVersion )-import Distribution.System-         ( OS(..), buildOS )-import Distribution.Verbosity-import Distribution.Text-         ( display, simpleParse )-import Language.Haskell.Extension (Language(..), Extension(..)-                                  ,KnownExtension(..))--import Control.Monad            ( unless, when )-import Data.Char                ( isSpace )-import Data.List-import qualified Data.Map as M  ( Map, fromList, lookup )-import Data.Maybe               ( catMaybes, fromMaybe, maybeToList )-import Data.Monoid              ( Monoid(..) )-import System.Directory-         ( getDirectoryContents, doesFileExist, getTemporaryDirectory )-import System.FilePath          ( (</>), (<.>), takeExtension,-                                  takeDirectory, replaceExtension,-                                  splitExtension )-import System.IO (hClose, hPutStrLn)-import System.Environment (getEnv)-import Distribution.Compat.Exception (catchExit, catchIO)-import Distribution.System (Platform, platformFromTriple)----- -------------------------------------------------------------------------------- Configuring--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration-          -> IO (Compiler, Maybe Platform, ProgramConfiguration)-configure verbosity hcPath hcPkgPath conf0 = do--  (ghcProg, ghcVersion, conf1) <--    requireProgramVersion verbosity ghcProgram-      (orLaterVersion (Version [6,4] []))-      (userMaybeSpecifyPath "ghc" hcPath conf0)--  -- 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) <--    requireProgramVersion verbosity ghcPkgProgram {-      programFindLocation = guessGhcPkgFromGhcPath ghcProg-    }-    anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath conf1)--  when (ghcVersion /= ghcPkgVersion) $ die $-       "Version mismatch between ghc and ghc-pkg: "-    ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " "-    ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion--  -- Likewise we try to find the matching hsc2hs program.-  let hsc2hsProgram' = hsc2hsProgram {-                           programFindLocation = guessHsc2hsFromGhcPath ghcProg-                       }-      conf3 = addKnownProgram hsc2hsProgram' conf2--  languages  <- getLanguages verbosity ghcProg-  extensions <- getExtensions verbosity ghcProg--  ghcInfo <- getGhcInfo verbosity ghcProg-  let ghcInfoMap = M.fromList ghcInfo--  let comp = Compiler {-        compilerId         = CompilerId GHC ghcVersion,-        compilerLanguages  = languages,-        compilerExtensions = extensions,-        compilerProperties = ghcInfoMap-      }-      compPlatform = targetPlatform ghcInfo-      conf4 = configureToolchain ghcProg ghcInfoMap conf3 -- configure gcc and ld-  return (comp, compPlatform, conf4)--targetPlatform :: [(String, String)] -> Maybe Platform-targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo---- | 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--- for a versioned or unversioned ghc-pkg in the same dir, that is:------ > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe)--- > /usr/local/bin/ghc-pkg-6.6.1(.exe)--- > /usr/local/bin/ghc-pkg(.exe)----guessToolFromGhcPath :: Program -> ConfiguredProgram-                     -> Verbosity -> ProgramSearchPath-                     -> IO (Maybe FilePath)-guessToolFromGhcPath tool ghcProg verbosity searchpath-  = do let toolname          = programName tool-           path              = programPath ghcProg-           dir               = takeDirectory path-           versionSuffix     = takeVersionSuffix (dropExeExtension path)-           guessNormal       = dir </> toolname <.> exeExtension-           guessGhcVersioned = dir </> (toolname ++ "-ghc" ++ versionSuffix)-                               <.> exeExtension-           guessVersioned    = dir </> (toolname ++ versionSuffix)-                               <.> exeExtension-           guesses | null versionSuffix = [guessNormal]-                   | otherwise          = [guessGhcVersioned,-                                           guessVersioned,-                                           guessNormal]-       info verbosity $ "looking for tool " ++ toolname-         ++ " near compiler in " ++ dir-       exists <- mapM doesFileExist guesses-       case [ file | (file, True) <- zip guesses exists ] of-                   -- If we can't find it near ghc, fall back to the usual-                   -- method.-         []     -> programFindLocation tool verbosity searchpath-         (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp-                      return (Just fp)--  where takeVersionSuffix :: FilePath -> String-        takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") .-                            reverse--        dropExeExtension :: FilePath -> FilePath-        dropExeExtension filepath =-          case splitExtension filepath of-            (filepath', extension) | extension == exeExtension -> filepath'-                                   | otherwise                 -> filepath---- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a--- corresponding ghc-pkg, we try looking for both a versioned and unversioned--- ghc-pkg in the same dir, that is:------ > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe)--- > /usr/local/bin/ghc-pkg-6.6.1(.exe)--- > /usr/local/bin/ghc-pkg(.exe)----guessGhcPkgFromGhcPath :: ConfiguredProgram-                       -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)-guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram---- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a--- corresponding hsc2hs, we try looking for both a versioned and unversioned--- hsc2hs in the same dir, that is:------ > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe)--- > /usr/local/bin/hsc2hs-6.6.1(.exe)--- > /usr/local/bin/hsc2hs(.exe)----guessHsc2hsFromGhcPath :: ConfiguredProgram-                       -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)-guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram---- | Adjust the way we find and configure gcc and ld----configureToolchain :: ConfiguredProgram -> M.Map String String-                                        -> ProgramConfiguration-                                        -> ProgramConfiguration-configureToolchain ghcProg ghcInfo =-    addKnownProgram gccProgram {-      programFindLocation = findProg gccProgram extraGccPath,-      programPostConf     = configureGcc-    }-  . addKnownProgram ldProgram {-      programFindLocation = findProg ldProgram extraLdPath,-      programPostConf     = configureLd-    }-  . addKnownProgram arProgram {-      programFindLocation = findProg arProgram extraArPath-    }-  . addKnownProgram stripProgram {-      programFindLocation = findProg stripProgram extraStripPath-    }-  where-    Just ghcVersion = programVersion ghcProg-    compilerDir = takeDirectory (programPath ghcProg)-    baseDir     = takeDirectory compilerDir-    mingwBinDir = baseDir </> "mingw" </> "bin"-    libDir      = baseDir </> "gcc-lib"-    includeDir  = baseDir </> "include" </> "mingw"-    isWindows   = case buildOS of Windows -> True; _ -> False-    binPrefix   = ""--    mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]-    mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath]-                                 | otherwise = mbDir-      where-        mbDir = maybeToList . fmap takeDirectory $ mbPath--    extraGccPath   = mkExtraPath mbGccLocation   windowsExtraGccDir-    extraLdPath    = mkExtraPath mbLdLocation    windowsExtraLdDir-    extraArPath    = mkExtraPath mbArLocation    windowsExtraArDir-    extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir--    -- on Windows finding and configuring ghc's gcc & binutils is a bit special-    windowsExtraGccDir-      | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix-      | otherwise                       = baseDir-    windowsExtraLdDir-      | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix-      | otherwise                       = libDir-    windowsExtraArDir-      | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix-      | otherwise                       = libDir-    windowsExtraStripDir-      | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix-      | otherwise                       = libDir--    findProg :: Program -> [FilePath]-             -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)-    findProg prog extraPath v searchpath =-        programFindLocation prog v searchpath'-      where-        searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath--    -- 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--    ccFlags        = getFlags "C compiler flags"-    gccLinkerFlags = getFlags "Gcc Linker flags"-    ldLinkerFlags  = getFlags "Ld Linker flags"--    getFlags key = case M.lookup key ghcInfo of-                   Nothing -> []-                   Just flags ->-                       case reads flags of-                       [(args, "")] -> args-                       _ -> [] -- XXX Should should be an error really--    configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-    configureGcc v gccProg = do-      gccProg' <- configureGcc' v gccProg-      return gccProg' {-        programDefaultArgs = programDefaultArgs gccProg'-                             ++ ccFlags ++ gccLinkerFlags-      }--    configureGcc' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-    configureGcc'-      | isWindows = \_ gccProg -> case programLocation gccProg of-          -- if it's found on system then it means we're using the result-          -- of programFindLocation above rather than a user-supplied path-          -- Pre GHC 6.12, that meant we should add these flags to tell-          -- ghc's gcc where it lives and thus where gcc can find its-          -- various files:-          FoundOnSystem {}-           | ghcVersion < Version [6,11] [] ->-               return gccProg { programDefaultArgs = ["-B" ++ libDir,-                                                      "-I" ++ includeDir] }-          _ -> return gccProg-      | otherwise = \_ gccProg -> return gccProg--    configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-    configureLd v ldProg = do-      ldProg' <- configureLd' v ldProg-      return ldProg' {-        programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags-      }--    -- we need to find out if ld supports the -x flag-    configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-    configureLd' verbosity ldProg = do-      tempDir <- getTemporaryDirectory-      ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->-             withTempFile tempDir ".o" $ \testofile testohnd -> do-               hPutStrLn testchnd "int foo() { return 0; }"-               hClose testchnd; hClose testohnd-               rawSystemProgram verbosity ghcProg ["-c", testcfile,-                                                   "-o", testofile]-               withTempFile tempDir ".o" $ \testofile' testohnd' ->-                 do-                   hClose testohnd'-                   _ <- rawSystemProgramStdout verbosity ldProg-                     ["-x", "-r", testofile, "-o", testofile']-                   return True-                 `catchIO`   (\_ -> return False)-                 `catchExit` (\_ -> return False)-      if ldx-        then return ldProg { programDefaultArgs = ["-x"] }-        else return ldProg--getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)]-getLanguages _ ghcProg-  -- TODO: should be using --supported-languages rather than hard coding-  | ghcVersion >= Version [7] [] = return [(Haskell98,   "-XHaskell98")-                                          ,(Haskell2010, "-XHaskell2010")]-  | otherwise                    = return [(Haskell98,   "")]-  where-    Just ghcVersion = programVersion ghcProg--getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]-getGhcInfo verbosity ghcProg =-    case programVersion ghcProg of-    Just ghcVersion-     | ghcVersion >= Version [6,7] [] ->-        do xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)-                 ["--info"]-           case reads xs of-               [(i, ss)]-                | all isSpace ss ->-                   return i-               _ ->-                   die "Can't parse --info output of GHC"-    _ ->-        return []--getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)]-getExtensions verbosity ghcProg-  | ghcVersion >= Version [6,7] [] = do--    str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)-              ["--supported-languages"]-    let extStrs = if ghcVersion >= Version [7] []-                  then lines str-                  else -- Older GHCs only gave us either Foo or NoFoo,-                       -- so we have to work out the other one ourselves-                       [ extStr''-                       | extStr <- lines str-                       , let extStr' = case extStr of-                                       'N' : 'o' : xs -> xs-                                       _              -> "No" ++ extStr-                       , extStr'' <- [extStr, extStr']-                       ]-    let extensions0 = [ (ext, "-X" ++ display ext)-                      | Just ext <- map simpleParse extStrs ]-        extensions1 = if ghcVersion >= Version [6,8]  [] &&-                         ghcVersion <  Version [6,10] []-                      then -- ghc-6.8 introduced RecordPuns however it-                           -- should have been NamedFieldPuns. We now-                           -- encourage packages to use NamedFieldPuns-                           -- so for compatability we fake support for-                           -- it in ghc-6.8 by making it an alias for-                           -- the old RecordPuns extension.-                           (EnableExtension  NamedFieldPuns, "-XRecordPuns") :-                           (DisableExtension NamedFieldPuns, "-XNoRecordPuns") :-                           extensions0-                      else extensions0-        extensions2 = if ghcVersion <  Version [7,1] []-                      then -- ghc-7.2 split NondecreasingIndentation off-                           -- into a proper extension. Before that it-                           -- was always on.-                           (EnableExtension  NondecreasingIndentation, "") :-                           (DisableExtension NondecreasingIndentation, "") :-                           extensions1-                      else extensions1-    return extensions2--  | otherwise = return oldLanguageExtensions--  where-    Just ghcVersion = programVersion ghcProg---- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags-oldLanguageExtensions :: [(Extension, Flag)]-oldLanguageExtensions =-    let doFlag (f, (enable, disable)) = [(EnableExtension  f, enable),-                                         (DisableExtension f, disable)]-        fglasgowExts = ("-fglasgow-exts",-                        "") -- This is wrong, but we don't want to turn-                            -- all the extensions off when asked to just-                            -- turn one off-        fFlag flag = ("-f" ++ flag, "-fno-" ++ flag)-    in concatMap doFlag-    [(OverlappingInstances       , fFlag "allow-overlapping-instances")-    ,(TypeSynonymInstances       , fglasgowExts)-    ,(TemplateHaskell            , fFlag "th")-    ,(ForeignFunctionInterface   , fFlag "ffi")-    ,(MonomorphismRestriction    , fFlag "monomorphism-restriction")-    ,(MonoPatBinds               , fFlag "mono-pat-binds")-    ,(UndecidableInstances       , fFlag "allow-undecidable-instances")-    ,(IncoherentInstances        , fFlag "allow-incoherent-instances")-    ,(Arrows                     , fFlag "arrows")-    ,(Generics                   , fFlag "generics")-    ,(ImplicitPrelude            , fFlag "implicit-prelude")-    ,(ImplicitParams             , fFlag "implicit-params")-    ,(CPP                        , ("-cpp", ""{- Wrong -}))-    ,(BangPatterns               , fFlag "bang-patterns")-    ,(KindSignatures             , fglasgowExts)-    ,(RecursiveDo                , fglasgowExts)-    ,(ParallelListComp           , fglasgowExts)-    ,(MultiParamTypeClasses      , fglasgowExts)-    ,(FunctionalDependencies     , fglasgowExts)-    ,(Rank2Types                 , fglasgowExts)-    ,(RankNTypes                 , fglasgowExts)-    ,(PolymorphicComponents      , fglasgowExts)-    ,(ExistentialQuantification  , fglasgowExts)-    ,(ScopedTypeVariables        , fFlag "scoped-type-variables")-    ,(FlexibleContexts           , fglasgowExts)-    ,(FlexibleInstances          , fglasgowExts)-    ,(EmptyDataDecls             , fglasgowExts)-    ,(PatternGuards              , fglasgowExts)-    ,(GeneralizedNewtypeDeriving , fglasgowExts)-    ,(MagicHash                  , fglasgowExts)-    ,(UnicodeSyntax              , fglasgowExts)-    ,(PatternSignatures          , fglasgowExts)-    ,(UnliftedFFITypes           , fglasgowExts)-    ,(LiberalTypeSynonyms        , fglasgowExts)-    ,(TypeOperators              , fglasgowExts)-    ,(GADTs                      , fglasgowExts)-    ,(RelaxedPolyRec             , fglasgowExts)-    ,(ExtendedDefaultRules       , fFlag "extended-default-rules")-    ,(UnboxedTuples              , fglasgowExts)-    ,(DeriveDataTypeable         , fglasgowExts)-    ,(ConstrainedClassMethods    , fglasgowExts)-    ]--- | Given a single package DB, return all installed packages.-getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration-                        -> IO PackageIndex-getPackageDBContents verbosity packagedb conf = do-  pkgss <- getInstalledPackages' verbosity [packagedb] conf-  toPackageIndex verbosity pkgss conf---- | Given a package DB stack, return all installed packages.-getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration-                     -> IO PackageIndex-getInstalledPackages verbosity packagedbs conf = do-  checkPackageDbEnvVar-  checkPackageDbStack packagedbs-  pkgss <- getInstalledPackages' verbosity packagedbs conf-  index <- toPackageIndex verbosity pkgss conf-  return $! hackRtsPackage index--  where-    hackRtsPackage index =-      case PackageIndex.lookupPackageName index (PackageName "rts") of-        [(_,[rts])]-           -> PackageIndex.insert (removeMingwIncludeDir rts) index-        _  -> index -- No (or multiple) ghc rts package is registered!!-                    -- Feh, whatever, the ghc testsuite does some crazy stuff.---- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a--- @PackageIndex@. Helper function used by 'getPackageDBContents' and--- 'getInstalledPackages'.-toPackageIndex :: Verbosity-               -> [(PackageDB, [InstalledPackageInfo])]-               -> ProgramConfiguration-               -> IO PackageIndex-toPackageIndex verbosity pkgss conf = 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.-  topDir <- ghcLibDir' verbosity ghcProg-  let indices = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)-                | (_, pkgs) <- pkgss ]-  return $! (mconcat indices)--  where-    Just ghcProg = lookupProgram ghcProgram conf--ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath-ghcLibDir verbosity lbi =-    (reverse . dropWhile isSpace . reverse) `fmap`-     rawSystemProgramStdoutConf verbosity ghcProgram-     (withPrograms lbi) ["--print-libdir"]--ghcLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath-ghcLibDir' verbosity ghcProg =-    (reverse . dropWhile isSpace . reverse) `fmap`-     rawSystemProgramStdout verbosity ghcProg ["--print-libdir"]---- Cabal does not use the environment variable GHC_PACKAGE_PATH; let users--- know that this is the case. See ticket #335. Simply ignoring it is not a--- good idea, since then ghc and cabal are looking at different sets of--- package dbs and chaos is likely to ensue.-checkPackageDbEnvVar :: IO ()-checkPackageDbEnvVar = do-    hasGPP <- (getEnv "GHC_PACKAGE_PATH" >> return True)-              `catchIO` (\_ -> return False)-    when hasGPP $-      die $ "Use of GHC's environment variable GHC_PACKAGE_PATH is "-         ++ "incompatible with Cabal. Use the flag --package-db to specify a "-         ++ "package database (it can be used multiple times)."--checkPackageDbStack :: PackageDBStack -> IO ()-checkPackageDbStack (GlobalPackageDB:rest)-  | GlobalPackageDB `notElem` rest = return ()-checkPackageDbStack rest-  | GlobalPackageDB `notElem` rest =-  die $ "With current ghc versions the global package db is always used "-     ++ "and must be listed first. This ghc limitation may be lifted in "-     ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977"-checkPackageDbStack _ =-  die $ "If the global package db is specified, it must be "-     ++ "specified first and cannot be specified multiple times"---- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This--- breaks when you want to use a different gcc, so we need to filter--- it out.-removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo-removeMingwIncludeDir pkg =-    let ids = InstalledPackageInfo.includeDirs pkg-        ids' = filter (not . ("mingw" `isSuffixOf`)) ids-    in pkg { InstalledPackageInfo.includeDirs = ids' }---- | Get the packages from specific PackageDBs, not cumulative.----getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration-                     -> IO [(PackageDB, [InstalledPackageInfo])]-getInstalledPackages' verbosity packagedbs conf-  | ghcVersion >= Version [6,9] [] =-  sequence-    [ do pkgs <- HcPkg.dump verbosity ghcPkgProg packagedb-         return (packagedb, pkgs)-    | packagedb <- packagedbs ]--  where-    Just ghcPkgProg = lookupProgram ghcPkgProgram conf-    Just ghcProg    = lookupProgram ghcProgram conf-    Just ghcVersion = programVersion ghcProg--getInstalledPackages' verbosity packagedbs conf = do-    str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf ["list"]-    let pkgFiles = [ init line | line <- lines str, last line == ':' ]-        dbFile packagedb = case (packagedb, pkgFiles) of-          (GlobalPackageDB, global:_)      -> return $ Just global-          (UserPackageDB,  _global:user:_) -> return $ Just user-          (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-                  pkgs <- readPackages file content-                  return (db, pkgs)-             | (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] []-      = \file content -> case reads content of-          [(pkgs, _)] -> return (map IPI642.toCurrent pkgs)-          _           -> failToRead file-      | otherwise-      = \file content -> case reads content of-          [(pkgs, _)] -> return (map IPI641.toCurrent pkgs)-          _           -> failToRead file-    Just ghcProg = lookupProgram ghcProgram conf-    Just ghcVersion = programVersion ghcProg-    failToRead file = die $ "cannot read ghc package database " ++ file--substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo-substTopDir topDir ipo- = ipo {-       InstalledPackageInfo.importDirs-           = map f (InstalledPackageInfo.importDirs ipo),-       InstalledPackageInfo.libraryDirs-           = map f (InstalledPackageInfo.libraryDirs ipo),-       InstalledPackageInfo.includeDirs-           = map f (InstalledPackageInfo.includeDirs ipo),-       InstalledPackageInfo.frameworkDirs-           = map f (InstalledPackageInfo.frameworkDirs ipo),-       InstalledPackageInfo.haddockInterfaces-           = map f (InstalledPackageInfo.haddockInterfaces ipo),-       InstalledPackageInfo.haddockHTMLs-           = map f (InstalledPackageInfo.haddockHTMLs ipo)-   }-    where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest-          f x = x---- -------------------------------------------------------------------------------- Building---- | Build a library with GHC.----buildLib, replLib :: Verbosity          -> Cabal.Flag (Maybe Int)-                  -> PackageDescription -> LocalBuildInfo-                  -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib = buildOrReplLib False-replLib  = buildOrReplLib True--buildOrReplLib :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)-               -> PackageDescription -> LocalBuildInfo-               -> Library            -> ComponentLocalBuildInfo -> IO ()-buildOrReplLib forRepl verbosity numJobsFlag pkg_descr lbi lib clbi = do-  libName <- case componentLibraries clbi of-             [libName] -> return libName-             [] -> die "No library name found when building library"-             _  -> die "Multiple library names found when building library"--  let libTargetDir = buildDir lbi-      numJobs = fromMaybe 1 $ fromFlagOrDefault Nothing numJobsFlag-      pkgid = packageId pkg_descr-      whenVanillaLib forceVanilla =-        when (not forRepl && (forceVanilla || withVanillaLib lbi))-      whenProfLib = when (not forRepl && withProfLib lbi)-      whenSharedLib forceShared =-        when (not forRepl &&  (forceShared || withSharedLib lbi))-      whenGHCiLib = when (not forRepl && withGHCiLib lbi && withVanillaLib lbi)-      ifReplLib = when forRepl-      comp = compiler lbi-      ghcVersion = compilerVersion comp--  (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)-  let runGhcProg = runGHC verbosity ghcProg comp--  libBi <- hackThreadedFlag verbosity-             comp (withProfLib lbi) (libBuildInfo lib)--  let isGhcDynamic        = ghcDynamic comp-      dynamicTooSupported = ghcSupportsDynamicToo comp-      doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi-      forceVanillaLib = doingTH && not isGhcDynamic-      forceSharedLib  = doingTH &&     isGhcDynamic-      -- TH always needs default libs, even when building for profiling--  createDirectoryIfMissingVerbose verbosity True libTargetDir-  -- TODO: do we need to put hs-boot files into place for mutually recursive-  -- modules?-  let cObjs       = map (`replaceExtension` objExtension) (cSources libBi)-      baseOpts    = componentGhcOptions verbosity lbi libBi clbi libTargetDir-      vanillaOpts = baseOpts `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeMake,-                      ghcOptNumJobs      = toFlag numJobs,-                      ghcOptPackageName  = toFlag pkgid,-                      ghcOptInputModules = libModules lib-                    }--      profOpts    = vanillaOpts `mappend` mempty {-                      ghcOptProfilingMode = toFlag True,-                      ghcOptHiSuffix      = toFlag "p_hi",-                      ghcOptObjSuffix     = toFlag "p_o",-                      ghcOptExtra         = ghcProfOptions libBi-                    }--      sharedOpts  = vanillaOpts `mappend` mempty {-                      ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                      ghcOptFPic        = toFlag True,-                      ghcOptHiSuffix    = toFlag "dyn_hi",-                      ghcOptObjSuffix   = toFlag "dyn_o",-                      ghcOptExtra       = ghcSharedOptions libBi-                    }-      linkerOpts = mempty {-                      ghcOptLinkOptions    = PD.ldOptions libBi,-                      ghcOptLinkLibs       = extraLibs libBi,-                      ghcOptLinkLibPath    = extraLibDirs libBi,-                      ghcOptLinkFrameworks = PD.frameworks libBi,-                      ghcOptInputFiles     = [libTargetDir </> x | x <- cObjs]-                   }-      replOpts    = vanillaOpts {-                      ghcOptExtra        = filterGhciFlags-                                           (ghcOptExtra vanillaOpts),-                      ghcOptNumJobs      = mempty-                    }-                    `mappend` linkerOpts-                    `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeInteractive,-                      ghcOptOptimisation = toFlag GhcNoOptimisation-                    }--      vanillaSharedOpts = vanillaOpts `mappend` mempty {-                      ghcOptDynLinkMode  = toFlag GhcStaticAndDynamic,-                      ghcOptDynHiSuffix  = toFlag "dyn_hi",-                      ghcOptDynObjSuffix = toFlag "dyn_o"-                    }--  unless (null (libModules lib)) $-    do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts)-           shared  = whenSharedLib  forceSharedLib  (runGhcProg sharedOpts)-           useDynToo = dynamicTooSupported &&-                       (forceVanillaLib || withVanillaLib lbi) &&-                       (forceSharedLib  || withSharedLib  lbi) &&-                       null (ghcSharedOptions libBi)-       if useDynToo-           then runGhcProg vanillaSharedOpts-           else if isGhcDynamic then do shared;  vanilla-                                else do vanilla; shared-       whenProfLib (runGhcProg profOpts)--  -- build any C sources-  unless (null (cSources libBi)) $ do-     info verbosity "Building C Sources..."-     sequence_-       [ do let vanillaCcOpts = (componentCcGhcOptions verbosity lbi-                                    libBi clbi libTargetDir filename)-                profCcOpts    = vanillaCcOpts `mappend` mempty {-                                  ghcOptProfilingMode = toFlag True,-                                  ghcOptObjSuffix     = toFlag "p_o"-                                }-                sharedCcOpts  = vanillaCcOpts `mappend` mempty {-                                  ghcOptFPic        = toFlag True,-                                  ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                                  ghcOptObjSuffix   = toFlag "dyn_o"-                                }-                odir          = fromFlag (ghcOptObjDir vanillaCcOpts)-            createDirectoryIfMissingVerbose verbosity True odir-            runGhcProg vanillaCcOpts-            whenSharedLib forceSharedLib (runGhcProg sharedCcOpts)-            whenProfLib (runGhcProg profCcOpts)-       | filename <- cSources libBi]--  -- 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)) $-     ifReplLib (runGhcProg replOpts)---  -- link:-  info verbosity "Linking..."-  let cProfObjs   = map (`replaceExtension` ("p_" ++ objExtension))-                    (cSources libBi)-      cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))-                    (cSources libBi)-      cid = compilerId (compiler lbi)-      vanillaLibFilePath = libTargetDir </> mkLibName           libName-      profileLibFilePath = libTargetDir </> mkProfLibName       libName-      sharedLibFilePath  = libTargetDir </> mkSharedLibName cid libName-      ghciLibFilePath    = libTargetDir </> mkGHCiLibName       libName-      libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest-      sharedLibInstallPath = libInstallPath </> mkSharedLibName cid libName--  stubObjs <- fmap catMaybes $ sequence-    [ findFileWithExtension [objExtension] [libTargetDir]-        (ModuleName.toFilePath x ++"_stub")-    | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files-    , x <- libModules lib ]-  stubProfObjs <- fmap catMaybes $ sequence-    [ 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 <- fmap catMaybes $ sequence-    [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]-        (ModuleName.toFilePath x ++"_stub")-    | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files-    , x <- libModules lib ]--  hObjs     <- getHaskellObjects lib lbi-                    libTargetDir objExtension True-  hProfObjs <--    if (withProfLib lbi)-            then getHaskellObjects lib lbi-                    libTargetDir ("p_" ++ objExtension) True-            else return []-  hSharedObjs <--    if (withSharedLib lbi)-            then getHaskellObjects lib lbi-                    libTargetDir ("dyn_" ++ objExtension) False-            else return []--  unless (null hObjs && null cObjs && null stubObjs) $ do--    let staticObjectFiles =-               hObjs-            ++ map (libTargetDir </>) cObjs-            ++ stubObjs-        profObjectFiles =-               hProfObjs-            ++ map (libTargetDir </>) cProfObjs-            ++ stubProfObjs-        ghciObjFiles =-               hObjs-            ++ map (libTargetDir </>) cObjs-            ++ stubObjs-        dynamicObjectFiles =-               hSharedObjs-            ++ map (libTargetDir </>) cSharedObjs-            ++ stubSharedObjs-        -- After the relocation lib is created we invoke ghc -shared-        -- with the dependencies spelled out as -package arguments-        -- and ghc invokes the linker with the proper library paths-        ghcSharedLinkArgs =-            mempty {-              ghcOptShared             = toFlag True,-              ghcOptDynLinkMode        = toFlag GhcDynamicOnly,-              ghcOptInputFiles         = dynamicObjectFiles,-              ghcOptOutputFile         = toFlag sharedLibFilePath,-              -- For dynamic libs, Mac OS/X needs to know the install location-              -- at build time.-              ghcOptDylibName          = if buildOS == OSX-                                          then toFlag sharedLibInstallPath-                                          else mempty,-              ghcOptPackageName        = toFlag pkgid,-              ghcOptNoAutoLinkPackages = toFlag True,-              ghcOptPackageDBs         = withPackageDB lbi,-              ghcOptPackages           = componentPackageDeps clbi,-              ghcOptLinkLibs           = extraLibs libBi,-              ghcOptLinkLibPath        = extraLibDirs libBi-            }--    whenVanillaLib False $ do-      Ar.createArLibArchive verbosity (withPrograms lbi) (stripLibs lbi)-        vanillaLibFilePath staticObjectFiles--    whenProfLib $ do-      Ar.createArLibArchive verbosity (withPrograms lbi) (stripLibs lbi)-        profileLibFilePath profObjectFiles--    whenGHCiLib $ do-      (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)-      Ld.combineObjectFiles verbosity ldProg-        ghciLibFilePath ghciObjFiles--    whenSharedLib False $-      runGhcProg ghcSharedLinkArgs---- | Start a REPL without loading any source files.-startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler-                 -> PackageDBStack -> IO ()-startInterpreter verbosity conf comp packageDBs = do-  let replOpts = mempty {-        ghcOptMode       = toFlag GhcModeInteractive,-        ghcOptPackageDBs = packageDBs-        }-  checkPackageDbStack packageDBs-  (ghcProg, _) <- requireProgram verbosity ghcProgram conf-  runGHC verbosity ghcProg comp replOpts---- | Build an executable with GHC.----buildExe, replExe :: Verbosity          -> Cabal.Flag (Maybe Int)-                  -> PackageDescription -> LocalBuildInfo-                  -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe = buildOrReplExe False-replExe  = buildOrReplExe True--buildOrReplExe :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)-               -> PackageDescription -> LocalBuildInfo-               -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildOrReplExe forRepl verbosity numJobsFlag _pkg_descr lbi-  exe@Executable { exeName = exeName', modulePath = modPath } clbi = do--  (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)-  let comp       = compiler lbi-      numJobs    = fromMaybe 1 $-                   fromFlagOrDefault Nothing numJobsFlag-      runGhcProg = runGHC verbosity ghcProg comp--  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 "")--  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-  -- modules?  FIX: what about exeName.hi-boot?--  -- build executables--  srcMainFile         <- findFile (exeDir : hsSourceDirs exeBi) modPath-  let isGhcDynamic        = ghcDynamic comp-      dynamicTooSupported = ghcSupportsDynamicToo 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)-                    `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeMake,-                      ghcOptInputFiles   =-                        [ srcMainFile | isHaskellMain],-                      ghcOptInputModules =-                        [ m | not isHaskellMain, m <- exeModules exe]-                    }-      staticOpts = baseOpts `mappend` mempty {-                      ghcOptDynLinkMode    = toFlag GhcStaticOnly-                   }-      profOpts   = baseOpts `mappend` mempty {-                      ghcOptProfilingMode  = toFlag True,-                      ghcOptHiSuffix       = toFlag "p_hi",-                      ghcOptObjSuffix      = toFlag "p_o",-                      ghcOptExtra          = ghcProfOptions exeBi-                    }-      dynOpts    = baseOpts `mappend` mempty {-                      ghcOptDynLinkMode    = toFlag GhcDynamicOnly,-                      ghcOptHiSuffix       = toFlag "dyn_hi",-                      ghcOptObjSuffix      = toFlag "dyn_o",-                      ghcOptExtra          = ghcSharedOptions exeBi-                    }-      dynTooOpts = staticOpts `mappend` mempty {-                      ghcOptDynLinkMode    = toFlag GhcStaticAndDynamic,-                      ghcOptDynHiSuffix    = toFlag "dyn_hi",-                      ghcOptDynObjSuffix   = toFlag "dyn_o"-                    }-      linkerOpts = mempty {-                      ghcOptLinkOptions    = PD.ldOptions exeBi,-                      ghcOptLinkLibs       = extraLibs exeBi,-                      ghcOptLinkLibPath    = extraLibDirs exeBi,-                      ghcOptLinkFrameworks = PD.frameworks exeBi,-                      ghcOptInputFiles     = [exeDir </> x | x <- cObjs]-                   }-      replOpts   = baseOpts {-                      ghcOptExtra          = filterGhciFlags-                                             (ghcOptExtra baseOpts)-                   }-                   -- For a normal compile we do separate invocations of ghc for-                   -- compiling as for linking. But for repl we have to do just-                   -- the one invocation, so that one has to include all the-                   -- linker stuff too, like -l flags and any .o files from C-                   -- files etc.-                   `mappend` linkerOpts-                   `mappend` mempty {-                      ghcOptMode           = toFlag GhcModeInteractive,-                      ghcOptOptimisation   = toFlag GhcNoOptimisation-                   }-      commonOpts  | withProfExe lbi = profOpts-                  | withDynExe  lbi = dynOpts-                  | otherwise       = staticOpts-      compileOpts | useDynToo = dynTooOpts-                  | otherwise = commonOpts-      withStaticExe = (not $ withProfExe lbi) && (not $ withDynExe lbi)--      -- 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-      -- -prof/-dynamic. This is because the code that TH needs to run at-      -- compile time needs to be the vanilla ABI so it can be loaded up and run-      -- 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-      -- Should we use -dynamic-too instead of compilng twice?-      useDynToo = dynamicTooSupported && isGhcDynamic-                  && doingTH && withStaticExe && null (ghcSharedOptions exeBi)-      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)-                 }--  -- Build static/dynamic object files for TH, if needed.-  when compileForTH $-    runGhcProg compileTHOpts { ghcOptNoLink  = toFlag True-                             , ghcOptNumJobs = toFlag numJobs }--  unless forRepl $-    runGhcProg compileOpts { ghcOptNoLink  = toFlag True-                           , ghcOptNumJobs = toFlag numJobs }--  -- build any C sources-  unless (null cSrcs) $ do-   info verbosity "Building C Sources..."-   sequence_-     [ do let opts = (componentCcGhcOptions verbosity lbi exeBi clbi-                         exeDir filename) `mappend` mempty {-                       ghcOptDynLinkMode   = toFlag (if withDynExe lbi-                                                       then GhcDynamicOnly-                                                       else GhcStaticOnly),-                       ghcOptProfilingMode = toFlag (withProfExe lbi)-                     }-              odir = fromFlag (ghcOptObjDir opts)-          createDirectoryIfMissingVerbose verbosity True odir-          runGhcProg opts-     | filename <- cSrcs ]--  -- 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--  -- link:-  unless forRepl $ do-    info verbosity "Linking..."-    runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }----- | Filter the "-threaded" flag when profiling as it does not---   work with ghc-6.8 and older.-hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo-hackThreadedFlag verbosity comp prof bi-  | not mustFilterThreaded = return bi-  | otherwise              = do-    warn verbosity $ "The ghc flag '-threaded' is not compatible with "-                  ++ "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] []-                      && "-threaded" `elem` hcOptions GHC bi-    filterHcOptions p hcoptss =-      [ (hc, if hc == GHC then filter p opts else opts)-      | (hc, opts) <- hcoptss ]---- | Strip out flags that are not supported in ghci-filterGhciFlags :: [String] -> [String]-filterGhciFlags = filter supported-  where-    supported ('-':'O':_) = False-    supported "-debug"    = False-    supported "-threaded" = False-    supported "-ticky"    = False-    supported "-eventlog" = False-    supported "-prof"     = False-    supported "-unreg"    = False-    supported _           = True---- 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-  | splitObjs lbi && allow_split_objs = do-        let splitSuffix = if compilerVersion (compiler lbi) <-                             Version [6, 11] []-                          then "_split"-                          else "_" ++ wanted_obj_ext ++ "_split"-            dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)-                   | x <- libModules lib ]-        objss <- mapM getDirectoryContents dirs-        let objs = [ dir </> obj-                   | (objs',dir) <- zip objss dirs, obj <- objs',-                     let obj_ext = takeExtension obj,-                     '.':wanted_obj_ext == obj_ext ]-        return objs-  | otherwise  =-        return [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext-               | x <- libModules lib ]---- | Extracts a String representing a hash of the ABI of a built--- library.  It can fail if the library has not yet been built.----libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo-           -> Library -> ComponentLocalBuildInfo -> IO String-libAbiHash verbosity pkg_descr lbi lib clbi = do-  libBi <- hackThreadedFlag verbosity-             (compiler lbi) (withProfLib lbi) (libBuildInfo lib)-  let-      comp        = compiler lbi-      vanillaArgs =-        (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))-        `mappend` mempty {-          ghcOptMode         = toFlag GhcModeAbiHash,-          ghcOptPackageName  = toFlag (packageId pkg_descr),-          ghcOptInputModules = exposedModules lib-        }-      sharedArgs = vanillaArgs `mappend` mempty {-                       ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                       ghcOptFPic        = toFlag True,-                       ghcOptHiSuffix    = toFlag "dyn_hi",-                       ghcOptObjSuffix   = toFlag "dyn_o",-                       ghcOptExtra       = ghcSharedOptions libBi-                   }-      profArgs = vanillaArgs `mappend` mempty {-                     ghcOptProfilingMode = toFlag True,-                     ghcOptHiSuffix      = toFlag "p_hi",-                     ghcOptObjSuffix     = toFlag "p_o",-                     ghcOptExtra         = ghcProfOptions libBi-                 }-      ghcArgs = if withVanillaLib lbi then vanillaArgs-           else if withSharedLib  lbi then sharedArgs-           else if withProfLib    lbi then profArgs-           else error "libAbiHash: Can't find an enabled library way"-  ---  (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)-  getProgramInvocationOutput verbosity (ghcInvocation ghcProg comp ghcArgs)---componentGhcOptions :: Verbosity -> LocalBuildInfo-                    -> BuildInfo -> ComponentLocalBuildInfo -> FilePath-                    -> GhcOptions-componentGhcOptions verbosity lbi bi clbi odir =-    mempty {-      ghcOptVerbosity       = toFlag verbosity,-      ghcOptHideAllPackages = toFlag True,-      ghcOptCabal           = toFlag True,-      ghcOptPackageDBs      = withPackageDB lbi,-      ghcOptPackages        = componentPackageDeps clbi,-      ghcOptSplitObjs       = toFlag (splitObjs lbi),-      ghcOptSourcePathClear = toFlag True,-      ghcOptSourcePath      = [odir] ++ nub (hsSourceDirs bi)-                                    ++ [autogenModulesDir lbi],-      ghcOptCppIncludePath  = [autogenModulesDir lbi, odir]-                                    ++ PD.includeDirs bi,-      ghcOptCppOptions      = cppOptions bi,-      ghcOptCppIncludes     = [autogenModulesDir lbi </> cppHeaderName],-      ghcOptFfiIncludes     = PD.includes bi,-      ghcOptObjDir          = toFlag odir,-      ghcOptHiDir           = toFlag odir,-      ghcOptStubDir         = toFlag odir,-      ghcOptOutputDir       = toFlag odir,-      ghcOptOptimisation    = toGhcOptimisation (withOptimization lbi),-      ghcOptExtra           = hcOptions GHC bi,-      ghcOptLanguage        = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),-      -- Unsupported extensions have already been checked by configure-      ghcOptExtensions      = usedExtensions bi,-      ghcOptExtensionMap    = compilerExtensions (compiler lbi)-    }-  where-    toGhcOptimisation NoOptimisation      = mempty --TODO perhaps override?-    toGhcOptimisation NormalOptimisation  = toFlag GhcNormalOptimisation-    toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation---componentCcGhcOptions :: Verbosity -> LocalBuildInfo-                      -> BuildInfo -> ComponentLocalBuildInfo-                      -> FilePath -> FilePath-                      -> GhcOptions-componentCcGhcOptions verbosity lbi bi clbi pref filename =-    mempty {-      ghcOptVerbosity      = toFlag verbosity,-      ghcOptMode           = toFlag GhcModeCompile,-      ghcOptInputFiles     = [filename],--      ghcOptCppIncludePath = [autogenModulesDir lbi, odir]-                                   ++ PD.includeDirs bi,-      ghcOptPackageDBs     = withPackageDB lbi,-      ghcOptPackages       = componentPackageDeps clbi,-      ghcOptCcOptions      = PD.ccOptions bi-                             ++ case withOptimization lbi of-                                  NoOptimisation -> []-                                  _              -> ["-O2"],-      ghcOptObjDir         = toFlag odir-    }-  where-    odir | compilerVersion (compiler lbi) >= Version [6,4,1] []  = pref-         | otherwise = pref </> takeDirectory filename-         -- ghc 6.4.0 had a bug in -odir handling for C compilations.--mkGHCiLibName :: LibraryName -> String-mkGHCiLibName (LibraryName lib) = lib <.> "o"---- -------------------------------------------------------------------------------- Installing---- |Install executables for GHC.-installExe :: Verbosity-           -> LocalBuildInfo-           -> InstallDirs FilePath -- ^Where to copy the files to-           -> FilePath  -- ^Build location-           -> (FilePath, FilePath)  -- ^Executable (prefix,suffix)-           -> PackageDescription-           -> Executable-           -> IO ()-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-      installBinary dest = do-          installExecutableFile verbosity-            (buildPref </> exeName exe </> exeFileName)-            (dest <.> exeExtension)-          when (stripExes lbi) $-            Strip.stripExe verbosity (withPrograms lbi) (dest <.> exeExtension)-  installBinary (binDir </> fixedExeBaseName)---- |Install for ghc, .hi, .a and, if --with-ghci given, .o-installLib    :: Verbosity-              -> LocalBuildInfo-              -> FilePath  -- ^install location-              -> FilePath  -- ^install location for dynamic librarys-              -> FilePath  -- ^Build location-              -> PackageDescription-              -> Library-              -> ComponentLocalBuildInfo-              -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do-  -- copy .hi files over:-  whenVanilla $ copyModuleFiles "hi"-  whenProf    $ copyModuleFiles "p_hi"-  whenShared  $ copyModuleFiles "dyn_hi"--  -- copy the built library files over:-  whenVanilla $ mapM_ (installOrdinary builtDir targetDir)       vanillaLibNames-  whenProf    $ mapM_ (installOrdinary builtDir targetDir)       profileLibNames-  whenGHCi    $ mapM_ (installOrdinary builtDir targetDir)       ghciLibNames-  whenShared  $ mapM_ (installShared   builtDir dynlibTargetDir) sharedLibNames--  where-    install isShared srcDir dstDir name = do-      let src = srcDir </> name-          dst = dstDir </> name-      createDirectoryIfMissingVerbose verbosity True dstDir-      if isShared-        then do when (stripLibs lbi) $-                  Strip.stripLib verbosity (withPrograms lbi) src-                installExecutableFile verbosity src dst-        else installOrdinaryFile   verbosity src dst--    installOrdinary = install False-    installShared   = install True--    copyModuleFiles ext =-      findModuleFiles [builtDir] [ext] (libModules lib)-      >>= installOrdinaryFiles verbosity targetDir--    cid = compilerId (compiler lbi)-    libNames = componentLibraries clbi-    vanillaLibNames = map mkLibName             libNames-    profileLibNames = map mkProfLibName         libNames-    ghciLibNames    = map mkGHCiLibName         libNames-    sharedLibNames  = map (mkSharedLibName cid) libNames--    hasLib    = not $ null (libModules lib)-                   && null (cSources (libBuildInfo lib))-    whenVanilla = when (hasLib && withVanillaLib lbi)-    whenProf    = when (hasLib && withProfLib    lbi)-    whenGHCi    = when (hasLib && withGHCiLib    lbi)-    whenShared  = when (hasLib && withSharedLib  lbi)---- -------------------------------------------------------------------------------- Registering---- | Create an empty package DB at the specified location.-initPackageDB :: Verbosity -> ProgramConfiguration -> FilePath -> IO ()-initPackageDB verbosity conf dbPath = HcPkg.init verbosity ghcPkgProg dbPath-  where-    Just ghcPkgProg = lookupProgram ghcPkgProgram conf---- | Run 'ghc-pkg' using a given package DB stack, directly forwarding the--- provided command-line arguments to it.-invokeHcPkg :: Verbosity -> ProgramConfiguration -> PackageDBStack -> [String]-               -> IO ()-invokeHcPkg verbosity conf dbStack extraArgs =-    HcPkg.invoke verbosity ghcPkgProg dbStack extraArgs-  where-    Just ghcPkgProg = lookupProgram ghcPkgProgram conf--registerPackage-  :: Verbosity-  -> InstalledPackageInfo-  -> PackageDescription-  -> LocalBuildInfo-  -> Bool-  -> PackageDBStack-  -> IO ()-registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do-  let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)-  HcPkg.reregister verbosity ghcPkg packageDbs (Right installedPkgInfo)---- -------------------------------------------------------------------------------- Utils--ghcLookupProperty :: String -> Compiler -> Bool-ghcLookupProperty prop comp =-  case M.lookup prop (compilerProperties comp) of-    Just "YES" -> True-    _          -> False--ghcDynamic :: Compiler -> Bool-ghcDynamic = ghcLookupProperty "GHC Dynamic"--ghcSupportsDynamicToo :: Compiler -> Bool-ghcSupportsDynamicToo = ghcLookupProperty "Support dynamic-too"+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.GHC+-- Copyright   :  Isaac Jones 2003-2007+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This is a fairly large module. It contains most of the GHC-specific code for+-- configuring, building and installing packages. It also exports a function+-- for finding out what packages are already installed. Configuring involves+-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions+-- this version of ghc supports and returning a 'Compiler' value.+--+-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out+-- what packages are installed.+--+-- Building is somewhat complex as there is quite a bit of information to take+-- into account. We have to build libs and programs, possibly for profiling and+-- shared libs. We have to support building libraries that will be usable by+-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files+-- using ghc. Linking, especially for @split-objs@ is remarkably complex,+-- partly because there tend to be 1,000's of @.o@ files and this can often be+-- more than we can pass to the @ld@ or @ar@ programs in one go.+--+-- Installing for libs and exes involves finding the right files and copying+-- them to the right places. One of the more tricky things about this module is+-- remembering the layout of files in the build directory (which is not+-- explicitly documented) and thus what search dirs are used for various kinds+-- of files.++module Distribution.Simple.GHC (+        getGhcInfo,+        configure, getInstalledPackages, getPackageDBContents,+        buildLib, buildExe,+        replLib, replExe,+        startInterpreter,+        installLib, installExe,+        libAbiHash,+        hcPkgInfo,+        registerPackage,+        componentGhcOptions,+        componentCcGhcOptions,+        getLibDir,+        isDynamic,+        getGlobalPackageDB,+        pkgRoot+ ) where++import qualified Distribution.Simple.GHC.IPI641 as IPI641+import qualified Distribution.Simple.GHC.IPI642 as IPI642+import qualified Distribution.Simple.GHC.Internal as Internal+import Distribution.Simple.GHC.ImplInfo+import Distribution.PackageDescription as PD+         ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..)+         , allExtensions, libModules, exeModules+         , hcOptions, hcSharedOptions, hcProfOptions )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo+                                ( InstalledPackageInfo(..) )+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)+         , absoluteInstallDirs, depLibraryPaths )+import qualified Distribution.Simple.Hpc as Hpc+import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs )+import Distribution.Simple.BuildPaths+import Distribution.Simple.Utils+import Distribution.Package+         ( PackageName(..) )+import qualified Distribution.ModuleName as ModuleName+import Distribution.Simple.Program+         ( Program(..), ConfiguredProgram(..), ProgramConfiguration+         , ProgramSearchPath+         , rawSystemProgramStdout, rawSystemProgramStdoutConf+         , getProgramInvocationOutput, requireProgramVersion, requireProgram+         , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram+         , ghcProgram, ghcPkgProgram, haddockProgram, hsc2hsProgram, ldProgram )+import qualified Distribution.Simple.Program.HcPkg as HcPkg+import qualified Distribution.Simple.Program.Ar    as Ar+import qualified Distribution.Simple.Program.Ld    as Ld+import qualified Distribution.Simple.Program.Strip as Strip+import Distribution.Simple.Program.GHC+import Distribution.Simple.Setup+         ( toFlag, fromFlag, fromFlagOrDefault, configCoverage, configDistPref )+import qualified Distribution.Simple.Setup as Cabal+        ( Flag(..) )+import Distribution.Simple.Compiler+         ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion+         , PackageDB(..), PackageDBStack, AbiTag(..) )+import Distribution.Version+         ( Version(..), anyVersion, orLaterVersion )+import Distribution.System+         ( Platform(..), OS(..) )+import Distribution.Verbosity+import Distribution.Text+         ( display )+import Distribution.Utils.NubList+         ( NubListR, overNubListR, toNubListR )+import Language.Haskell.Extension (Extension(..), KnownExtension(..))++import Control.Monad            ( unless, when )+import Data.Char                ( isDigit, isSpace )+import Data.List+import qualified Data.Map as M  ( fromList )+import Data.Maybe               ( catMaybes )+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid              ( Monoid(..) )+#endif+import Data.Version             ( showVersion )+import System.Directory+         ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing )+import System.FilePath          ( (</>), (<.>), takeExtension,+                                  takeDirectory, replaceExtension,+                                  splitExtension, isRelative )+import qualified System.Info++-- -----------------------------------------------------------------------------+-- Configuring++configure :: Verbosity -> Maybe FilePath -> Maybe FilePath+          -> ProgramConfiguration+          -> IO (Compiler, Maybe Platform, ProgramConfiguration)+configure verbosity hcPath hcPkgPath conf0 = do++  (ghcProg, ghcVersion, conf1) <-+    requireProgramVersion verbosity ghcProgram+      (orLaterVersion (Version [6,4] []))+      (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) <-+    requireProgramVersion verbosity ghcPkgProgram {+      programFindLocation = guessGhcPkgFromGhcPath ghcProg+    }+    anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath conf1)++  when (ghcVersion /= ghcPkgVersion) $ die $+       "Version mismatch between ghc and ghc-pkg: "+    ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " "+    ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion++  -- Likewise we try to find the matching hsc2hs and haddock programs.+  let hsc2hsProgram' = hsc2hsProgram {+                           programFindLocation = guessHsc2hsFromGhcPath ghcProg+                       }+      haddockProgram' = haddockProgram {+                           programFindLocation = guessHaddockFromGhcPath ghcProg+                       }+      conf3 = addKnownProgram haddockProgram' $+              addKnownProgram hsc2hsProgram' conf2++  languages  <- Internal.getLanguages verbosity implInfo ghcProg+  extensions <- Internal.getExtensions verbosity implInfo ghcProg++  ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg+  let ghcInfoMap = M.fromList ghcInfo++  let comp = Compiler {+        compilerId         = CompilerId GHC ghcVersion,+        compilerAbiTag     = NoAbiTag,+        compilerCompat     = [],+        compilerLanguages  = languages,+        compilerExtensions = extensions,+        compilerProperties = ghcInfoMap+      }+      compPlatform = Internal.targetPlatform ghcInfo+      -- configure gcc and ld+      conf4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap conf3+  return (comp, compPlatform, conf4)++-- | 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+-- for a versioned or unversioned ghc-pkg in the same dir, that is:+--+-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe)+-- > /usr/local/bin/ghc-pkg-6.6.1(.exe)+-- > /usr/local/bin/ghc-pkg(.exe)+--+guessToolFromGhcPath :: Program -> ConfiguredProgram+                     -> Verbosity -> ProgramSearchPath+                     -> IO (Maybe FilePath)+guessToolFromGhcPath tool ghcProg verbosity searchpath+  = do let toolname          = programName tool+           path              = programPath ghcProg+           dir               = takeDirectory path+           versionSuffix     = takeVersionSuffix (dropExeExtension path)+           guessNormal       = dir </> toolname <.> exeExtension+           guessGhcVersioned = dir </> (toolname ++ "-ghc" ++ versionSuffix)+                               <.> exeExtension+           guessVersioned    = dir </> (toolname ++ versionSuffix)+                               <.> exeExtension+           guesses | null versionSuffix = [guessNormal]+                   | otherwise          = [guessGhcVersioned,+                                           guessVersioned,+                                           guessNormal]+       info verbosity $ "looking for tool " ++ toolname+         ++ " near compiler in " ++ dir+       exists <- mapM doesFileExist guesses+       case [ file | (file, True) <- zip guesses exists ] of+                   -- If we can't find it near ghc, fall back to the usual+                   -- method.+         []     -> programFindLocation tool verbosity searchpath+         (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp+                      return (Just fp)++  where takeVersionSuffix :: FilePath -> String+        takeVersionSuffix = takeWhileEndLE isSuffixChar++        isSuffixChar :: Char -> Bool+        isSuffixChar c = isDigit c || c == '.' || c == '-'++        dropExeExtension :: FilePath -> FilePath+        dropExeExtension filepath =+          case splitExtension filepath of+            (filepath', extension) | extension == exeExtension -> filepath'+                                   | otherwise                 -> filepath++-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a+-- corresponding ghc-pkg, we try looking for both a versioned and unversioned+-- ghc-pkg in the same dir, that is:+--+-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe)+-- > /usr/local/bin/ghc-pkg-6.6.1(.exe)+-- > /usr/local/bin/ghc-pkg(.exe)+--+guessGhcPkgFromGhcPath :: ConfiguredProgram+                       -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram++-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a+-- corresponding hsc2hs, we try looking for both a versioned and unversioned+-- hsc2hs in the same dir, that is:+--+-- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe)+-- > /usr/local/bin/hsc2hs-6.6.1(.exe)+-- > /usr/local/bin/hsc2hs(.exe)+--+guessHsc2hsFromGhcPath :: ConfiguredProgram+                       -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram++-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a+-- corresponding haddock, we try looking for both a versioned and unversioned+-- haddock in the same dir, that is:+--+-- > /usr/local/bin/haddock-ghc-6.6.1(.exe)+-- > /usr/local/bin/haddock-6.6.1(.exe)+-- > /usr/local/bin/haddock(.exe)+--+guessHaddockFromGhcPath :: ConfiguredProgram+                       -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram++getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]+getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg+  where+    Just version = programVersion ghcProg+    implInfo = ghcVersionImplInfo version++-- | Given a single package DB, return all installed packages.+getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration+                        -> IO InstalledPackageIndex+getPackageDBContents verbosity packagedb conf = do+  pkgss <- getInstalledPackages' verbosity [packagedb] conf+  toPackageIndex verbosity pkgss conf++-- | Given a package DB stack, return all installed packages.+getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration+                     -> IO InstalledPackageIndex+getInstalledPackages verbosity comp packagedbs conf = do+  checkPackageDbEnvVar+  checkPackageDbStack comp packagedbs+  pkgss <- getInstalledPackages' verbosity packagedbs conf+  index <- toPackageIndex verbosity pkgss conf+  return $! hackRtsPackage index++  where+    hackRtsPackage index =+      case PackageIndex.lookupPackageName index (PackageName "rts") of+        [(_,[rts])]+           -> PackageIndex.insert (removeMingwIncludeDir rts) index+        _  -> index -- No (or multiple) ghc rts package is registered!!+                    -- Feh, whatever, the ghc test suite does some crazy stuff.++-- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a+-- @PackageIndex@. Helper function used by 'getPackageDBContents' and+-- 'getInstalledPackages'.+toPackageIndex :: Verbosity+               -> [(PackageDB, [InstalledPackageInfo])]+               -> ProgramConfiguration+               -> IO InstalledPackageIndex+toPackageIndex verbosity pkgss conf = 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.+  topDir <- getLibDir' verbosity ghcProg+  let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)+                | (_, pkgs) <- pkgss ]+  return $! (mconcat indices)++  where+    Just ghcProg = lookupProgram ghcProgram conf++getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath+getLibDir verbosity lbi =+    dropWhileEndLE isSpace `fmap`+     rawSystemProgramStdoutConf verbosity ghcProgram+     (withPrograms lbi) ["--print-libdir"]++getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath+getLibDir' verbosity ghcProg =+    dropWhileEndLE isSpace `fmap`+     rawSystemProgramStdout 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"]++checkPackageDbEnvVar :: IO ()+checkPackageDbEnvVar =+    Internal.checkPackageDbEnvVar "GHC" "GHC_PACKAGE_PATH"++checkPackageDbStack :: Compiler -> PackageDBStack -> IO ()+checkPackageDbStack comp = if flagPackageConf implInfo+                              then checkPackageDbStackPre76+                              else checkPackageDbStackPost76+  where implInfo = ghcVersionImplInfo (compilerVersion comp)++checkPackageDbStackPost76 :: PackageDBStack -> IO ()+checkPackageDbStackPost76 (GlobalPackageDB:rest)+  | GlobalPackageDB `notElem` rest = return ()+checkPackageDbStackPost76 rest+  | GlobalPackageDB `elem` rest =+  die $ "If the global package db is specified, it must be "+     ++ "specified first and cannot be specified multiple times"+checkPackageDbStackPost76 _ = return ()++checkPackageDbStackPre76 :: PackageDBStack -> IO ()+checkPackageDbStackPre76 (GlobalPackageDB:rest)+  | GlobalPackageDB `notElem` rest = return ()+checkPackageDbStackPre76 rest+  | GlobalPackageDB `notElem` rest =+  die $ "With current ghc versions the global package db is always used "+     ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6,"+     ++ "see http://hackage.haskell.org/trac/ghc/ticket/5977"+checkPackageDbStackPre76 _ =+  die $ "If the global package db is specified, it must be "+     ++ "specified first and cannot be specified multiple times"++-- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This+-- breaks when you want to use a different gcc, so we need to filter+-- it out.+removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo+removeMingwIncludeDir pkg =+    let ids = InstalledPackageInfo.includeDirs pkg+        ids' = filter (not . ("mingw" `isSuffixOf`)) ids+    in pkg { InstalledPackageInfo.includeDirs = ids' }++-- | Get the packages from specific PackageDBs, not cumulative.+--+getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration+                     -> IO [(PackageDB, [InstalledPackageInfo])]+getInstalledPackages' verbosity packagedbs conf+  | ghcVersion >= Version [6,9] [] =+  sequence+    [ do pkgs <- HcPkg.dump (hcPkgInfo conf) verbosity packagedb+         return (packagedb, pkgs)+    | packagedb <- packagedbs ]++  where+    Just ghcProg    = lookupProgram ghcProgram conf+    Just ghcVersion = programVersion ghcProg++getInstalledPackages' verbosity packagedbs conf = do+    str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf ["list"]+    let pkgFiles = [ init line | line <- lines str, last line == ':' ]+        dbFile packagedb = case (packagedb, pkgFiles) of+          (GlobalPackageDB, global:_)      -> return $ Just global+          (UserPackageDB,  _global:user:_) -> return $ Just user+          (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+                  pkgs <- readPackages file content+                  return (db, pkgs)+             | (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] []+      = \file content -> case reads content of+          [(pkgs, _)] -> return (map IPI642.toCurrent pkgs)+          _           -> failToRead file+      | otherwise+      = \file content -> case reads content of+          [(pkgs, _)] -> return (map IPI641.toCurrent pkgs)+          _           -> failToRead file+    Just ghcProg = lookupProgram ghcProgram conf+    Just ghcVersion = programVersion ghcProg+    failToRead file = die $ "cannot read ghc package database " ++ file++-- -----------------------------------------------------------------------------+-- Building++-- | Build a library with GHC.+--+buildLib, replLib :: Verbosity          -> Cabal.Flag (Maybe Int)+                  -> PackageDescription -> LocalBuildInfo+                  -> Library            -> ComponentLocalBuildInfo -> IO ()+buildLib = buildOrReplLib False+replLib  = buildOrReplLib True++buildOrReplLib :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)+               -> PackageDescription -> LocalBuildInfo+               -> Library            -> ComponentLocalBuildInfo -> IO ()+buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do+  let libName = componentLibraryName clbi+      libTargetDir = buildDir lbi+      whenVanillaLib forceVanilla =+        when (forceVanilla || withVanillaLib lbi)+      whenProfLib = when (withProfLib lbi)+      whenSharedLib forceShared =+        when (forceShared || withSharedLib lbi)+      whenGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi)+      ifReplLib = when forRepl+      comp = compiler lbi+      ghcVersion = compilerVersion comp+      implInfo  = getImplInfo comp+      (Platform _hostArch hostOS) = hostPlatform lbi++  (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)+  let runGhcProg = runGHC verbosity ghcProg comp++  libBi <- hackThreadedFlag verbosity+             comp (withProfLib lbi) (libBuildInfo lib)++  let isGhcDynamic        = isDynamic comp+      dynamicTooSupported = supportsDynamicToo comp+      doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi+      forceVanillaLib = doingTH && not isGhcDynamic+      forceSharedLib  = doingTH &&     isGhcDynamic+      -- TH always needs default libs, even when building for profiling++  -- Determine if program coverage should be enabled and if so, what+  -- '-hpcdir' should be.+  let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi+      -- Component name. Not 'libName' because that has the "HS" prefix+      -- that GHC gives Haskell libraries.+      cname = display $ PD.package $ localPkgDescr lbi+      distPref = fromFlag $ configDistPref $ configFlags lbi+      hpcdir way+        | forRepl = mempty  -- HPC is not supported in ghci+        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname+        | otherwise = mempty++  createDirectoryIfMissingVerbose verbosity True libTargetDir+  -- TODO: do we need to put hs-boot files into place for mutually recursive+  -- modules?+  let cObjs       = map (`replaceExtension` objExtension) (cSources libBi)+      baseOpts    = componentGhcOptions verbosity lbi libBi clbi libTargetDir+      vanillaOpts = baseOpts `mappend` mempty {+                      ghcOptMode         = toFlag GhcModeMake,+                      ghcOptNumJobs      = numJobs,+                      ghcOptInputModules = toNubListR $ libModules lib,+                      ghcOptHPCDir       = hpcdir Hpc.Vanilla+                    }++      profOpts    = vanillaOpts `mappend` mempty {+                      ghcOptProfilingMode = toFlag True,+                      ghcOptProfilingAuto = Internal.profDetailLevelFlag True+                                              (withProfLibDetail lbi),+                      ghcOptHiSuffix      = toFlag "p_hi",+                      ghcOptObjSuffix     = toFlag "p_o",+                      ghcOptExtra         = toNubListR $ hcProfOptions GHC libBi,+                      ghcOptHPCDir        = hpcdir Hpc.Prof+                    }++      sharedOpts  = vanillaOpts `mappend` mempty {+                      ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                      ghcOptFPic        = toFlag True,+                      ghcOptHiSuffix    = toFlag "dyn_hi",+                      ghcOptObjSuffix   = toFlag "dyn_o",+                      ghcOptExtra       = toNubListR $ hcSharedOptions GHC libBi,+                      ghcOptHPCDir      = hpcdir Hpc.Dyn+                    }+      linkerOpts = mempty {+                      ghcOptLinkOptions    = toNubListR $ PD.ldOptions libBi,+                      ghcOptLinkLibs       = toNubListR $ extraLibs libBi,+                      ghcOptLinkLibPath    = toNubListR $ extraLibDirs libBi,+                      ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi,+                      ghcOptInputFiles     = toNubListR+                                             [libTargetDir </> x | x <- cObjs]+                   }+      replOpts    = vanillaOpts {+                      ghcOptExtra        = overNubListR+                                           Internal.filterGhciFlags $+                                           (ghcOptExtra vanillaOpts),+                      ghcOptNumJobs      = mempty+                    }+                    `mappend` linkerOpts+                    `mappend` mempty {+                      ghcOptMode         = toFlag GhcModeInteractive,+                      ghcOptOptimisation = toFlag GhcNoOptimisation+                    }++      vanillaSharedOpts = vanillaOpts `mappend` mempty {+                      ghcOptDynLinkMode  = toFlag GhcStaticAndDynamic,+                      ghcOptDynHiSuffix  = toFlag "dyn_hi",+                      ghcOptDynObjSuffix = toFlag "dyn_o",+                      ghcOptHPCDir       = hpcdir Hpc.Dyn+                    }++  unless (forRepl || null (libModules lib)) $+    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+          then do+              runGhcProg vanillaSharedOpts+              case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of+                (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> do+                    -- When the vanilla and shared library builds are done+                    -- in one pass, only one set of HPC module interfaces+                    -- are generated. This set should suffice for both+                    -- static and dynamically linked executables. We copy+                    -- the modules interfaces so they are available under+                    -- both ways.+                    copyDirectoryRecursive verbosity dynDir vanillaDir+                _ -> return ()+          else if isGhcDynamic+            then do shared;  vanilla+            else do vanilla; shared+       whenProfLib (runGhcProg profOpts)++  -- build any C sources+  unless (null (cSources libBi)) $ do+    info verbosity "Building C Sources..."+    sequence_+      [ do let baseCcOpts    = Internal.componentCcGhcOptions verbosity implInfo+                               lbi libBi clbi libTargetDir 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,+                                 ghcOptObjSuffix     = toFlag "p_o"+                               }+               sharedCcOpts  = vanillaCcOpts `mappend` mempty {+                                 ghcOptFPic        = toFlag True,+                                 ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                                 ghcOptObjSuffix   = toFlag "dyn_o"+                               }+               odir          = fromFlag (ghcOptObjDir vanillaCcOpts)+           createDirectoryIfMissingVerbose verbosity True odir+           needsRecomp <- checkNeedsRecompilation filename vanillaCcOpts+           when needsRecomp $ do+               runGhcProg vanillaCcOpts+               unless forRepl $+                 whenSharedLib forceSharedLib (runGhcProg sharedCcOpts)+               unless forRepl $ whenProfLib (runGhcProg profCcOpts)+      | filename <- cSources libBi]++  -- 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.++  ifReplLib $ do+    when (null (libModules lib)) $ warn verbosity "No exposed modules"+    ifReplLib (runGhcProg replOpts)++  -- link:+  unless forRepl $ do+    info verbosity "Linking..."+    let cProfObjs   = map (`replaceExtension` ("p_" ++ objExtension))+                      (cSources libBi)+        cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))+                      (cSources libBi)+        cid = compilerId (compiler lbi)+        vanillaLibFilePath = libTargetDir </> mkLibName           libName+        profileLibFilePath = libTargetDir </> mkProfLibName       libName+        sharedLibFilePath  = libTargetDir </> mkSharedLibName cid libName+        ghciLibFilePath    = libTargetDir </> Internal.mkGHCiLibName libName+        libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest+        sharedLibInstallPath = libInstallPath </> mkSharedLibName cid libName++    stubObjs <- fmap catMaybes $ sequence+      [ findFileWithExtension [objExtension] [libTargetDir]+          (ModuleName.toFilePath x ++"_stub")+      | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files+      , x <- libModules lib ]+    stubProfObjs <- fmap catMaybes $ sequence+      [ 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 <- fmap catMaybes $ sequence+      [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]+          (ModuleName.toFilePath x ++"_stub")+      | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files+      , x <- libModules lib ]++    hObjs     <- Internal.getHaskellObjects implInfo lib lbi+                      libTargetDir objExtension True+    hProfObjs <-+      if (withProfLib lbi)+              then Internal.getHaskellObjects implInfo lib lbi+                      libTargetDir ("p_" ++ objExtension) True+              else return []+    hSharedObjs <-+      if (withSharedLib lbi)+              then Internal.getHaskellObjects implInfo lib lbi+                      libTargetDir ("dyn_" ++ objExtension) False+              else return []++    unless (null hObjs && null cObjs && null stubObjs) $ do+      rpaths <- getRPaths lbi clbi++      let staticObjectFiles =+                 hObjs+              ++ map (libTargetDir </>) cObjs+              ++ stubObjs+          profObjectFiles =+                 hProfObjs+              ++ map (libTargetDir </>) cProfObjs+              ++ stubProfObjs+          ghciObjFiles =+                 hObjs+              ++ map (libTargetDir </>) cObjs+              ++ stubObjs+          dynamicObjectFiles =+                 hSharedObjs+              ++ map (libTargetDir </>) cSharedObjs+              ++ stubSharedObjs+          -- After the relocation lib is created we invoke ghc -shared+          -- with the dependencies spelled out as -package arguments+          -- and ghc invokes the linker with the proper library paths+          ghcSharedLinkArgs =+              mempty {+                ghcOptShared             = toFlag True,+                ghcOptDynLinkMode        = toFlag GhcDynamicOnly,+                ghcOptInputFiles         = toNubListR dynamicObjectFiles,+                ghcOptOutputFile         = toFlag sharedLibFilePath,+                -- For dynamic libs, Mac OS/X needs to know the install location+                -- at build time. This only applies to GHC < 7.8 - see the+                -- discussion in #1660.+                ghcOptDylibName          = if (hostOS == OSX+                                               && ghcVersion < Version [7,8] [])+                                            then toFlag sharedLibInstallPath+                                            else mempty,+                ghcOptNoAutoLinkPackages = toFlag True,+                ghcOptPackageDBs         = withPackageDB lbi,+                ghcOptPackages           = toNubListR $+                                           Internal.mkGhcOptPackages clbi ,+                ghcOptLinkLibs           = toNubListR $ extraLibs libBi,+                ghcOptLinkLibPath        = toNubListR $ extraLibDirs libBi,+                ghcOptLinkFrameworks     = toNubListR $ PD.frameworks libBi,+                ghcOptRPaths             = rpaths+              }++      info verbosity (show (ghcOptPackages ghcSharedLinkArgs))++      whenVanillaLib False $ do+        Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles++      whenProfLib $ do+        Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles++      whenGHCiLib $ do+        (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)+        Ld.combineObjectFiles verbosity ldProg+          ghciLibFilePath ghciObjFiles++      whenSharedLib False $+        runGhcProg ghcSharedLinkArgs++-- | Start a REPL without loading any source files.+startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler+                 -> PackageDBStack -> IO ()+startInterpreter verbosity conf comp packageDBs = do+  let replOpts = mempty {+        ghcOptMode       = toFlag GhcModeInteractive,+        ghcOptPackageDBs = packageDBs+        }+  checkPackageDbStack comp packageDBs+  (ghcProg, _) <- requireProgram verbosity ghcProgram conf+  runGHC verbosity ghcProg comp replOpts++-- | Build an executable with GHC.+--+buildExe, replExe :: Verbosity          -> Cabal.Flag (Maybe Int)+                  -> PackageDescription -> LocalBuildInfo+                  -> Executable         -> ComponentLocalBuildInfo -> IO ()+buildExe = buildOrReplExe False+replExe  = buildOrReplExe True++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++  (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)+  let comp       = compiler lbi+      implInfo   = getImplInfo comp+      runGhcProg = runGHC verbosity ghcProg comp++  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 "")++  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+  -- 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+      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++  srcMainFile         <- findFile (exeDir : hsSourceDirs exeBi) modPath+  rpaths              <- getRPaths lbi clbi++  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)+                    `mappend` mempty {+                      ghcOptMode         = toFlag GhcModeMake,+                      ghcOptInputFiles   = toNubListR+                        [ srcMainFile | isHaskellMain],+                      ghcOptInputModules = toNubListR+                        [ m | not isHaskellMain, m <- exeModules exe]+                    }+      staticOpts = baseOpts `mappend` mempty {+                      ghcOptDynLinkMode    = toFlag GhcStaticOnly,+                      ghcOptHPCDir         = hpcdir Hpc.Vanilla+                   }+      profOpts   = baseOpts `mappend` mempty {+                      ghcOptProfilingMode  = toFlag True,+                      ghcOptProfilingAuto  = Internal.profDetailLevelFlag False+                                               (withProfExeDetail lbi),+                      ghcOptHiSuffix       = toFlag "p_hi",+                      ghcOptObjSuffix      = toFlag "p_o",+                      ghcOptExtra          = toNubListR (hcProfOptions GHC exeBi),+                      ghcOptHPCDir         = hpcdir Hpc.Prof+                    }+      dynOpts    = baseOpts `mappend` mempty {+                      ghcOptDynLinkMode    = toFlag GhcDynamicOnly,+                      ghcOptHiSuffix       = toFlag "dyn_hi",+                      ghcOptObjSuffix      = toFlag "dyn_o",+                      ghcOptExtra          = toNubListR $+                                             hcSharedOptions GHC exeBi,+                      ghcOptHPCDir         = hpcdir Hpc.Dyn+                    }+      dynTooOpts = staticOpts `mappend` mempty {+                      ghcOptDynLinkMode    = toFlag GhcStaticAndDynamic,+                      ghcOptDynHiSuffix    = toFlag "dyn_hi",+                      ghcOptDynObjSuffix   = toFlag "dyn_o",+                      ghcOptHPCDir         = hpcdir Hpc.Dyn+                    }+      linkerOpts = mempty {+                      ghcOptLinkOptions    = toNubListR $ PD.ldOptions exeBi,+                      ghcOptLinkLibs       = toNubListR $ extraLibs exeBi,+                      ghcOptLinkLibPath    = toNubListR $ extraLibDirs exeBi,+                      ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi,+                      ghcOptInputFiles     = toNubListR+                                             [exeDir </> x | x <- cObjs]+                    }+      dynLinkerOpts = mempty {+                      ghcOptRPaths         = rpaths+                   }+      replOpts   = baseOpts {+                      ghcOptExtra          = overNubListR+                                             Internal.filterGhciFlags+                                             (ghcOptExtra baseOpts)+                   }+                   -- For a normal compile we do separate invocations of ghc for+                   -- compiling as for linking. But for repl we have to do just+                   -- the one invocation, so that one has to include all the+                   -- linker stuff too, like -l flags and any .o files from C+                   -- files etc.+                   `mappend` linkerOpts+                   `mappend` mempty {+                      ghcOptMode           = toFlag GhcModeInteractive,+                      ghcOptOptimisation   = toFlag GhcNoOptimisation+                   }+      commonOpts  | withProfExe lbi = profOpts+                  | withDynExe  lbi = dynOpts+                  | otherwise       = staticOpts+      compileOpts | useDynToo = dynTooOpts+                  | otherwise = commonOpts+      withStaticExe = (not $ withProfExe lbi) && (not $ withDynExe lbi)++      -- 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+      -- -prof/-dynamic. This is because the code that TH needs to run at+      -- compile time needs to be the vanilla ABI so it can be loaded up and run+      -- 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+      -- Should we use -dynamic-too instead of compiling twice?+      useDynToo = dynamicTooSupported && isGhcDynamic+                  && doingTH && withStaticExe+                  && null (hcSharedOptions GHC exeBi)+      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)++  -- Build static/dynamic object files for TH, if needed.+  when compileForTH $+    runGhcProg compileTHOpts { ghcOptNoLink  = toFlag True+                             , ghcOptNumJobs = numJobs }++  unless forRepl $+    runGhcProg compileOpts { ghcOptNoLink  = toFlag True+                           , ghcOptNumJobs = numJobs }++  -- build any C sources+  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)+          createDirectoryIfMissingVerbose verbosity True odir+          needsRecomp <- checkNeedsRecompilation filename opts+          when needsRecomp $ +            runGhcProg opts+     | filename <- cSrcs ]++  -- 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++  -- link:+  unless forRepl $ do+    info verbosity "Linking..."+    runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }++-- | 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 filename opts = filename `moreRecentFile` oname+    where oname = getObjectFileName filename opts++-- | Finds the object file name of the given source file+getObjectFileName :: FilePath -> GhcOptions -> FilePath+getObjectFileName filename opts = oname+    where odir  = fromFlag (ghcOptObjDir opts)+          oext  = fromFlagOrDefault "o" (ghcOptObjSuffix opts)+          oname = odir </> replaceExtension filename oext++-- | Calculate the RPATHs for the component we are building.+--+-- Calculates relative RPATHs when 'relocatable' is set.+getRPaths :: LocalBuildInfo+          -> ComponentLocalBuildInfo -- ^ Component we are building+          -> IO (NubListR FilePath)+getRPaths lbi clbi | supportRPaths hostOS = do+    libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi+    let hostPref = case hostOS of+                     OSX -> "@loader_path"+                     _   -> "$ORIGIN"+        relPath p = if isRelative p then hostPref </> p else p+        rpaths    = toNubListR (map relPath libraryPaths)+    return rpaths+  where+    (Platform _ hostOS) = hostPlatform lbi++    -- The list of RPath-supported operating systems below reflects the+    -- platforms on which Cabal's RPATH handling is tested. It does _NOT_+    -- reflect whether the OS supports RPATH.++    -- E.g. when this comment was written, the *BSD operating systems were+    -- untested with regards to Cabal RPATH handling, and were hence set to+    -- 'False', while those operating systems themselves do support RPATH.+    supportRPaths Linux       = True+    supportRPaths Windows     = False+    supportRPaths OSX         = True+    supportRPaths FreeBSD     = False+    supportRPaths OpenBSD     = False+    supportRPaths NetBSD      = False+    supportRPaths DragonFly   = False+    supportRPaths Solaris     = False+    supportRPaths AIX         = False+    supportRPaths HPUX        = False+    supportRPaths IRIX        = False+    supportRPaths HaLVM       = False+    supportRPaths IOS         = False+    supportRPaths Android     = False+    supportRPaths Ghcjs       = False+    supportRPaths Hurd        = False+    supportRPaths (OtherOS _) = False+    -- Do _not_ add a default case so that we get a warning here when a new OS+    -- is added.++getRPaths _ _ = return mempty++-- | Filter the "-threaded" flag when profiling as it does not+--   work with ghc-6.8 and older.+hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo+hackThreadedFlag verbosity comp prof bi+  | not mustFilterThreaded = return bi+  | otherwise              = do+    warn verbosity $ "The ghc flag '-threaded' is not compatible with "+                  ++ "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] []+                      && "-threaded" `elem` hcOptions GHC bi+    filterHcOptions p hcoptss =+      [ (hc, if hc == GHC then filter p opts else opts)+      | (hc, opts) <- hcoptss ]+++-- | Extracts a String representing a hash of the ABI of a built+-- library.  It can fail if the library has not yet been built.+--+libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo+           -> Library -> ComponentLocalBuildInfo -> IO String+libAbiHash verbosity _pkg_descr lbi lib clbi = do+  libBi <- hackThreadedFlag verbosity+             (compiler lbi) (withProfLib lbi) (libBuildInfo lib)+  let+      comp        = compiler lbi+      vanillaArgs =+        (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))+        `mappend` mempty {+          ghcOptMode         = toFlag GhcModeAbiHash,+          ghcOptInputModules = toNubListR $ exposedModules lib+        }+      sharedArgs = vanillaArgs `mappend` mempty {+                       ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                       ghcOptFPic        = toFlag True,+                       ghcOptHiSuffix    = toFlag "dyn_hi",+                       ghcOptObjSuffix   = toFlag "dyn_o",+                       ghcOptExtra       = toNubListR $ hcSharedOptions GHC libBi+                   }+      profArgs   = vanillaArgs `mappend` mempty {+                     ghcOptProfilingMode = toFlag True,+                     ghcOptProfilingAuto = Internal.profDetailLevelFlag True+                                             (withProfLibDetail lbi),+                     ghcOptHiSuffix      = toFlag "p_hi",+                     ghcOptObjSuffix     = toFlag "p_o",+                     ghcOptExtra         = toNubListR $ hcProfOptions GHC libBi+                   }+      ghcArgs = if withVanillaLib lbi then vanillaArgs+           else if withSharedLib  lbi then sharedArgs+           else if withProfLib    lbi then profArgs+           else error "libAbiHash: Can't find an enabled library way"+  --+  (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)+  hash <- getProgramInvocationOutput verbosity+          (ghcInvocation ghcProg comp ghcArgs)+  return (takeWhile (not . isSpace) hash)++componentGhcOptions :: Verbosity -> LocalBuildInfo+                    -> BuildInfo -> ComponentLocalBuildInfo -> FilePath+                    -> GhcOptions+componentGhcOptions = Internal.componentGhcOptions++componentCcGhcOptions :: Verbosity -> LocalBuildInfo+                      -> BuildInfo -> ComponentLocalBuildInfo+                      -> FilePath -> FilePath+                      -> GhcOptions+componentCcGhcOptions verbosity lbi =+    Internal.componentCcGhcOptions verbosity implInfo lbi+  where+    comp     = compiler lbi+    implInfo = getImplInfo comp++-- -----------------------------------------------------------------------------+-- Installing++-- |Install executables for GHC.+installExe :: Verbosity+           -> LocalBuildInfo+           -> InstallDirs FilePath -- ^Where to copy the files to+           -> FilePath  -- ^Build location+           -> (FilePath, FilePath)  -- ^Executable (prefix,suffix)+           -> PackageDescription+           -> Executable+           -> IO ()+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+      installBinary dest = do+          installExecutableFile verbosity+            (buildPref </> exeName exe </> exeFileName)+            (dest <.> exeExtension)+          when (stripExes lbi) $+            Strip.stripExe verbosity (hostPlatform lbi) (withPrograms lbi)+                           (dest <.> exeExtension)+  installBinary (binDir </> fixedExeBaseName)++-- |Install for ghc, .hi, .a and, if --with-ghci given, .o+installLib    :: Verbosity+              -> LocalBuildInfo+              -> FilePath  -- ^install location+              -> FilePath  -- ^install location for dynamic libraries+              -> FilePath  -- ^Build location+              -> PackageDescription+              -> Library+              -> ComponentLocalBuildInfo+              -> IO ()+installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do+  -- copy .hi files over:+  whenVanilla $ copyModuleFiles "hi"+  whenProf    $ copyModuleFiles "p_hi"+  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++  where+    install isShared srcDir dstDir name = do+      let src = srcDir </> name+          dst = dstDir </> name+      createDirectoryIfMissingVerbose verbosity True dstDir++      if isShared+        then installExecutableFile verbosity src dst+        else installOrdinaryFile   verbosity src dst++      when (stripLibs lbi) $ Strip.stripLib verbosity+                             (hostPlatform lbi) (withPrograms lbi) dst++    installOrdinary = install False+    installShared   = install True++    copyModuleFiles ext =+      findModuleFiles [builtDir] [ext] (libModules lib)+      >>= installOrdinaryFiles verbosity targetDir++    cid = compilerId (compiler lbi)+    libName = componentLibraryName clbi+    vanillaLibName = mkLibName              libName+    profileLibName = mkProfLibName          libName+    ghciLibName    = Internal.mkGHCiLibName libName+    sharedLibName  = (mkSharedLibName cid)  libName++    hasLib    = not $ null (libModules lib)+                   && null (cSources (libBuildInfo lib))+    whenVanilla = when (hasLib && withVanillaLib lbi)+    whenProf    = when (hasLib && withProfLib    lbi)+    whenGHCi    = when (hasLib && withGHCiLib    lbi)+    whenShared  = when (hasLib && withSharedLib  lbi)++-- -----------------------------------------------------------------------------+-- 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.useSingleFileDb = v < [7,9]+                                 }+  where+    v               = versionBranch ver+    Just ghcPkgProg = lookupProgram ghcPkgProgram conf+    Just ver        = programVersion ghcPkgProg++registerPackage+  :: Verbosity+  -> InstalledPackageInfo+  -> PackageDescription+  -> LocalBuildInfo+  -> Bool+  -> PackageDBStack+  -> IO ()+registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs =+  HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity+    packageDbs (Right installedPkgInfo)++pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath+pkgRoot verbosity lbi = pkgRoot'+   where+    pkgRoot' GlobalPackageDB =+      let Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)+      in  fmap takeDirectory (getGlobalPackageDB verbosity ghcProg)+    pkgRoot' UserPackageDB = do+      appDir <- getAppUserDataDirectory "ghc"+      let ver      = compilerVersion (compiler lbi)+          subdir   = System.Info.arch ++ '-':System.Info.os+                     ++ '-':showVersion 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+      -- directory at the time of 'ghc-pkg register', and registration will+      -- fail.+      createDirectoryIfMissing True rootDir+      return rootDir+    pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp)++-- -----------------------------------------------------------------------------+-- Utils++isDynamic :: Compiler -> Bool+isDynamic = Internal.ghcLookupProperty "GHC Dynamic"++supportsDynamicToo :: Compiler -> Bool+supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"

cabal/Cabal/Distribution/Simple/GHC/IPI641.hs view

@@ -2,48 +2,19 @@ -- | -- Module      :  Distribution.Simple.GHC.IPI641 -- Copyright   :  (c) The University of Glasgow 2004+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable -- -{- 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 the University 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. -}- module Distribution.Simple.GHC.IPI641 (-    InstalledPackageInfo,+    InstalledPackageInfo(..),     toCurrent,   ) where  import qualified Distribution.InstalledPackageInfo as Current-import qualified Distribution.Package as Current hiding (depends)+import qualified Distribution.Package as Current hiding (installedPackageId) import Distribution.Text (display)  import Distribution.Simple.GHC.IPI642@@ -94,9 +65,13 @@ mkInstalledPackageId = Current.InstalledPackageId . display  toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo-toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo {+toCurrent ipi@InstalledPackageInfo{} =+  let pid = convertPackageId (package ipi)+      mkExposedModule m = Current.ExposedModule m Nothing Nothing+  in Current.InstalledPackageInfo {     Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)),-    Current.sourcePackageId    = convertPackageId (package ipi),+    Current.sourcePackageId    = pid,+    Current.packageKey         = Current.OldPackageKey pid,     Current.license            = convertLicense (license ipi),     Current.copyright          = copyright ipi,     Current.maintainer         = maintainer ipi,@@ -108,22 +83,24 @@     Current.description        = description ipi,     Current.category           = category ipi,     Current.exposed            = exposed ipi,-    Current.exposedModules     = map convertModuleName (exposedModules ipi),+    Current.exposedModules     = map (mkExposedModule . convertModuleName) (exposedModules ipi),+    Current.instantiatedWith   = [],     Current.hiddenModules      = map convertModuleName (hiddenModules ipi),     Current.trusted            = Current.trusted Current.emptyInstalledPackageInfo,     Current.importDirs         = importDirs ipi,     Current.libraryDirs        = libraryDirs ipi,+    Current.dataDir            = "",     Current.hsLibraries        = hsLibraries ipi,     Current.extraLibraries     = extraLibraries ipi,     Current.extraGHCiLibraries = [],     Current.includeDirs        = includeDirs ipi,     Current.includes           = includes ipi,     Current.depends            = map (mkInstalledPackageId.convertPackageId) (depends ipi),-    Current.hugsOptions        = hugsOptions ipi,     Current.ccOptions          = ccOptions ipi,     Current.ldOptions          = ldOptions ipi,     Current.frameworkDirs      = frameworkDirs ipi,     Current.frameworks         = frameworks ipi,     Current.haddockInterfaces  = haddockInterfaces ipi,-    Current.haddockHTMLs       = haddockHTMLs ipi+    Current.haddockHTMLs       = haddockHTMLs ipi,+    Current.pkgRoot            = Nothing   }

cabal/Cabal/Distribution/Simple/GHC/IPI642.hs view

@@ -2,43 +2,14 @@ -- | -- Module      :  Distribution.Simple.GHC.IPI642 -- Copyright   :  (c) The University of Glasgow 2004+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable -- -{- 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 the University 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. -}- module Distribution.Simple.GHC.IPI642 (-    InstalledPackageInfo,+    InstalledPackageInfo(..),     toCurrent,      -- Don't use these, they're only for conversion purposes@@ -48,7 +19,7 @@   ) where  import qualified Distribution.InstalledPackageInfo as Current-import qualified Distribution.Package as Current hiding (depends)+import qualified Distribution.Package as Current hiding (installedPackageId) import qualified Distribution.License as Current  import Distribution.Version (Version)@@ -129,9 +100,13 @@ convertLicense OtherLicense = Current.OtherLicense  toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo-toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo {+toCurrent ipi@InstalledPackageInfo{} =+  let pid = convertPackageId (package ipi)+      mkExposedModule m = Current.ExposedModule m Nothing Nothing+  in Current.InstalledPackageInfo {     Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)),-    Current.sourcePackageId    = convertPackageId (package ipi),+    Current.sourcePackageId    = pid,+    Current.packageKey         = Current.OldPackageKey pid,     Current.license            = convertLicense (license ipi),     Current.copyright          = copyright ipi,     Current.maintainer         = maintainer ipi,@@ -143,22 +118,24 @@     Current.description        = description ipi,     Current.category           = category ipi,     Current.exposed            = exposed ipi,-    Current.exposedModules     = map convertModuleName (exposedModules ipi),+    Current.exposedModules     = map (mkExposedModule . convertModuleName) (exposedModules ipi),     Current.hiddenModules      = map convertModuleName (hiddenModules ipi),+    Current.instantiatedWith   = [],     Current.trusted            = Current.trusted Current.emptyInstalledPackageInfo,     Current.importDirs         = importDirs ipi,     Current.libraryDirs        = libraryDirs ipi,+    Current.dataDir            = "",     Current.hsLibraries        = hsLibraries ipi,     Current.extraLibraries     = extraLibraries ipi,     Current.extraGHCiLibraries = extraGHCiLibraries ipi,     Current.includeDirs        = includeDirs ipi,     Current.includes           = includes ipi,     Current.depends            = map (mkInstalledPackageId.convertPackageId) (depends ipi),-    Current.hugsOptions        = hugsOptions ipi,     Current.ccOptions          = ccOptions ipi,     Current.ldOptions          = ldOptions ipi,     Current.frameworkDirs      = frameworkDirs ipi,     Current.frameworks         = frameworks ipi,     Current.haddockInterfaces  = haddockInterfaces ipi,-    Current.haddockHTMLs       = haddockHTMLs ipi+    Current.haddockHTMLs       = haddockHTMLs ipi,+    Current.pkgRoot            = Nothing   }

+ cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs view

@@ -0,0 +1,111 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.GHC.ImplInfo+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module contains the data structure describing invocation+-- details for a GHC or GHC-derived compiler, such as supported flags+-- and workarounds for bugs.++module Distribution.Simple.GHC.ImplInfo (+        GhcImplInfo(..), getImplInfo,+        ghcVersionImplInfo, ghcjsVersionImplInfo, lhcVersionImplInfo+        ) where++import Distribution.Simple.Compiler+  ( Compiler(..), CompilerFlavor(..)+  , compilerFlavor, compilerVersion, compilerCompatVersion )+import Distribution.Version ( Version(..) )++{- |+     Information about features and quirks of a GHC-based implementation.++     Compiler flavors based on GHC behave similarly enough that some of+     the support code for them is shared. Every implementation has its+     own peculiarities, that may or may not be a direct result of the+     underlying GHC version. This record keeps track of these differences.++     All shared code (i.e. everything not in the Distribution.Simple.FLAVOR+     module) should use implementation info rather than version numbers+     to test for supported features.+-}++data GhcImplInfo = GhcImplInfo+  { hasCcOdirBug         :: Bool -- ^ bug in -odir handling for C compilations.+  , flagInfoLanguages    :: Bool -- ^ --info and --supported-languages flags+  , fakeRecordPuns       :: Bool -- ^ use -XRecordPuns for NamedFieldPuns+  , flagStubdir          :: Bool -- ^ -stubdir flag supported+  , flagOutputDir        :: Bool -- ^ -outputdir flag supported+  , noExtInSplitSuffix   :: Bool -- ^ split-obj suffix does not contain p_o ext+  , flagFfiIncludes      :: Bool -- ^ -#include on command line for FFI includes+  , flagBuildingCabalPkg :: Bool -- ^ -fbuilding-cabal-package flag supported+  , flagPackageId        :: Bool -- ^ -package-id / -package flags supported+  , separateGccMingw     :: Bool -- ^ mingw and gcc are in separate directories+  , supportsHaskell2010  :: Bool -- ^ -XHaskell2010 and -XHaskell98 flags+  , reportsNoExt         :: Bool -- ^ --supported-languages gives Ext and NoExt+  , alwaysNondecIndent   :: Bool -- ^ NondecreasingIndentation is always on+  , flagGhciScript       :: Bool -- ^ -ghci-script flag supported+  , flagProfAuto         :: Bool -- ^ new style -fprof-auto* flags+  , flagPackageConf      :: Bool -- ^ use package-conf instead of package-db+  , flagDebugInfo        :: Bool -- ^ -g flag supported+  }++getImplInfo :: Compiler -> GhcImplInfo+getImplInfo comp =+  case compilerFlavor comp of+    GHC   -> ghcVersionImplInfo (compilerVersion comp)+    LHC   -> lhcVersionImplInfo (compilerVersion comp)+    GHCJS -> case compilerCompatVersion GHC comp of+              Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer+              _  -> error ("Distribution.Simple.GHC.Props.getImplProps: " +++                           "could not find GHC version for GHCJS compiler")+    x     -> error ("Distribution.Simple.GHC.Props.getImplProps only works" +++                    "for GHC-like compilers (GHC, GHCJS, LHC)" +++                    ", but found " ++ show x)++ghcVersionImplInfo :: Version -> GhcImplInfo+ghcVersionImplInfo (Version v _) = GhcImplInfo+  { hasCcOdirBug         = v <  [6,4,1]+  , flagInfoLanguages    = v >= [6,7]+  , fakeRecordPuns       = v >= [6,8] && v < [6,10]+  , flagStubdir          = v >= [6,8]+  , flagOutputDir        = v >= [6,10]+  , noExtInSplitSuffix   = v <  [6,11]+  , flagFfiIncludes      = v <  [6,11]+  , flagBuildingCabalPkg = v >= [6,11]+  , flagPackageId        = v >  [6,11]+  , separateGccMingw     = v <  [6,12]+  , supportsHaskell2010  = v >= [7]+  , reportsNoExt         = v >= [7]+  , alwaysNondecIndent   = v <  [7,1]+  , flagGhciScript       = v >= [7,2]+  , flagProfAuto         = v >= [7,4]+  , flagPackageConf      = v <  [7,5]+  , flagDebugInfo        = v >= [7,10]+  }++ghcjsVersionImplInfo :: Version -> Version -> GhcImplInfo+ghcjsVersionImplInfo _ghcjsVer _ghcVer = GhcImplInfo+  { hasCcOdirBug         = False+  , flagInfoLanguages    = True+  , fakeRecordPuns       = False+  , flagStubdir          = True+  , flagOutputDir        = True+  , noExtInSplitSuffix   = False+  , flagFfiIncludes      = False+  , flagBuildingCabalPkg = True+  , flagPackageId        = True+  , separateGccMingw     = False+  , supportsHaskell2010  = True+  , reportsNoExt         = True+  , alwaysNondecIndent   = False+  , flagGhciScript       = True+  , flagProfAuto         = True+  , flagPackageConf      = False+  , flagDebugInfo        = False+  }++lhcVersionImplInfo :: Version -> GhcImplInfo+lhcVersionImplInfo = ghcVersionImplInfo

+ cabal/Cabal/Distribution/Simple/GHC/Internal.hs view

@@ -0,0 +1,521 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.GHC.Internal+-- Copyright   :  Isaac Jones 2003-2007+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module contains functions shared by GHC (Distribution.Simple.GHC)+-- and GHC-derived compilers.++module Distribution.Simple.GHC.Internal (+        configureToolchain,+        getLanguages,+        getExtensions,+        targetPlatform,+        getGhcInfo,+        componentCcGhcOptions,+        componentGhcOptions,+        mkGHCiLibName,+        filterGhciFlags,+        ghcLookupProperty,+        getHaskellObjects,+        mkGhcOptPackages,+        substTopDir,+        checkPackageDbEnvVar,+        profDetailLevelFlag,+ ) where++import Distribution.Simple.GHC.ImplInfo ( GhcImplInfo (..) )+import Distribution.Package+         ( InstalledPackageId, PackageId, LibraryName+         , getHSLibraryName )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo+                                ( InstalledPackageInfo(..) )+import Distribution.PackageDescription as PD+         ( BuildInfo(..), Library(..), libModules+         , hcOptions, usedExtensions, ModuleRenaming, lookupRenaming )+import Distribution.Compat.Exception ( catchExit, catchIO )+import Distribution.Lex (tokenizeQuotedWords)+import Distribution.Simple.Compiler+         ( CompilerFlavor(..), Compiler(..), DebugInfoLevel(..)+         , OptimisationLevel(..), ProfDetailLevel(..) )+import Distribution.Simple.Program.GHC+import Distribution.Simple.Setup+         ( Flag, toFlag )+import qualified Distribution.ModuleName as ModuleName+import Distribution.Simple.Program+         ( Program(..), ConfiguredProgram(..), ProgramConfiguration+         , ProgramLocation(..), ProgramSearchPath, ProgramSearchPathEntry(..)+         , rawSystemProgram, rawSystemProgramStdout, programPath+         , addKnownProgram, arProgram, ldProgram, gccProgram, stripProgram+         , getProgramOutput )+import Distribution.Simple.Program.Types ( suppressOverrideArgs )+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) )+import Distribution.Simple.Utils+import Distribution.Simple.BuildPaths+import Distribution.System ( buildOS, OS(..), Platform, platformFromTriple )+import Distribution.Text ( display, simpleParse )+import Distribution.Utils.NubList ( toNubListR )+import Distribution.Verbosity+import Language.Haskell.Extension+         ( Language(..), Extension(..), KnownExtension(..) )++import qualified Data.Map as M+import Data.Char                ( isSpace )+import Data.Maybe               ( fromMaybe, maybeToList, isJust )+import Control.Monad            ( unless, when )+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid              ( Monoid(..) )+#endif+import System.Directory         ( getDirectoryContents, getTemporaryDirectory )+import System.Environment       ( getEnv )+import System.FilePath          ( (</>), (<.>), takeExtension, takeDirectory )+import System.IO                ( hClose, hPutStrLn )++targetPlatform :: [(String, String)] -> Maybe Platform+targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo++-- | Adjust the way we find and configure gcc and ld+--+configureToolchain :: GhcImplInfo+                   -> ConfiguredProgram+                   -> M.Map String String+                   -> ProgramConfiguration+                   -> ProgramConfiguration+configureToolchain implInfo ghcProg ghcInfo =+    addKnownProgram gccProgram {+      programFindLocation = findProg gccProgram extraGccPath,+      programPostConf     = configureGcc+    }+  . addKnownProgram ldProgram {+      programFindLocation = findProg ldProgram extraLdPath,+      programPostConf     = configureLd+    }+  . addKnownProgram arProgram {+      programFindLocation = findProg arProgram extraArPath+    }+  . addKnownProgram stripProgram {+      programFindLocation = findProg stripProgram extraStripPath+    }+  where+    compilerDir = takeDirectory (programPath ghcProg)+    baseDir     = takeDirectory compilerDir+    mingwBinDir = baseDir </> "mingw" </> "bin"+    libDir      = baseDir </> "gcc-lib"+    includeDir  = baseDir </> "include" </> "mingw"+    isWindows   = case buildOS of Windows -> True; _ -> False+    binPrefix   = ""++    mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]+    mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath]+                                 | otherwise = mbDir+      where+        mbDir = maybeToList . fmap takeDirectory $ mbPath++    extraGccPath   = mkExtraPath mbGccLocation   windowsExtraGccDir+    extraLdPath    = mkExtraPath mbLdLocation    windowsExtraLdDir+    extraArPath    = mkExtraPath mbArLocation    windowsExtraArDir+    extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir++    -- on Windows finding and configuring ghc's gcc & binutils is a bit special+    (windowsExtraGccDir, windowsExtraLdDir,+     windowsExtraArDir, windowsExtraStripDir)+      | separateGccMingw implInfo = (baseDir, libDir, libDir, libDir)+      | otherwise                 = -- GHC >= 6.12+          let b = mingwBinDir </> binPrefix+          in  (b, b, b, b)++    findProg :: Program -> [FilePath]+             -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+    findProg prog extraPath v searchpath =+        programFindLocation prog v searchpath'+      where+        searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath++    -- 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++    ccFlags        = getFlags "C compiler flags"+    gccLinkerFlags = getFlags "Gcc Linker flags"+    ldLinkerFlags  = getFlags "Ld Linker 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+    -- String.+    --+    -- We first try to parse as a [String] and if this fails then tokenize the+    -- flags ourself.+    getFlags :: String -> [String]+    getFlags key =+        case M.lookup key ghcInfo of+          Nothing -> []+          Just flags+            | (flags', ""):_ <- reads flags -> flags'+            | otherwise -> tokenizeQuotedWords flags++    configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram+    configureGcc v gccProg = do+      gccProg' <- configureGcc' v gccProg+      return gccProg' {+        programDefaultArgs = programDefaultArgs gccProg'+                             ++ ccFlags ++ gccLinkerFlags+      }++    configureGcc' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram+    configureGcc'+      | isWindows = \_ gccProg -> case programLocation gccProg of+          -- if it's found on system then it means we're using the result+          -- of programFindLocation above rather than a user-supplied path+          -- Pre GHC 6.12, that meant we should add these flags to tell+          -- ghc's gcc where it lives and thus where gcc can find its+          -- various files:+          FoundOnSystem {}+           | separateGccMingw implInfo ->+               return gccProg { programDefaultArgs = ["-B" ++ libDir,+                                                      "-I" ++ includeDir] }+          _ -> return gccProg+      | otherwise = \_ gccProg -> return gccProg++    configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram+    configureLd v ldProg = do+      ldProg' <- configureLd' v ldProg+      return ldProg' {+        programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags+      }++    -- we need to find out if ld supports the -x flag+    configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram+    configureLd' verbosity ldProg = do+      tempDir <- getTemporaryDirectory+      ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->+             withTempFile tempDir ".o" $ \testofile testohnd -> do+               hPutStrLn testchnd "int foo() { return 0; }"+               hClose testchnd; hClose testohnd+               rawSystemProgram verbosity ghcProg ["-c", testcfile,+                                                   "-o", testofile]+               withTempFile tempDir ".o" $ \testofile' testohnd' ->+                 do+                   hClose testohnd'+                   _ <- rawSystemProgramStdout verbosity ldProg+                     ["-x", "-r", testofile, "-o", testofile']+                   return True+                 `catchIO`   (\_ -> return False)+                 `catchExit` (\_ -> return False)+      if ldx+        then return ldProg { programDefaultArgs = ["-x"] }+        else return ldProg++getLanguages :: Verbosity -> GhcImplInfo -> ConfiguredProgram+             -> IO [(Language, String)]+getLanguages _ implInfo _+  -- TODO: should be using --supported-languages rather than hard coding+  | supportsHaskell2010 implInfo = return [(Haskell98,   "-XHaskell98")+                                          ,(Haskell2010, "-XHaskell2010")]+  | otherwise                    = return [(Haskell98,   "")]++getGhcInfo :: Verbosity -> GhcImplInfo -> ConfiguredProgram+           -> IO [(String, String)]+getGhcInfo verbosity implInfo ghcProg+  | flagInfoLanguages implInfo = do+      xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)+                 ["--info"]+      case reads xs of+        [(i, ss)]+          | all isSpace ss ->+              return i+        _ ->+          die "Can't parse --info output of GHC"+  | otherwise =+      return []++getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram+              -> IO [(Extension, String)]+getExtensions verbosity implInfo ghcProg+  | flagInfoLanguages implInfo = do+    str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)+              ["--supported-languages"]+    let extStrs = if reportsNoExt implInfo+                  then lines str+                  else -- Older GHCs only gave us either Foo or NoFoo,+                       -- so we have to work out the other one ourselves+                       [ extStr''+                       | extStr <- lines str+                       , let extStr' = case extStr of+                                       'N' : 'o' : xs -> xs+                                       _              -> "No" ++ extStr+                       , extStr'' <- [extStr, extStr']+                       ]+    let extensions0 = [ (ext, "-X" ++ display ext)+                      | Just ext <- map simpleParse extStrs ]+        extensions1 = if fakeRecordPuns implInfo+                      then -- ghc-6.8 introduced RecordPuns however it+                           -- should have been NamedFieldPuns. We now+                           -- encourage packages to use NamedFieldPuns+                           -- so for compatibility we fake support for+                           -- it in ghc-6.8 by making it an alias for+                           -- the old RecordPuns extension.+                           (EnableExtension  NamedFieldPuns, "-XRecordPuns") :+                           (DisableExtension NamedFieldPuns, "-XNoRecordPuns") :+                           extensions0+                      else extensions0+        extensions2 = if alwaysNondecIndent implInfo+                      then -- ghc-7.2 split NondecreasingIndentation off+                           -- into a proper extension. Before that it+                           -- was always on.+                           (EnableExtension  NondecreasingIndentation, "") :+                           (DisableExtension NondecreasingIndentation, "") :+                           extensions1+                      else extensions1+    return extensions2++  | otherwise = return oldLanguageExtensions++-- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags+oldLanguageExtensions :: [(Extension, String)]+oldLanguageExtensions =+    let doFlag (f, (enable, disable)) = [(EnableExtension  f, enable),+                                         (DisableExtension f, disable)]+        fglasgowExts = ("-fglasgow-exts",+                        "") -- This is wrong, but we don't want to turn+                            -- all the extensions off when asked to just+                            -- turn one off+        fFlag flag = ("-f" ++ flag, "-fno-" ++ flag)+    in concatMap doFlag+    [(OverlappingInstances       , fFlag "allow-overlapping-instances")+    ,(TypeSynonymInstances       , fglasgowExts)+    ,(TemplateHaskell            , fFlag "th")+    ,(ForeignFunctionInterface   , fFlag "ffi")+    ,(MonomorphismRestriction    , fFlag "monomorphism-restriction")+    ,(MonoPatBinds               , fFlag "mono-pat-binds")+    ,(UndecidableInstances       , fFlag "allow-undecidable-instances")+    ,(IncoherentInstances        , fFlag "allow-incoherent-instances")+    ,(Arrows                     , fFlag "arrows")+    ,(Generics                   , fFlag "generics")+    ,(ImplicitPrelude            , fFlag "implicit-prelude")+    ,(ImplicitParams             , fFlag "implicit-params")+    ,(CPP                        , ("-cpp", ""{- Wrong -}))+    ,(BangPatterns               , fFlag "bang-patterns")+    ,(KindSignatures             , fglasgowExts)+    ,(RecursiveDo                , fglasgowExts)+    ,(ParallelListComp           , fglasgowExts)+    ,(MultiParamTypeClasses      , fglasgowExts)+    ,(FunctionalDependencies     , fglasgowExts)+    ,(Rank2Types                 , fglasgowExts)+    ,(RankNTypes                 , fglasgowExts)+    ,(PolymorphicComponents      , fglasgowExts)+    ,(ExistentialQuantification  , fglasgowExts)+    ,(ScopedTypeVariables        , fFlag "scoped-type-variables")+    ,(FlexibleContexts           , fglasgowExts)+    ,(FlexibleInstances          , fglasgowExts)+    ,(EmptyDataDecls             , fglasgowExts)+    ,(PatternGuards              , fglasgowExts)+    ,(GeneralizedNewtypeDeriving , fglasgowExts)+    ,(MagicHash                  , fglasgowExts)+    ,(UnicodeSyntax              , fglasgowExts)+    ,(PatternSignatures          , fglasgowExts)+    ,(UnliftedFFITypes           , fglasgowExts)+    ,(LiberalTypeSynonyms        , fglasgowExts)+    ,(TypeOperators              , fglasgowExts)+    ,(GADTs                      , fglasgowExts)+    ,(RelaxedPolyRec             , fglasgowExts)+    ,(ExtendedDefaultRules       , fFlag "extended-default-rules")+    ,(UnboxedTuples              , fglasgowExts)+    ,(DeriveDataTypeable         , fglasgowExts)+    ,(ConstrainedClassMethods    , fglasgowExts)+    ]++componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo+                      -> BuildInfo -> ComponentLocalBuildInfo+                      -> FilePath -> FilePath+                      -> GhcOptions+componentCcGhcOptions verbosity implInfo lbi bi clbi pref filename =+    mempty {+      ghcOptVerbosity      = toFlag verbosity,+      ghcOptMode           = toFlag GhcModeCompile,+      ghcOptInputFiles     = toNubListR [filename],++      ghcOptCppIncludePath = toNubListR $ [autogenModulesDir lbi, odir]+                                          ++ PD.includeDirs bi,+      ghcOptPackageDBs     = withPackageDB lbi,+      ghcOptPackages       = toNubListR $ mkGhcOptPackages clbi,+      ghcOptCcOptions      = toNubListR $+                             (case withOptimization lbi of+                                  NoOptimisation -> []+                                  _              -> ["-O2"]) +++                             (case withDebugInfo lbi of+                                  NoDebugInfo   -> []+                                  MinimalDebugInfo -> ["-g1"]+                                  NormalDebugInfo  -> ["-g"]+                                  MaximalDebugInfo -> ["-g3"]) +++                                  PD.ccOptions bi,+      ghcOptObjDir         = toFlag odir+    }+  where+    odir | hasCcOdirBug implInfo = pref </> takeDirectory filename+         | otherwise             = pref+         -- ghc 6.4.0 had a bug in -odir handling for C compilations.++componentGhcOptions :: Verbosity -> LocalBuildInfo+                    -> BuildInfo -> ComponentLocalBuildInfo -> FilePath+                    -> GhcOptions+componentGhcOptions verbosity lbi bi clbi odir =+    mempty {+      ghcOptVerbosity       = toFlag verbosity,+      ghcOptHideAllPackages = toFlag True,+      ghcOptCabal           = toFlag True,+      ghcOptPackageKey  = case clbi of+        LibComponentLocalBuildInfo { componentPackageKey = pk } -> toFlag pk+        _ -> mempty,+      ghcOptSigOf           = hole_insts,+      ghcOptPackageDBs      = withPackageDB lbi,+      ghcOptPackages        = toNubListR $ mkGhcOptPackages clbi,+      ghcOptSplitObjs       = toFlag (splitObjs lbi),+      ghcOptSourcePathClear = toFlag True,+      ghcOptSourcePath      = toNubListR $ [odir] ++ (hsSourceDirs bi)+                                           ++ [autogenModulesDir lbi],+      ghcOptCppIncludePath  = toNubListR $ [autogenModulesDir lbi, odir]+                                           ++ PD.includeDirs bi,+      ghcOptCppOptions      = toNubListR $ cppOptions bi,+      ghcOptCppIncludes     = toNubListR $+                              [autogenModulesDir lbi </> cppHeaderName],+      ghcOptFfiIncludes     = toNubListR $ PD.includes bi,+      ghcOptObjDir          = toFlag odir,+      ghcOptHiDir           = toFlag odir,+      ghcOptStubDir         = toFlag odir,+      ghcOptOutputDir       = toFlag odir,+      ghcOptOptimisation    = toGhcOptimisation (withOptimization lbi),+      ghcOptDebugInfo       = toGhcDebugInfo (withDebugInfo lbi),+      ghcOptExtra           = toNubListR $ hcOptions GHC bi,+      ghcOptLanguage        = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),+      -- Unsupported extensions have already been checked by configure+      ghcOptExtensions      = toNubListR $ usedExtensions bi,+      ghcOptExtensionMap    = M.fromList . compilerExtensions $ (compiler lbi)+    }+  where+    toGhcOptimisation NoOptimisation      = mempty --TODO perhaps override?+    toGhcOptimisation NormalOptimisation  = toFlag GhcNormalOptimisation+    toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation++    -- GHC doesn't support debug info levels yet.+    toGhcDebugInfo NoDebugInfo      = mempty+    toGhcDebugInfo MinimalDebugInfo = toFlag True+    toGhcDebugInfo NormalDebugInfo  = toFlag True+    toGhcDebugInfo MaximalDebugInfo = toFlag True++    hole_insts = map (\(k,(p,n)) -> (k, (InstalledPackageInfo.packageKey p,n)))+                 (instantiatedWith lbi)++-- | Strip out flags that are not supported in ghci+filterGhciFlags :: [String] -> [String]+filterGhciFlags = filter supported+  where+    supported ('-':'O':_) = False+    supported "-debug"    = False+    supported "-threaded" = False+    supported "-ticky"    = False+    supported "-eventlog" = False+    supported "-prof"     = False+    supported "-unreg"    = False+    supported _           = True++mkGHCiLibName :: LibraryName -> String+mkGHCiLibName lib = getHSLibraryName lib <.> "o"++ghcLookupProperty :: String -> Compiler -> Bool+ghcLookupProperty prop comp =+  case M.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+  | splitObjs lbi && allow_split_objs = do+        let splitSuffix = if   noExtInSplitSuffix implInfo+                          then "_split"+                          else "_" ++ wanted_obj_ext ++ "_split"+            dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)+                   | x <- libModules lib ]+        objss <- mapM getDirectoryContents dirs+        let objs = [ dir </> obj+                   | (objs',dir) <- zip objss dirs, obj <- objs',+                     let obj_ext = takeExtension obj,+                     '.':wanted_obj_ext == obj_ext ]+        return objs+  | otherwise  =+        return [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext+               | x <- libModules lib ]++mkGhcOptPackages :: ComponentLocalBuildInfo+                 -> [(InstalledPackageId, PackageId, ModuleRenaming)]+mkGhcOptPackages clbi =+  map (\(i,p) -> (i,p,lookupRenaming p (componentPackageRenaming clbi)))+      (componentPackageDeps clbi)++substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo+substTopDir topDir ipo+ = ipo {+       InstalledPackageInfo.importDirs+           = map f (InstalledPackageInfo.importDirs ipo),+       InstalledPackageInfo.libraryDirs+           = map f (InstalledPackageInfo.libraryDirs ipo),+       InstalledPackageInfo.includeDirs+           = map f (InstalledPackageInfo.includeDirs ipo),+       InstalledPackageInfo.frameworkDirs+           = map f (InstalledPackageInfo.frameworkDirs ipo),+       InstalledPackageInfo.haddockInterfaces+           = map f (InstalledPackageInfo.haddockInterfaces ipo),+       InstalledPackageInfo.haddockHTMLs+           = map f (InstalledPackageInfo.haddockHTMLs ipo)+   }+    where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest+          f x = x++-- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let+-- users know that this is the case. See ticket #335. Simply ignoring it is+-- not a good idea, since then ghc and cabal are looking at different sets+-- of package DBs and chaos is likely to ensue.+--+-- An exception to this is when running cabal from within a `cabal exec`+-- environment. In this case, `cabal exec` will set the+-- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set+-- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow+-- GHC{,JS}_PACKAGE_PATH.+checkPackageDbEnvVar :: String -> String -> IO ()+checkPackageDbEnvVar compilerName packagePathEnvVar = do+    mPP <- lookupEnv packagePathEnvVar+    when (isJust mPP) $ do+        mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH"+        unless (mPP == mcsPP) abort+    where+        lookupEnv :: String -> IO (Maybe String)+        lookupEnv name = (Just `fmap` getEnv name) `catchIO` const (return Nothing)+        abort =+            die $ "Use of " ++ compilerName ++ "'s environment variable "+               ++ packagePathEnvVar ++ " is incompatible with Cabal. Use the "+               ++ "flag --package-db to specify a package database (it can be "+               ++ "used multiple times)."++profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto+profDetailLevelFlag forLib mpl =+    case mpl of+      ProfDetailNone                -> mempty+      ProfDetailDefault | forLib    -> toFlag GhcProfAutoExported+                        | otherwise -> toFlag GhcProfAutoToplevel+      ProfDetailExportedFunctions   -> toFlag GhcProfAutoExported+      ProfDetailToplevelFunctions   -> toFlag GhcProfAutoToplevel+      ProfDetailAllFunctions        -> toFlag GhcProfAutoAll+      ProfDetailOther _             -> mempty

+ cabal/Cabal/Distribution/Simple/GHCJS.hs view

@@ -0,0 +1,896 @@+{-# LANGUAGE CPP #-}+module Distribution.Simple.GHCJS (+        configure, getInstalledPackages, getPackageDBContents,+        buildLib, buildExe,+        replLib, replExe,+        startInterpreter,+        installLib, installExe,+        libAbiHash,+        hcPkgInfo,+        registerPackage,+        componentGhcOptions,+        getLibDir,+        isDynamic,+        getGlobalPackageDB,+        runCmd+  ) where++import Distribution.Simple.GHC.ImplInfo ( getImplInfo, ghcjsVersionImplInfo )+import qualified Distribution.Simple.GHC.Internal as Internal+import Distribution.PackageDescription as PD+         ( PackageDescription(..), BuildInfo(..), Executable(..)+         , Library(..), libModules, exeModules+         , hcOptions, hcProfOptions, hcSharedOptions+         , allExtensions )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo+                                ( InstalledPackageInfo(..) )+import Distribution.Package ( LibraryName(..), getHSLibraryName )+import Distribution.Simple.PackageIndex ( InstalledPackageIndex )+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) )+import qualified Distribution.Simple.Hpc as Hpc+import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs )+import Distribution.Simple.BuildPaths+import Distribution.Simple.Utils+import Distribution.Simple.Program+         ( Program(..), ConfiguredProgram(..), ProgramConfiguration+         , ProgramSearchPath+         , rawSystemProgramConf+         , rawSystemProgramStdout, rawSystemProgramStdoutConf+         , getProgramInvocationOutput+         , requireProgramVersion, requireProgram+         , userMaybeSpecifyPath, programPath+         , lookupProgram, addKnownPrograms+         , ghcjsProgram, ghcjsPkgProgram, c2hsProgram, hsc2hsProgram+         , ldProgram, haddockProgram, stripProgram )+import qualified Distribution.Simple.Program.HcPkg as HcPkg+import qualified Distribution.Simple.Program.Ar    as Ar+import qualified Distribution.Simple.Program.Ld    as Ld+import qualified Distribution.Simple.Program.Strip as Strip+import Distribution.Simple.Program.GHC+import Distribution.Simple.Setup+         ( toFlag, fromFlag, configCoverage, configDistPref )+import qualified Distribution.Simple.Setup as Cabal+        ( Flag(..) )+import Distribution.Simple.Compiler+         ( CompilerFlavor(..), CompilerId(..), Compiler(..)+         , PackageDB(..), PackageDBStack, AbiTag(..) )+import Distribution.Version+         ( Version(..), anyVersion, orLaterVersion )+import Distribution.System+         ( Platform(..) )+import Distribution.Verbosity+import Distribution.Utils.NubList+         ( overNubListR, toNubListR )+import Distribution.Text ( display )+import Language.Haskell.Extension ( Extension(..)+                                  , KnownExtension(..))++import Control.Monad            ( unless, when )+import Data.Char                ( isSpace )+import qualified Data.Map as M  ( fromList  )+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid              ( Monoid(..) )+#endif+import System.Directory         ( doesFileExist )+import System.FilePath          ( (</>), (<.>), takeExtension,+                                  takeDirectory, replaceExtension,+                                  splitExtension )++configure :: Verbosity -> Maybe FilePath -> Maybe FilePath+          -> ProgramConfiguration+          -> IO (Compiler, Maybe Platform, ProgramConfiguration)+configure verbosity hcPath hcPkgPath conf0 = do+  (ghcjsProg, ghcjsVersion, conf1) <-+    requireProgramVersion verbosity ghcjsProgram+      (orLaterVersion (Version [0,1] []))+      (userMaybeSpecifyPath "ghcjs" hcPath conf0)+  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) <-+    requireProgramVersion verbosity ghcjsPkgProgram {+      programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg+    }+    anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath conf1)++  Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion+                                  verbosity (programPath ghcjsPkgProg)++  when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die $+       "Version mismatch between ghcjs and ghcjs-pkg: "+    ++ programPath ghcjsProg ++ " is version " ++ display ghcjsVersion ++ " "+    ++ programPath ghcjsPkgProg ++ " is version " ++ display ghcjsPkgGhcjsVersion++  when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die $+       "Version mismatch between ghcjs and ghcjs-pkg: "+    ++ programPath ghcjsProg+    ++ " was built with GHC version " ++ display ghcjsGhcVersion ++ " "+    ++ programPath ghcjsPkgProg+    ++ " was built with GHC version " ++ display ghcjsPkgVersion++  -- be sure to use our versions of hsc2hs, c2hs, haddock and ghc+  let hsc2hsProgram' =+        hsc2hsProgram { programFindLocation =+                          guessHsc2hsFromGhcjsPath ghcjsProg }+      c2hsProgram' =+        c2hsProgram { programFindLocation =+                          guessC2hsFromGhcjsPath ghcjsProg }++      haddockProgram' =+        haddockProgram { programFindLocation =+                          guessHaddockFromGhcjsPath ghcjsProg }+      conf3 = addKnownPrograms [ hsc2hsProgram', c2hsProgram', haddockProgram' ] conf2++  languages  <- Internal.getLanguages  verbosity implInfo ghcjsProg+  extensions <- Internal.getExtensions verbosity implInfo ghcjsProg++  ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg+  let ghcInfoMap = M.fromList ghcInfo++  let comp = Compiler {+        compilerId         = CompilerId GHCJS ghcjsVersion,+        compilerAbiTag     = AbiTag $+          "ghc" ++ intercalate "_" (map show . versionBranch $ ghcjsGhcVersion),+        compilerCompat     = [CompilerId GHC ghcjsGhcVersion],+        compilerLanguages  = languages,+        compilerExtensions = extensions,+        compilerProperties = ghcInfoMap+      }+      compPlatform = Internal.targetPlatform ghcInfo+  -- configure gcc and ld+  let conf4 = if ghcjsNativeToo comp+                     then Internal.configureToolchain implInfo+                            ghcjsProg ghcInfoMap conf3+                     else conf3+  return (comp, compPlatform, conf4)++ghcjsNativeToo :: Compiler -> Bool+ghcjsNativeToo = Internal.ghcLookupProperty "Native Too"++guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity+                           -> ProgramSearchPath -> IO (Maybe FilePath)+guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram++guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity+                         -> ProgramSearchPath -> IO (Maybe FilePath)+guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram++guessC2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity+                       -> ProgramSearchPath -> IO (Maybe FilePath)+guessC2hsFromGhcjsPath = guessToolFromGhcjsPath c2hsProgram++guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity+                          -> ProgramSearchPath -> IO (Maybe FilePath)+guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram++guessToolFromGhcjsPath :: Program -> ConfiguredProgram+                       -> Verbosity -> ProgramSearchPath+                       -> IO (Maybe FilePath)+guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath+  = do let toolname          = programName tool+           path              = programPath ghcjsProg+           dir               = takeDirectory path+           versionSuffix     = takeVersionSuffix (dropExeExtension path)+           guessNormal       = dir </> toolname <.> exeExtension+           guessGhcjsVersioned = dir </> (toolname ++ "-ghcjs" ++ versionSuffix)+                                 <.> exeExtension+           guessGhcjs        = dir </> (toolname ++ "-ghcjs")+                               <.> exeExtension+           guessVersioned    = dir </> (toolname ++ versionSuffix) <.> exeExtension+           guesses | null versionSuffix = [guessGhcjs, guessNormal]+                   | otherwise          = [guessGhcjsVersioned,+                                           guessGhcjs,+                                           guessVersioned,+                                           guessNormal]+       info verbosity $ "looking for tool " ++ toolname+         ++ " near compiler in " ++ dir+       exists <- mapM doesFileExist guesses+       case [ file | (file, True) <- zip guesses exists ] of+                   -- If we can't find it near ghc, fall back to the usual+                   -- method.+         []     -> programFindLocation tool verbosity searchpath+         (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp+                      return (Just fp)++  where takeVersionSuffix :: FilePath -> String+        takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") .+                            reverse++        dropExeExtension :: FilePath -> FilePath+        dropExeExtension filepath =+          case splitExtension filepath of+            (filepath', extension) | extension == exeExtension -> filepath'+                                   | otherwise                 -> filepath+++-- | Given a single package DB, return all installed packages.+getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration+                     -> IO InstalledPackageIndex+getPackageDBContents verbosity packagedb conf = do+  pkgss <- getInstalledPackages' verbosity [packagedb] conf+  toPackageIndex verbosity pkgss conf++-- | Given a package DB stack, return all installed packages.+getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration+                     -> IO InstalledPackageIndex+getInstalledPackages verbosity packagedbs conf = do+  checkPackageDbEnvVar+  checkPackageDbStack packagedbs+  pkgss <- getInstalledPackages' verbosity packagedbs conf+  index <- toPackageIndex verbosity pkgss conf+  return $! index++toPackageIndex :: Verbosity+               -> [(PackageDB, [InstalledPackageInfo])]+               -> ProgramConfiguration+               -> IO InstalledPackageIndex+toPackageIndex verbosity pkgss conf = 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.+  topDir <- getLibDir' verbosity ghcjsProg+  let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)+                | (_, pkgs) <- pkgss ]+  return $! (mconcat indices)++  where+    Just ghcjsProg = lookupProgram ghcjsProgram conf++checkPackageDbEnvVar :: IO ()+checkPackageDbEnvVar =+    Internal.checkPackageDbEnvVar "GHCJS" "GHCJS_PACKAGE_PATH"++checkPackageDbStack :: PackageDBStack -> IO ()+checkPackageDbStack (GlobalPackageDB:rest)+  | GlobalPackageDB `notElem` rest = return ()+checkPackageDbStack rest+  | GlobalPackageDB `notElem` rest =+  die $ "With current ghc versions the global package db is always used "+     ++ "and must be listed first. This ghc limitation may be lifted in "+     ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977"+checkPackageDbStack _ =+  die $ "If the global package db is specified, it must be "+     ++ "specified first and cannot be specified multiple times"++getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration+                      -> IO [(PackageDB, [InstalledPackageInfo])]+getInstalledPackages' verbosity packagedbs conf =+  sequence+    [ do pkgs <- HcPkg.dump (hcPkgInfo conf) verbosity packagedb+         return (packagedb, pkgs)+    | packagedb <- packagedbs ]++getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath+getLibDir verbosity lbi =+    (reverse . dropWhile isSpace . reverse) `fmap`+     rawSystemProgramStdoutConf verbosity ghcjsProgram+     (withPrograms lbi) ["--print-libdir"]++getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath+getLibDir' verbosity ghcjsProg =+    (reverse . dropWhile isSpace . reverse) `fmap`+     rawSystemProgramStdout 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"]++toJSLibName :: String -> String+toJSLibName lib+  | takeExtension lib `elem` [".dll",".dylib",".so"]+                              = replaceExtension lib "js_so"+  | takeExtension lib == ".a" = replaceExtension lib "js_a"+  | otherwise                 = lib <.> "js_a"++buildLib, replLib :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription+                  -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo+                  -> IO ()+buildLib = buildOrReplLib False+replLib  = buildOrReplLib True++buildOrReplLib :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)+               -> PackageDescription -> LocalBuildInfo+               -> Library            -> ComponentLocalBuildInfo -> IO ()+buildOrReplLib forRepl verbosity numJobs _pkg_descr lbi lib clbi = do+  let libName@(LibraryName cname) = componentLibraryName clbi+      libTargetDir = buildDir lbi+      whenVanillaLib forceVanilla =+        when (not forRepl && (forceVanilla || withVanillaLib lbi))+      whenProfLib = when (not forRepl && withProfLib lbi)+      whenSharedLib forceShared =+        when (not forRepl &&  (forceShared || withSharedLib lbi))+      whenGHCiLib = when (not forRepl && withGHCiLib lbi && withVanillaLib lbi)+      ifReplLib = when forRepl+      comp = compiler lbi+      implInfo = getImplInfo comp+      hole_insts = map (\(k,(p,n)) -> (k,(InstalledPackageInfo.packageKey p,n)))+                       (instantiatedWith lbi)+      nativeToo = ghcjsNativeToo comp++  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)+  let runGhcjsProg        = runGHC verbosity ghcjsProg comp+      libBi               = libBuildInfo lib+      isGhcjsDynamic      = isDynamic comp+      dynamicTooSupported = supportsDynamicToo comp+      doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi+      forceVanillaLib = doingTH && not isGhcjsDynamic+      forceSharedLib  = doingTH &&     isGhcjsDynamic+      -- TH always needs default libs, even when building for profiling++  -- Determine if program coverage should be enabled and if so, what+  -- '-hpcdir' should be.+  let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi+      distPref = fromFlag $ configDistPref $ configFlags lbi+      hpcdir way+        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname+        | otherwise = mempty++  createDirectoryIfMissingVerbose verbosity True libTargetDir+  -- TODO: do we need to put hs-boot files into place for mutually recursive+  -- modules?+  let cObjs       = map (`replaceExtension` objExtension) (cSources libBi)+      jsSrcs      = jsSources libBi+      baseOpts    = componentGhcOptions verbosity lbi libBi clbi libTargetDir+      linkJsLibOpts = mempty {+                        ghcOptExtra = toNubListR $+                          [ "-link-js-lib"     , getHSLibraryName libName+                          , "-js-lib-outputdir", libTargetDir ] +++                          concatMap (\x -> ["-js-lib-src",x]) jsSrcs+                      }+      vanillaOptsNoJsLib = baseOpts `mappend` mempty {+                      ghcOptMode         = toFlag GhcModeMake,+                      ghcOptNumJobs      = numJobs,+                      ghcOptSigOf        = hole_insts,+                      ghcOptInputModules = toNubListR $ libModules lib,+                      ghcOptHPCDir       = hpcdir Hpc.Vanilla+                    }+      vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts++      profOpts    = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty {+                        ghcOptProfilingMode = toFlag True,+                        ghcOptExtra         = toNubListR $+                                              ghcjsProfOptions libBi,+                        ghcOptHPCDir        = hpcdir Hpc.Prof+                      }+      sharedOpts  = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty {+                        ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                        ghcOptFPic        = toFlag True,+                        ghcOptExtra       = toNubListR $+                                            ghcjsSharedOptions libBi,+                        ghcOptHPCDir      = hpcdir Hpc.Dyn+                      }+      linkerOpts = mempty {+                      ghcOptLinkOptions    = toNubListR $ PD.ldOptions libBi,+                      ghcOptLinkLibs       = toNubListR $ extraLibs libBi,+                      ghcOptLinkLibPath    = toNubListR $ extraLibDirs libBi,+                      ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi,+                      ghcOptInputFiles     =+                        toNubListR $ [libTargetDir </> x | x <- cObjs] ++ jsSrcs+                   }+      replOpts    = vanillaOptsNoJsLib {+                      ghcOptExtra        = overNubListR+                                           Internal.filterGhciFlags+                                           (ghcOptExtra vanillaOpts),+                      ghcOptNumJobs      = mempty+                    }+                    `mappend` linkerOpts+                    `mappend` mempty {+                      ghcOptMode         = toFlag GhcModeInteractive,+                      ghcOptOptimisation = toFlag GhcNoOptimisation+                    }++      vanillaSharedOpts = vanillaOpts `mappend`+                            mempty {+                              ghcOptDynLinkMode  = toFlag GhcStaticAndDynamic,+                              ghcOptDynHiSuffix  = toFlag "dyn_hi",+                              ghcOptDynObjSuffix = toFlag "dyn_o",+                              ghcOptHPCDir       = hpcdir Hpc.Dyn+                            }++  unless (forRepl || (null (libModules lib) && null jsSrcs && null cObjs)) $+    do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts)+           shared  = whenSharedLib  forceSharedLib  (runGhcjsProg sharedOpts)+           useDynToo = dynamicTooSupported &&+                       (forceVanillaLib || withVanillaLib lbi) &&+                       (forceSharedLib  || withSharedLib  lbi) &&+                       null (ghcjsSharedOptions libBi)+       if useDynToo+          then do+              runGhcjsProg vanillaSharedOpts+              case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of+                (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> do+                    -- When the vanilla and shared library builds are done+                    -- in one pass, only one set of HPC module interfaces+                    -- are generated. This set should suffice for both+                    -- static and dynamically linked executables. We copy+                    -- the modules interfaces so they are available under+                    -- both ways.+                    copyDirectoryRecursive verbosity dynDir vanillaDir+                _ -> return ()+          else if isGhcjsDynamic+            then do shared;  vanilla+            else do vanilla; shared+       whenProfLib (runGhcjsProg profOpts)++  -- build any C sources+  unless (null (cSources libBi) || not nativeToo) $ do+     info verbosity "Building C Sources..."+     sequence_+       [ do let vanillaCcOpts =+                  (Internal.componentCcGhcOptions verbosity implInfo+                     lbi libBi clbi libTargetDir filename)+                profCcOpts    = vanillaCcOpts `mappend` mempty {+                                  ghcOptProfilingMode = toFlag True,+                                  ghcOptObjSuffix     = toFlag "p_o"+                                }+                sharedCcOpts  = vanillaCcOpts `mappend` mempty {+                                  ghcOptFPic        = toFlag True,+                                  ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                                  ghcOptObjSuffix   = toFlag "dyn_o"+                                }+                odir          = fromFlag (ghcOptObjDir vanillaCcOpts)+            createDirectoryIfMissingVerbose verbosity True odir+            runGhcjsProg vanillaCcOpts+            whenSharedLib forceSharedLib (runGhcjsProg sharedCcOpts)+            whenProfLib (runGhcjsProg profCcOpts)+       | filename <- cSources libBi]++  -- 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)) $+     ifReplLib (runGhcjsProg replOpts)++  -- link:+  when (nativeToo && not forRepl) $ do+    info verbosity "Linking..."+    let cProfObjs   = map (`replaceExtension` ("p_" ++ objExtension))+                      (cSources libBi)+        cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))+                      (cSources libBi)+        cid = compilerId (compiler lbi)+        vanillaLibFilePath = libTargetDir </> mkLibName            libName+        profileLibFilePath = libTargetDir </> mkProfLibName        libName+        sharedLibFilePath  = libTargetDir </> mkSharedLibName cid  libName+        ghciLibFilePath    = libTargetDir </> Internal.mkGHCiLibName libName++    hObjs     <- Internal.getHaskellObjects implInfo lib lbi+                      libTargetDir objExtension True+    hProfObjs <-+      if (withProfLib lbi)+              then Internal.getHaskellObjects implInfo lib lbi+                      libTargetDir ("p_" ++ objExtension) True+              else return []+    hSharedObjs <-+      if (withSharedLib lbi)+              then Internal.getHaskellObjects implInfo lib lbi+                      libTargetDir ("dyn_" ++ objExtension) False+              else return []++    unless (null hObjs && null cObjs) $ do++      let staticObjectFiles =+                 hObjs+              ++ map (libTargetDir </>) cObjs+          profObjectFiles =+                 hProfObjs+              ++ map (libTargetDir </>) cProfObjs+          ghciObjFiles =+                 hObjs+              ++ map (libTargetDir </>) cObjs+          dynamicObjectFiles =+                 hSharedObjs+              ++ map (libTargetDir </>) cSharedObjs+          -- After the relocation lib is created we invoke ghc -shared+          -- with the dependencies spelled out as -package arguments+          -- and ghc invokes the linker with the proper library paths+          ghcSharedLinkArgs =+              mempty {+                ghcOptShared             = toFlag True,+                ghcOptDynLinkMode        = toFlag GhcDynamicOnly,+                ghcOptInputFiles         = toNubListR dynamicObjectFiles,+                ghcOptOutputFile         = toFlag sharedLibFilePath,+                ghcOptNoAutoLinkPackages = toFlag True,+                ghcOptPackageDBs         = withPackageDB lbi,+                ghcOptPackages           = toNubListR $+                                           Internal.mkGhcOptPackages clbi,+                ghcOptLinkLibs           = toNubListR $ extraLibs libBi,+                ghcOptLinkLibPath        = toNubListR $ extraLibDirs libBi+              }++      whenVanillaLib False $ do+        Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles++      whenProfLib $ do+        Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles++      whenGHCiLib $ do+        (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)+        Ld.combineObjectFiles verbosity ldProg+          ghciLibFilePath ghciObjFiles++      whenSharedLib False $+        runGhcjsProg ghcSharedLinkArgs++-- | Start a REPL without loading any source files.+startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler+                 -> PackageDBStack -> IO ()+startInterpreter verbosity conf comp packageDBs = do+  let replOpts = mempty {+        ghcOptMode       = toFlag GhcModeInteractive,+        ghcOptPackageDBs = packageDBs+        }+  checkPackageDbStack packageDBs+  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram conf+  runGHC verbosity ghcjsProg comp replOpts++buildExe, replExe :: Verbosity          -> Cabal.Flag (Maybe Int)+                  -> PackageDescription -> LocalBuildInfo+                  -> Executable         -> ComponentLocalBuildInfo -> IO ()+buildExe = buildOrReplExe False+replExe  = buildOrReplExe True++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++  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)+  let comp         = compiler lbi+      implInfo     = getImplInfo comp+      runGhcjsProg = runGHC verbosity ghcjsProg comp+      exeBi        = buildInfo exe++  -- exeNameReal, the name that GHC really uses (with .exe on Windows)+  let exeNameReal = exeName' <.>+                    (if takeExtension exeName' /= ('.':exeExtension)+                       then exeExtension+                       else "")++  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+  -- 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+      distPref = fromFlag $ configDistPref $ configFlags lbi+      hpcdir way+        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName'+        | otherwise = mempty++  -- build executables++  srcMainFile         <- findFile (exeDir : hsSourceDirs exeBi) modPath+  let isGhcjsDynamic      = isDynamic comp+      dynamicTooSupported = supportsDynamicToo comp+      buildRunner = case clbi of+                       ExeComponentLocalBuildInfo {} -> False+                       _                             -> True+      isHaskellMain = elem (takeExtension srcMainFile) [".hs", ".lhs"]+      jsSrcs        = jsSources exeBi+      cSrcs         = cSources exeBi ++ [srcMainFile | not isHaskellMain]+      cObjs         = map (`replaceExtension` objExtension) cSrcs+      nativeToo     = ghcjsNativeToo comp+      baseOpts   = (componentGhcOptions verbosity lbi exeBi clbi exeDir)+                    `mappend` mempty {+                      ghcOptMode         = toFlag GhcModeMake,+                      ghcOptInputFiles   = toNubListR $+                        [ srcMainFile | isHaskellMain],+                      ghcOptInputModules = toNubListR $+                        [ m | not isHaskellMain, m <- exeModules exe],+                      ghcOptExtra =+                        if buildRunner then toNubListR ["-build-runner"]+                                       else mempty+                    }+      staticOpts = baseOpts `mappend` mempty {+                      ghcOptDynLinkMode    = toFlag GhcStaticOnly,+                      ghcOptHPCDir         = hpcdir Hpc.Vanilla+                   }+      profOpts   = adjustExts "p_hi" "p_o" baseOpts `mappend` mempty {+                      ghcOptProfilingMode  = toFlag True,+                      ghcOptExtra          = toNubListR $ ghcjsProfOptions exeBi,+                      ghcOptHPCDir         = hpcdir Hpc.Prof+                    }+      dynOpts    = adjustExts "dyn_hi" "dyn_o" baseOpts `mappend` mempty {+                      ghcOptDynLinkMode    = toFlag GhcDynamicOnly,+                      ghcOptExtra          = toNubListR $+                                             ghcjsSharedOptions exeBi,+                      ghcOptHPCDir         = hpcdir Hpc.Dyn+                    }+      dynTooOpts = adjustExts "dyn_hi" "dyn_o" staticOpts `mappend` mempty {+                      ghcOptDynLinkMode    = toFlag GhcStaticAndDynamic,+                      ghcOptHPCDir         = hpcdir Hpc.Dyn+                    }+      linkerOpts = mempty {+                      ghcOptLinkOptions    = toNubListR $ PD.ldOptions exeBi,+                      ghcOptLinkLibs       = toNubListR $ extraLibs exeBi,+                      ghcOptLinkLibPath    = toNubListR $ extraLibDirs exeBi,+                      ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi,+                      ghcOptInputFiles     = toNubListR $+                                             [exeDir </> x | x <- cObjs] ++ jsSrcs+                   }+      replOpts   = baseOpts {+                      ghcOptExtra          = overNubListR+                                             Internal.filterGhciFlags+                                             (ghcOptExtra baseOpts)+                   }+                   -- For a normal compile we do separate invocations of ghc for+                   -- compiling as for linking. But for repl we have to do just+                   -- the one invocation, so that one has to include all the+                   -- linker stuff too, like -l flags and any .o files from C+                   -- files etc.+                   `mappend` linkerOpts+                   `mappend` mempty {+                      ghcOptMode           = toFlag GhcModeInteractive,+                      ghcOptOptimisation   = toFlag GhcNoOptimisation+                   }+      commonOpts  | withProfExe lbi = profOpts+                  | withDynExe  lbi = dynOpts+                  | otherwise       = staticOpts+      compileOpts | useDynToo = dynTooOpts+                  | otherwise = commonOpts+      withStaticExe = (not $ withProfExe lbi) && (not $ withDynExe lbi)++      -- 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+      -- -prof/-dynamic. This is because the code that TH needs to run at+      -- compile time needs to be the vanilla ABI so it can be loaded up and run+      -- 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+      -- Should we use -dynamic-too instead of compiling twice?+      useDynToo = dynamicTooSupported && isGhcjsDynamic+                  && doingTH && withStaticExe && null (ghcjsSharedOptions exeBi)+      compileTHOpts | isGhcjsDynamic = dynOpts+                    | otherwise      = staticOpts+      compileForTH+        | forRepl      = False+        | useDynToo    = False+        | isGhcjsDynamic = doingTH && (withProfExe lbi || withStaticExe)+        | otherwise      = doingTH && (withProfExe lbi || withDynExe lbi)++      linkOpts = commonOpts `mappend`+                 linkerOpts `mappend` mempty {+                      ghcOptLinkNoHsMain   = toFlag (not isHaskellMain)+                 }++  -- Build static/dynamic object files for TH, if needed.+  when compileForTH $+    runGhcjsProg compileTHOpts { ghcOptNoLink  = toFlag True+                               , ghcOptNumJobs = numJobs }++  unless forRepl $+    runGhcjsProg compileOpts { ghcOptNoLink  = toFlag True+                             , ghcOptNumJobs = numJobs }++  -- build any C sources+  unless (null cSrcs || not nativeToo) $ 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)+          createDirectoryIfMissingVerbose verbosity True odir+          runGhcjsProg opts+     | filename <- cSrcs ]++  -- 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 $ runGhcjsProg replOpts++  -- link:+  unless forRepl $ do+    info verbosity "Linking..."+    runGhcjsProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }++-- |Install for ghc, .hi, .a and, if --with-ghci given, .o+installLib    :: Verbosity+              -> LocalBuildInfo+              -> FilePath  -- ^install location+              -> FilePath  -- ^install location for dynamic libraries+              -> FilePath  -- ^Build location+              -> PackageDescription+              -> Library+              -> ComponentLocalBuildInfo+              -> IO ()+installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do+  whenVanilla $ copyModuleFiles "js_hi"+  whenProf    $ copyModuleFiles "js_p_hi"+  whenShared  $ copyModuleFiles "js_dyn_hi"++  whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName+  whenProf    $ installOrdinary builtDir targetDir $ toJSLibName profileLibName+  whenShared  $ installShared   builtDir dynlibTargetDir $ toJSLibName sharedLibName++  when (ghcjsNativeToo $ compiler lbi) $ do+    -- copy .hi files over:+    whenVanilla $ copyModuleFiles "hi"+    whenProf    $ copyModuleFiles "p_hi"+    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++  where+    install isShared srcDir dstDir name = do+      let src = srcDir </> name+          dst = dstDir </> name+      createDirectoryIfMissingVerbose verbosity True dstDir++      if isShared+        then installExecutableFile verbosity src dst+        else installOrdinaryFile   verbosity src dst++      when (stripLibs lbi) $ Strip.stripLib verbosity+                             (hostPlatform lbi) (withPrograms lbi) dst++    installOrdinary = install False+    installShared   = install True++    copyModuleFiles ext =+      findModuleFiles [builtDir] [ext] (libModules lib)+      >>= installOrdinaryFiles verbosity targetDir++    cid = compilerId (compiler lbi)+    libName = componentLibraryName clbi+    vanillaLibName = mkLibName              libName+    profileLibName = mkProfLibName          libName+    ghciLibName    = Internal.mkGHCiLibName libName+    sharedLibName  = (mkSharedLibName cid)  libName++    hasLib    = not $ null (libModules lib)+                   && null (cSources (libBuildInfo lib))+    whenVanilla = when (hasLib && withVanillaLib lbi)+    whenProf    = when (hasLib && withProfLib    lbi)+    whenGHCi    = when (hasLib && withGHCiLib    lbi)+    whenShared  = when (hasLib && withSharedLib  lbi)++installExe :: Verbosity+              -> LocalBuildInfo+              -> InstallDirs FilePath -- ^Where to copy the files to+              -> FilePath  -- ^Build location+              -> (FilePath, FilePath)  -- ^Executable (prefix,suffix)+              -> PackageDescription+              -> Executable+              -> IO ()+installExe verbosity lbi installDirs buildPref+           (progprefix, progsuffix) _pkg exe = do+  let binDir = bindir installDirs+  createDirectoryIfMissingVerbose verbosity True binDir+  let exeFileName = exeName exe+      fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix+      installBinary dest = do+        rawSystemProgramConf verbosity ghcjsProgram (withPrograms lbi) $+          [ "--install-executable"+          , buildPref </> exeName exe </> exeFileName+          , "-o", dest+          ] +++          case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of+           (True, Just strip) -> ["-strip-program", programPath strip]+           _                  -> []+  installBinary (binDir </> fixedExeBaseName)++libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo+           -> Library -> ComponentLocalBuildInfo -> IO String+libAbiHash verbosity _pkg_descr lbi lib clbi = do+  let+      libBi       = libBuildInfo lib+      comp        = compiler lbi+      vanillaArgs =+        (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))+        `mappend` mempty {+          ghcOptMode         = toFlag GhcModeAbiHash,+          ghcOptInputModules = toNubListR $ exposedModules lib+        }+      profArgs = adjustExts "js_p_hi" "js_p_o" vanillaArgs `mappend` mempty {+                     ghcOptProfilingMode = toFlag True,+                     ghcOptExtra         = toNubListR (ghcjsProfOptions libBi)+                 }+      ghcArgs = if withVanillaLib lbi then vanillaArgs+           else if withProfLib    lbi then profArgs+           else error "libAbiHash: Can't find an enabled library way"+  --+  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)+  getProgramInvocationOutput verbosity (ghcInvocation ghcjsProg comp ghcArgs)++adjustExts :: String -> String -> GhcOptions -> GhcOptions+adjustExts hiSuf objSuf opts =+  opts `mappend` mempty {+    ghcOptHiSuffix  = toFlag hiSuf,+    ghcOptObjSuffix = toFlag objSuf+  }++registerPackage :: Verbosity+                -> InstalledPackageInfo+                -> PackageDescription+                -> LocalBuildInfo+                -> Bool+                -> PackageDBStack+                -> IO ()+registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs =+  HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity packageDbs+    (Right installedPkgInfo)++componentGhcOptions :: Verbosity -> LocalBuildInfo+                    -> BuildInfo -> ComponentLocalBuildInfo -> FilePath+                    -> GhcOptions+componentGhcOptions verbosity lbi bi clbi odir =+  let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir+  in  opts { ghcOptExtra = ghcOptExtra opts `mappend` toNubListR+                             (hcOptions GHCJS bi)+           }++ghcjsProfOptions :: BuildInfo -> [String]+ghcjsProfOptions bi =+  hcProfOptions GHC bi `mappend` hcProfOptions GHCJS bi++ghcjsSharedOptions :: BuildInfo -> [String]+ghcjsSharedOptions bi =+  hcSharedOptions GHC bi `mappend` hcSharedOptions GHCJS bi++isDynamic :: Compiler -> Bool+isDynamic = Internal.ghcLookupProperty "GHC Dynamic"++supportsDynamicToo :: Compiler -> Bool+supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"++findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version)+findGhcjsGhcVersion verbosity pgm =+  findProgramVersion "--numeric-ghc-version" id verbosity pgm++findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version)+findGhcjsPkgGhcjsVersion verbosity pgm =+  findProgramVersion "--numeric-ghcjs-version" id verbosity pgm++-- -----------------------------------------------------------------------------+-- Registering++hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo+hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = ghcjsPkgProg+                                 , HcPkg.noPkgDbStack    = False+                                 , HcPkg.noVerboseFlag   = False+                                 , HcPkg.flagPackageConf = False+                                 , HcPkg.useSingleFileDb = v < [7,9]+                                 }+  where+    v                 = versionBranch ver+    Just ghcjsPkgProg = lookupProgram ghcjsPkgProgram conf+    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+            -> (FilePath, FilePath, [String])+runCmd conf exe =+  ( script+  , programPath ghcjsProg+  , programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"]+  )+  where+    script = exe <.> "jsexe" </> "all" <.> "js"+    Just ghcjsProg = lookupProgram ghcjsProgram conf

cabal/Cabal/Distribution/Simple/Haddock.hs view

@@ -2,95 +2,69 @@ -- | -- Module      :  Distribution.Simple.Haddock -- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable ----- This module deals with the @haddock@ and @hscolour@ commands. Sadly this is a--- rather complicated module. It deals with two versions of haddock (0.x and--- 2.x). It has to do pre-processing which involves \'unlit\'ing and using--- @-D__HADDOCK__@ for any source code that uses @cpp@. It uses information--- about installed packages (from @ghc-pkg@) to find the locations of--- documentation for dependent packages, so it can create links.+-- This module deals with the @haddock@ and @hscolour@ commands.+-- It uses information about installed packages (from @ghc-pkg@) to find the+-- locations of documentation for dependent packages, so it can create links. ----- The @hscolour@ support allows generating html versions of the original+-- The @hscolour@ support allows generating HTML versions of the original -- source, with coloured syntax highlighting. -{- 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. -}- module Distribution.Simple.Haddock (-  haddock, hscolour+  haddock, hscolour,++  haddockPackagePaths   ) where +import qualified Distribution.Simple.GHC   as GHC+import qualified Distribution.Simple.GHCJS as GHCJS+ -- local import Distribution.Package          ( PackageIdentifier(..)          , Package(..)-         , PackageName(..), packageName )+         , PackageName(..), packageName, LibraryName(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..), allExtensions+         ( PackageDescription(..), BuildInfo(..), usedExtensions+         , hcSharedOptions          , Library(..), hasLibs, Executable(..)          , TestSuite(..), TestSuiteInterface(..)          , Benchmark(..), BenchmarkInterface(..) ) import Distribution.Simple.Compiler-         ( Compiler(..), compilerVersion )-import Distribution.Simple.GHC ( componentGhcOptions, ghcLibDir )+         ( Compiler, compilerInfo, CompilerFlavor(..)+         , compilerFlavor, compilerCompatVersion ) import Distribution.Simple.Program.GHC          ( GhcOptions(..), GhcDynLinkMode(..), renderGhcOptions ) import Distribution.Simple.Program-         ( ConfiguredProgram(..), requireProgramVersion+         ( ConfiguredProgram(..), lookupProgramVersion, requireProgramVersion          , rawSystemProgram, rawSystemProgramStdout          , hscolourProgram, haddockProgram )-import Distribution.Simple.PreProcess (ppCpp', ppUnlit-                                      , PPSuffixHandler, runSimplePreProcessor-                                      , preprocessComponent)+import Distribution.Simple.PreProcess+         ( PPSuffixHandler, preprocessComponent) import Distribution.Simple.Setup-        ( defaultHscolourFlags, Flag(..), toFlag, flagToMaybe, flagToList, fromFlag-        , HaddockFlags(..), HscolourFlags(..) )+         ( defaultHscolourFlags+         , Flag(..), toFlag, flagToMaybe, flagToList, fromFlag+         , HaddockFlags(..), HscolourFlags(..) ) import Distribution.Simple.Build (initialBuildSteps)-import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplateEnv, PathTemplate,-                                        PathTemplateVariable(..),-                                        toPathTemplate, fromPathTemplate,-                                        substPathTemplate, initialPathTemplateEnv)+import Distribution.Simple.InstallDirs+         ( InstallDirs(..)+         , PathTemplateEnv, PathTemplate, PathTemplateVariable(..)+         , toPathTemplate, fromPathTemplate+         , substPathTemplate, initialPathTemplateEnv ) import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)          , withAllComponentsInBuildOrder )-import Distribution.Simple.BuildPaths ( haddockName,-                                        hscolourPref, autogenModulesDir,-                                        )+import Distribution.Simple.BuildPaths+         ( haddockName, hscolourPref, autogenModulesDir) import Distribution.Simple.PackageIndex (dependencyClosure) import qualified Distribution.Simple.PackageIndex as PackageIndex import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-         ( InstalledPackageInfo_(..) )+         ( InstalledPackageInfo(..) ) import Distribution.InstalledPackageInfo          ( InstalledPackageInfo ) import Distribution.Simple.Utils@@ -102,45 +76,65 @@          , findFileWithExtension, findFile ) import Distribution.Text          ( display, simpleParse )+import Distribution.Utils.NubList+         ( toNubListR )  import Distribution.Verbosity import Language.Haskell.Extension--- Base-import System.Directory(removeFile, doesFileExist, createDirectoryIfMissing) -import Control.Monad ( when, guard, forM_ )-import Control.Exception (assert)++import Control.Monad    ( when, forM_ )+import Data.Either      ( rights )+import Data.Foldable    ( traverse_ ) import Data.Monoid-import Data.Maybe    ( fromMaybe, listToMaybe )+import Data.Maybe       ( fromMaybe, listToMaybe ) -import System.FilePath((</>), (<.>), splitFileName, splitExtension,-                       normalise, splitPath, joinPath, isAbsolute )-import System.IO (hClose, hPutStrLn)+import System.Directory (doesFileExist)+import System.FilePath  ( (</>), (<.>)+                        , normalise, splitPath, joinPath, isAbsolute )+import System.IO        (hClose, hPutStrLn, hSetEncoding, utf8) import Distribution.Version +-- ------------------------------------------------------------------------------ -- Types --- | record that represents the arguments to the haddock executable, a product monoid.+-- | A record that represents the arguments to the haddock executable, a product+-- monoid. data HaddockArgs = HaddockArgs {- argInterfaceFile :: Flag FilePath,               -- ^ path of the interface file, relative to argOutputDir, required.- argPackageName :: Flag PackageIdentifier,        -- ^ package name,                                         required.- argHideModules :: (All,[ModuleName.ModuleName]), -- ^ (hide modules ?, modules to hide)- argIgnoreExports :: Any,                         -- ^ ingore export lists in modules?- argLinkSource :: Flag (Template,Template),       -- ^ (template for modules, template for symbols)- argCssFile :: Flag FilePath,                     -- ^ optinal custom css file.- argContents :: Flag String,                      -- ^ optional url to contents page+ argInterfaceFile :: Flag FilePath,+ -- ^ Path to the interface file, relative to argOutputDir, required.+ argPackageName :: Flag PackageIdentifier,+ -- ^ Package name, required.+ argHideModules :: (All,[ModuleName.ModuleName]),+ -- ^ (Hide modules ?, modules to hide)+ argIgnoreExports :: Any,+ -- ^ Ignore export lists in modules?+ argLinkSource :: Flag (Template,Template,Template),+ -- ^ (Template for modules, template for symbols, template for lines).+ argCssFile :: Flag FilePath,+ -- ^ Optional custom CSS file.+ argContents :: Flag String,+ -- ^ Optional URL to contents page.  argVerbose :: Any,- argOutput :: Flag [Output],                      -- ^ Html or Hoogle doc or both?                                   required.- argInterfaces :: [(FilePath, Maybe String)],     -- ^ [(interface file, URL to the html docs for links)]- argOutputDir :: Directory,                       -- ^ where to generate the documentation.- argTitle :: Flag String,                         -- ^ page's title,                                         required.- argPrologue :: Flag String,                      -- ^ prologue text,                                        required.- argGhcOptions :: Flag (GhcOptions, Version),     -- ^ additional flags to pass to ghc for haddock-2- argGhcLibDir :: Flag FilePath,                   -- ^ to find the correct ghc,                              required by haddock-2.- argTargets :: [FilePath]                         -- ^ modules to process.+ argOutput :: Flag [Output],+ -- ^ HTML or Hoogle doc or both? Required.+ argInterfaces :: [(FilePath, Maybe String)],+ -- ^ [(Interface file, URL to the HTML docs for links)].+ argOutputDir :: Directory,+ -- ^ Where to generate the documentation.+ argTitle :: Flag String,+ -- ^ Page title, required.+ argPrologue :: Flag String,+ -- ^ Prologue text, required.+ argGhcOptions :: Flag (GhcOptions, Version),+ -- ^ Additional flags to pass to GHC.+ argGhcLibDir :: Flag FilePath,+ -- ^ To find the correct GHC, required.+ argTargets :: [FilePath]+ -- ^ Modules to process. } --- | the FilePath of a directory, it's a monoid under (</>)+-- | The FilePath of a directory, it's a monoid under '(</>)'. newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord)  unDir :: Directory -> FilePath@@ -150,10 +144,14 @@  data Output = Html | Hoogle --- --------------------------------------------------------------------------+-- ------------------------------------------------------------------------------ -- Haddock support -haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO ()+haddock :: PackageDescription+        -> LocalBuildInfo+        -> [PPSuffixHandler]+        -> HaddockFlags+        -> IO () haddock pkg_descr _ _ haddockFlags   |    not (hasLibs pkg_descr)     && not (fromFlag $ haddockExecutables haddockFlags)@@ -165,45 +163,38 @@         ++ " --benchmarks flags."  haddock pkg_descr lbi suffixes flags = do-     setupMessage verbosity "Running Haddock for" (packageId pkg_descr)     (confHaddock, version, _) <-       requireProgramVersion verbosity haddockProgram-        (orLaterVersion (Version [0,6] [])) (withPrograms lbi)+        (orLaterVersion (Version [2,0] [])) (withPrograms lbi)      -- various sanity checks-    let isVersion2   = version >= Version [2,0] []-     when ( flag haddockHoogle-           && version > Version [2] []            && version < Version [2,2] []) $          die "haddock 2.0 and 2.1 do not support the --hoogle flag." -    when (flag haddockHscolour && version < Version [0,8] []) $-         die "haddock --hyperlink-source requires Haddock version 0.8 or later"--    when isVersion2 $ do-      haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock-                                ["--ghc-version"]-      case simpleParse haddockGhcVersionStr of-        Nothing -> die "Could not get GHC version from Haddock"-        Just haddockGhcVersion-          | haddockGhcVersion == ghcVersion -> return ()-          | otherwise -> die $-                 "Haddock's internal GHC version must match the configured "-              ++ "GHC version.\n"-              ++ "The GHC version is " ++ display ghcVersion ++ " but "-              ++ "haddock is using GHC version " ++ display haddockGhcVersion-          where ghcVersion = compilerVersion comp+    haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock+                              ["--ghc-version"]+    case (simpleParse haddockGhcVersionStr, compilerCompatVersion GHC comp) of+      (Nothing, _) -> die "Could not get GHC version from Haddock"+      (_, Nothing) -> die "Could not get GHC version from compiler"+      (Just haddockGhcVersion, Just ghcVersion)+        | haddockGhcVersion == ghcVersion -> return ()+        | otherwise -> die $+               "Haddock's internal GHC version must match the configured "+            ++ "GHC version.\n"+            ++ "The GHC version is " ++ display ghcVersion ++ " but "+            ++ "haddock is using GHC version " ++ display haddockGhcVersion      -- the tools match the requests, we can proceed      initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity -    when (flag haddockHscolour) $ hscolour' pkg_descr lbi suffixes $-         defaultHscolourFlags `mappend` haddockToHscolour flags+    when (flag haddockHscolour) $+      hscolour' (warn verbosity) pkg_descr lbi suffixes+      (defaultHscolourFlags `mappend` haddockToHscolour flags) -    libdirArgs <- getGhcLibDir  verbosity lbi isVersion2+    libdirArgs <- getGhcLibDir  verbosity lbi     let commonArgs = mconcat             [ libdirArgs             , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags@@ -215,24 +206,24 @@       let         doExe com = case (compToExe com) of           Just exe -> do-            withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do-              let bi = buildInfo exe-              exeArgs  <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate-              exeArgs' <- prepareSources verbosity tmp-                            lbi version bi (commonArgs `mappend` exeArgs)-              runHaddock verbosity tmpFileOpts comp confHaddock exeArgs'+            withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $+              \tmp -> do+                exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate+                           version+                let exeArgs' = commonArgs `mappend` exeArgs+                runHaddock verbosity tmpFileOpts comp confHaddock exeArgs'           Nothing -> do            warn (fromFlag $ haddockVerbosity flags)              "Unsupported component, skipping..."            return ()       case component of         CLib lib -> do-          withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do-            let bi = libBuildInfo lib-            libArgs  <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate-            libArgs' <- prepareSources verbosity tmp-                          lbi version bi (commonArgs `mappend` libArgs)-            runHaddock verbosity tmpFileOpts comp confHaddock libArgs'+          withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $+            \tmp -> do+              libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate+                         version+              let libArgs' = commonArgs `mappend` libArgs+              runHaddock verbosity tmpFileOpts comp confHaddock libArgs'         CExe   _ -> when (flag haddockExecutables) $ doExe component         CTest  _ -> when (flag haddockTestSuites)  $ doExe component         CBench _ -> when (flag haddockBenchmarks)  $ doExe component@@ -246,66 +237,27 @@     comp          = compiler lbi     tmpFileOpts   = defaultTempFileOptions { optKeepTempFiles = keepTempFiles }     flag f        = fromFlag $ f flags-    htmlTemplate  = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags---- | performs cpp and unlit preprocessing where needed on the files in--- | argTargets, which must have an .hs or .lhs extension.-prepareSources :: Verbosity-                  -> FilePath-                  -> LocalBuildInfo-                  -> Version-                  -> BuildInfo-                  -> HaddockArgs-                  -> IO HaddockArgs-prepareSources verbosity tmp lbi haddockVersion bi args@HaddockArgs{argTargets=files} =-              mapM (mockPP tmp) files >>= \targets -> return args {argTargets=targets}-          where-            mockPP pref file = do-                 let (filePref, fileName) = splitFileName file-                     targetDir  = pref </> filePref-                     targetFile = targetDir </> fileName-                     (targetFileNoext, targetFileExt) = splitExtension $ targetFile-                     hsFile = targetFileNoext <.> "hs"--                 assert (targetFileExt `elem` [".lhs",".hs"]) $ return ()--                 createDirectoryIfMissing True targetDir--                 if needsCpp-                    then do-                      runSimplePreProcessor (ppCpp' defines bi lbi)-                                            file targetFile verbosity-                    else-                      copyFileVerbose verbosity file targetFile--                 when (targetFileExt == ".lhs") $ do-                     runSimplePreProcessor ppUnlit targetFile hsFile verbosity-                     removeFile targetFile--                 return hsFile-            needsCpp             = EnableExtension CPP `elem` allExtensions bi-            isVersion2           = haddockVersion >= Version [2,0] []-            defines | isVersion2 = [haddockVersionMacro]-                    | otherwise  = ["-D__HADDOCK__", haddockVersionMacro]-            haddockVersionMacro  = "-D__HADDOCK_VERSION__="-                                   ++ show (v1 * 1000 + v2 * 10 + v3)-              where-                [v1, v2, v3] = take 3 $ versionBranch haddockVersion ++ [0,0]+    htmlTemplate  = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation+                    $ flags ------------------------------------------------------------------------------------------------------ constributions to HaddockArgs+-- ------------------------------------------------------------------------------+-- Contributions to HaddockArgs.  fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs fromFlags env flags =     mempty {-      argHideModules = (maybe mempty (All . not) $ flagToMaybe (haddockInternal flags), mempty),+      argHideModules = (maybe mempty (All . not)+                        $ flagToMaybe (haddockInternal flags), mempty),       argLinkSource = if fromFlag (haddockHscolour flags)                                then Flag ("src/%{MODULE/./-}.html"-                                         ,"src/%{MODULE/./-}.html#%{NAME}")+                                         ,"src/%{MODULE/./-}.html#%{NAME}"+                                         ,"src/%{MODULE/./-}.html#line-%{LINE}")                                else NoFlag,       argCssFile = haddockCss flags,-      argContents = fmap (fromPathTemplate . substPathTemplate env) (haddockContents flags),-      argVerbose = maybe mempty (Any . (>= deafening)) . flagToMaybe $ haddockVerbosity flags,+      argContents = fmap (fromPathTemplate . substPathTemplate env)+                    (haddockContents flags),+      argVerbose = maybe mempty (Any . (>= deafening))+                   . flagToMaybe $ haddockVerbosity flags,       argOutput =           Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++                       [ Hoogle | Flag True <- [haddockHoogle flags] ]@@ -316,12 +268,13 @@  fromPackageDescription :: PackageDescription -> HaddockArgs fromPackageDescription pkg_descr =-      mempty {-                argInterfaceFile = Flag $ haddockName pkg_descr,-                argPackageName = Flag $ packageId $ pkg_descr,-                argOutputDir = Dir $ "doc" </> "html" </> display (packageName pkg_descr),-                argPrologue = Flag $ if null desc then synopsis pkg_descr else desc,-                argTitle = Flag $ showPkg ++ subtitle+      mempty { argInterfaceFile = Flag $ haddockName pkg_descr,+               argPackageName = Flag $ packageId $ pkg_descr,+               argOutputDir = Dir $ "doc" </> "html"+                              </> display (packageName pkg_descr),+               argPrologue = Flag $ if null desc then synopsis pkg_descr+                                    else desc,+               argTitle = Flag $ showPkg ++ subtitle              }       where         desc = PD.description pkg_descr@@ -329,12 +282,25 @@         subtitle | null (synopsis pkg_descr) = ""                  | otherwise                 = ": " ++ synopsis pkg_descr +componentGhcOptions :: Verbosity -> LocalBuildInfo+                 -> BuildInfo -> ComponentLocalBuildInfo -> FilePath+                 -> GhcOptions+componentGhcOptions verbosity lbi bi clbi odir =+  let f = case compilerFlavor (compiler lbi) of+            GHC   -> GHC.componentGhcOptions+            GHCJS -> GHCJS.componentGhcOptions+            _     -> error $+                       "Distribution.Simple.Haddock.componentGhcOptions:" +++                       "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+            -> Maybe PathTemplate -- ^ template for HTML location+            -> Version             -> IO HaddockArgs-fromLibrary verbosity tmp lbi lib clbi htmlTemplate = do+fromLibrary verbosity tmp lbi lib clbi htmlTemplate haddockVersion = do     inFiles <- map snd `fmap` getLibSourceFiles lbi lib     ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate     let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {@@ -342,22 +308,29 @@                           -- 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-                      }+                          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       = ghcSharedOptions bi+                         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"+            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))+     return ifaceArgs {       argHideModules = (mempty,otherModules $ bi),       argGhcOptions  = toFlag (opts, ghcVersion),@@ -365,14 +338,14 @@     }   where     bi = libBuildInfo lib-    ghcVersion = compilerVersion (compiler lbi)  fromExecutable :: Verbosity                -> FilePath                -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo-               -> Maybe PathTemplate -- ^ template for html location+               -> Maybe PathTemplate -- ^ template for HTML location+               -> Version                -> IO HaddockArgs-fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do+fromExecutable verbosity tmp lbi exe clbi htmlTemplate haddockVersion = do     inFiles <- map snd `fmap` getExeSourceFiles lbi exe     ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate     let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {@@ -383,19 +356,25 @@                           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       = ghcSharedOptions bi+                         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"+            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))+     return ifaceArgs {       argGhcOptions = toFlag (opts, ghcVersion),       argOutputDir  = Dir (exeName exe),@@ -404,7 +383,6 @@     }   where     bi = buildInfo exe-    ghcVersion = compilerVersion (compiler lbi)  compToExe :: Component -> Maybe Executable compToExe comp =@@ -427,27 +405,41 @@ getInterfaces :: Verbosity               -> LocalBuildInfo               -> ComponentLocalBuildInfo-              -> Maybe PathTemplate -- ^ template for html location+              -> Maybe PathTemplate -- ^ template for HTML location               -> IO HaddockArgs getInterfaces verbosity lbi clbi htmlTemplate = do     (packageFlags, warnings) <- haddockPackageFlags lbi clbi htmlTemplate-    maybe (return ()) (warn verbosity) warnings+    traverse_ (warn verbosity) warnings     return $ mempty {                  argInterfaces = packageFlags                } +getGhcCppOpts :: Version+              -> BuildInfo+              -> GhcOptions+getGhcCppOpts haddockVersion bi =+    mempty {+        ghcOptExtensions   = toNubListR [EnableExtension CPP | needsCpp],+        ghcOptCppOptions   = toNubListR defines+    }+  where+    needsCpp             = EnableExtension CPP `elem` usedExtensions bi+    defines              = [haddockVersionMacro]+    haddockVersionMacro  = "-D__HADDOCK_VERSION__="+                           ++ show (v1 * 1000 + v2 * 10 + v3)+      where+        [v1, v2, v3] = take 3 $ versionBranch haddockVersion ++ [0,0]+ getGhcLibDir :: Verbosity -> LocalBuildInfo-             -> Bool -- ^ are we using haddock-2.x ?              -> IO HaddockArgs-getGhcLibDir verbosity lbi isVersion2-    | isVersion2 =-        do l <- ghcLibDir verbosity lbi-           return $ mempty { argGhcLibDir = Flag l }-    | otherwise  =-        return mempty------------------------------------------------------------------------------------------------+getGhcLibDir verbosity lbi = do+    l <- case compilerFlavor (compiler lbi) of+            GHC   -> GHC.getLibDir   verbosity lbi+            GHCJS -> GHCJS.getLibDir verbosity lbi+            _     -> error "haddock only supports GHC and GHCJS"+    return $ mempty { argGhcLibDir = Flag l } +-- ------------------------------------------------------------------------------ -- | Call haddock with the specified arguments. runHaddock :: Verbosity               -> TempFileOptions@@ -474,15 +466,29 @@               -> (([String], FilePath) -> IO a)               -> IO a renderArgs verbosity tmpFileOpts version comp args k = do+  let haddockSupportsUTF8          = version >= Version [2,14,4] []+      haddockSupportsResponseFiles = version >  Version [2,16,1] []   createDirectoryIfMissingVerbose verbosity True outputDir-  withTempFileEx tmpFileOpts outputDir "haddock-prolog.txt" $ \prologFileName h -> do+  withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $+    \prologueFileName h -> do           do+             when haddockSupportsUTF8 (hSetEncoding h utf8)              hPutStrLn h $ fromFlag $ argPrologue args              hClose h-             let pflag = "--prologue=" ++ prologFileName-             k (pflag : renderPureArgs version comp args, result)+             let pflag = "--prologue=" ++ prologueFileName+                 renderedArgs = pflag : renderPureArgs version comp args+             if haddockSupportsResponseFiles +               then+                 withTempFileEx tmpFileOpts outputDir "haddock-response.txt" $+                    \responseFileName hf -> do+                         when haddockSupportsUTF8 (hSetEncoding hf utf8)+                         mapM_ (hPutStrLn hf) renderedArgs+                         hClose hf+                         let respFile = "@" ++ responseFileName+                         k ([respFile], result)+               else+                 k (renderedArgs, result)     where-      isVersion2 = version >= Version [2,0] []       outputDir = (unDir $ argOutputDir args)       result = intercalate ", "              . map (\o -> outputDir </>@@ -491,61 +497,78 @@                               Hoogle -> pkgstr <.> "txt")              $ arg argOutput             where-              pkgstr | isVersion2 = display $ packageName pkgid-                     | otherwise = display pkgid+              pkgstr = display $ packageName pkgid               pkgid = arg argPackageName       arg f = fromFlag $ f args  renderPureArgs :: Version -> Compiler -> HaddockArgs -> [String] renderPureArgs version comp args = concat-    [-     (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)-     . fromFlag . argInterfaceFile $ args,-     (\pname ->   if isVersion2-                  then ["--optghc=-package-name", "--optghc=" ++ pname]-                  else ["--package=" ++ pname]) . display . fromFlag . argPackageName $ args,-     (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) . argHideModules $ args,-     bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args,-     maybe [] (\(m,e) -> ["--source-module=" ++ m-                         ,"--source-entity=" ++ e]) . flagToMaybe . argLinkSource $ args,-     maybe [] ((:[]).("--css="++)) . flagToMaybe . argCssFile $ args,-     maybe [] ((:[]).("--use-contents="++)) . flagToMaybe . argContents $ args,-     bool [] [verbosityFlag] . getAny . argVerbose $ args,-     map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") . fromFlag . argOutput $ args,-     renderInterfaces . argInterfaces $ args,-     (:[]).("--odir="++) . unDir . argOutputDir $ args,-     (:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args))-              . fromFlag . argTitle $ args,-     [ "--optghc=" ++ opt | isVersion2-                          , (opts, _ghcVer) <- flagToList (argGhcOptions args)-                          , opt <- renderGhcOptions comp opts ],-     maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and Nothing?-     argTargets $ args+    [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)+      . fromFlag . argInterfaceFile $ args++    , if isVersion 2 16+        then (\pkg -> [ "--package-name=" ++ display (pkgName pkg)+                      , "--package-version="++display (pkgVersion pkg)+                      ])+             . fromFlag . argPackageName $ args+        else []++    , (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b)+                     . argHideModules $ args++    , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args++    , maybe [] (\(m,e,l) ->+                 ["--source-module=" ++ m+                 ,"--source-entity=" ++ e]+                 ++ if isVersion 2 14 then ["--source-entity-line=" ++ l]+                    else []+               ) . flagToMaybe . argLinkSource $ args++    , maybe [] ((:[]) . ("--css="++)) . flagToMaybe . argCssFile $ args++    , maybe [] ((:[]) . ("--use-contents="++)) . flagToMaybe . argContents $ args++    , bool [] [verbosityFlag] . getAny . argVerbose $ args++    , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html")+      . fromFlag . argOutput $ args++    , renderInterfaces . argInterfaces $ args++    , (:[]) . ("--odir="++) . unDir . argOutputDir $ args++    , (:[]) . ("--title="++)+      . (bool (++" (internal documentation)")+         id (getAny $ argIgnoreExports args))+      . fromFlag . argTitle $ args++    , [ "--optghc=" ++ opt | (opts, _ghcVer) <- flagToList (argGhcOptions args)+                           , opt <- renderGhcOptions comp opts ]++    , maybe [] (\l -> ["-B"++l]) $+      flagToMaybe (argGhcLibDir args) -- error if Nothing?++    , argTargets $ args     ]     where       renderInterfaces =         map (\(i,mh) -> "--read-interface=" ++           maybe "" (++",") mh ++ i)       bool a b c = if c then a else b-      isVersion2 = version >= Version [2,0] []-      isVersion2_5 = version >= Version [2,5] []+      isVersion major minor  = version >= Version [major,minor]  []       verbosityFlag-       | isVersion2_5 = "--verbosity=1"-       | otherwise = "--verbose"+       | isVersion 2 5 = "--verbosity=1"+       | otherwise     = "--verbose" ------------------------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------- -haddockPackageFlags :: LocalBuildInfo-                    -> ComponentLocalBuildInfo-                    -> Maybe PathTemplate-                    -> IO ([(FilePath,Maybe String)], Maybe String)-haddockPackageFlags lbi clbi htmlTemplate = do-  let allPkgs = installedPkgs lbi-      directDeps = map fst (componentPackageDeps clbi)-  transitiveDeps <- case dependencyClosure allPkgs directDeps of-    Left x    -> return x-    Right inf -> die $ "internal error when calculating transative "-                    ++ "package dependencies.\nDebug info: " ++ show inf+-- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and+-- HTML paths, and an optional warning for packages with missing documentation.+haddockPackagePaths :: [InstalledPackageInfo]+                    -> Maybe (InstalledPackageInfo -> FilePath)+                    -> IO ([(FilePath, Maybe FilePath)], Maybe String)+haddockPackagePaths ipkgs mkHtmlPath = do   interfaces <- sequence     [ case interfaceAndHtmlPath ipkg of         Nothing -> return (Left (packageId ipkg))@@ -553,97 +576,123 @@           exists <- doesFileExist interface           if exists             then return (Right (interface, html))-            else return (Left (packageId ipkg))-    | ipkg <- PackageIndex.allPackages transitiveDeps-    , pkgName (packageId ipkg) `notElem` noHaddockWhitelist+            else return (Left pkgid)+    | ipkg <- ipkgs, let pkgid = packageId ipkg+    , pkgName pkgid `notElem` noHaddockWhitelist     ]    let missing = [ pkgid | Left pkgid <- interfaces ]       warning = "The documentation for the following packages are not "              ++ "installed. No links will be generated to these packages: "              ++ intercalate ", " (map display missing)-      flags = [ (interface, if null html then Nothing else Just html)-              | Right (interface, html) <- interfaces ]+      flags = rights interfaces    return (flags, if null missing then Nothing else Just warning)    where+    -- Don't warn about missing documentation for these packages. See #1231.     noHaddockWhitelist = map PackageName [ "rts" ]-    interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (FilePath, FilePath)++    -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'.+    interfaceAndHtmlPath :: InstalledPackageInfo+                         -> Maybe (FilePath, Maybe FilePath)     interfaceAndHtmlPath pkg = do       interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)-      html <- case htmlTemplate of+      html <- case mkHtmlPath of         Nothing -> fmap fixFileUrl                         (listToMaybe (InstalledPackageInfo.haddockHTMLs pkg))-        Just htmlPathTemplate -> Just (expandTemplateVars htmlPathTemplate)-      return (interface, html)-+        Just mkPath -> Just (mkPath pkg)+      return (interface, if null html then Nothing else Just html)       where-        expandTemplateVars = fromPathTemplate . substPathTemplate env-        env = haddockTemplateEnv lbi (packageId pkg)--        -- the 'haddock-html' field in the hc-pkg output is often set as a-        -- native path, but we need it as a URL.-        -- See https://github.com/haskell/cabal/issues/1064+        -- The 'haddock-html' field in the hc-pkg output is often set as a+        -- native path, but we need it as a URL. See #1064.         fixFileUrl f | isAbsolute f = "file://" ++ f                      | otherwise    = f +haddockPackageFlags :: LocalBuildInfo+                    -> ComponentLocalBuildInfo+                    -> Maybe PathTemplate+                    -> IO ([(FilePath, Maybe FilePath)], Maybe String)+haddockPackageFlags lbi clbi htmlTemplate = do+  let allPkgs = installedPkgs lbi+      directDeps = map fst (componentPackageDeps clbi)+  transitiveDeps <- case dependencyClosure allPkgs directDeps of+    Left x    -> return x+    Right inf -> die $ "internal error when calculating transitive "+                    ++ "package dependencies.\nDebug info: " ++ show inf+  haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath+    where+      mkHtmlPath                  = fmap expandTemplateVars htmlTemplate+      expandTemplateVars tmpl pkg =+        fromPathTemplate . substPathTemplate (env pkg) $ tmpl+      env pkg                     = haddockTemplateEnv lbi (packageId pkg)++ haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv-haddockTemplateEnv lbi pkg_id = (PrefixVar, prefix (installDirTemplates lbi))-                                : initialPathTemplateEnv pkg_id (compilerId (compiler lbi))-                                  (hostPlatform lbi)+haddockTemplateEnv lbi pkg_id =+  (PrefixVar, prefix (installDirTemplates lbi))+  : initialPathTemplateEnv pkg_id (LibraryName (display pkg_id)) (compilerInfo (compiler lbi))+  (hostPlatform lbi) --- ----------------------------------------------------------------------------- hscolour support+-- ------------------------------------------------------------------------------+-- hscolour support. -hscolour :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO ()+hscolour :: PackageDescription+         -> LocalBuildInfo+         -> [PPSuffixHandler]+         -> HscolourFlags+         -> IO () hscolour pkg_descr lbi suffixes flags = do   -- we preprocess even if hscolour won't be found on the machine   -- will this upset someone?   initialBuildSteps distPref pkg_descr lbi verbosity-  hscolour' pkg_descr lbi suffixes flags+  hscolour' die pkg_descr lbi suffixes flags  where    verbosity  = fromFlag (hscolourVerbosity flags)    distPref = fromFlag $ hscolourDistPref flags -hscolour' :: PackageDescription+hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found.+          -> PackageDescription           -> LocalBuildInfo           -> [PPSuffixHandler]           -> HscolourFlags           -> IO ()-hscolour' pkg_descr lbi suffixes flags = do-    let distPref = fromFlag $ hscolourDistPref flags-    (hscolourProg, _, _) <--      requireProgramVersion-        verbosity hscolourProgram-        (orLaterVersion (Version [1,8] [])) (withPrograms lbi)+hscolour' onNoHsColour pkg_descr lbi suffixes flags =+    either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<<+      lookupProgramVersion verbosity hscolourProgram+      (orLaterVersion (Version [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 -    setupMessage verbosity "Running hscolour for" (packageId pkg_descr)-    createDirectoryIfMissingVerbose verbosity True $ hscolourPref distPref pkg_descr+      let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes+      withAllComponentsInBuildOrder pkg_descr lbi $ \comp _ -> do+        pre comp+        let+          doExe com = case (compToExe com) of+            Just exe -> do+              let outputDir = hscolourPref distPref pkg_descr+                              </> exeName exe </> "src"+              runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe+            Nothing -> do+              warn (fromFlag $ hscolourVerbosity flags)+                "Unsupported component, skipping..."+              return ()+        case comp of+          CLib lib -> do+            let outputDir = hscolourPref distPref pkg_descr </> "src"+            runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib+          CExe   _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp+          CTest  _ -> when (fromFlag (hscolourTestSuites  flags)) $ doExe comp+          CBench _ -> when (fromFlag (hscolourBenchmarks  flags)) $ doExe comp -    let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes-    withAllComponentsInBuildOrder pkg_descr lbi $ \comp _ -> do-      pre comp-      let-        doExe com = case (compToExe com) of-          Just exe -> do-            let outputDir = hscolourPref distPref pkg_descr </> exeName exe </> "src"-            runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe-          Nothing -> do-           warn (fromFlag $ hscolourVerbosity flags)-             "Unsupported component, skipping..."-           return ()-      case comp of-        CLib lib -> do-          let outputDir = hscolourPref distPref pkg_descr </> "src"-          runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib-        CExe   _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp-        CTest  _ -> when (fromFlag (hscolourTestSuites  flags)) $ doExe comp-        CBench _ -> when (fromFlag (hscolourBenchmarks  flags)) $ doExe comp-  where     stylesheet = flagToMaybe (hscolourCSS flags)      verbosity  = fromFlag (hscolourVerbosity flags)+    distPref   = fromFlag (hscolourDistPref flags)      runHsColour prog outputDir moduleFiles = do          createDirectoryIfMissingVerbose verbosity True outputDir@@ -659,7 +708,8 @@              rawSystemProgram verbosity prog                     ["-css", "-anchor", "-o" ++ outFile m, inFile]         where-          outFile m = outputDir </> intercalate "-" (ModuleName.components m) <.> "html"+          outFile m = outputDir </>+                      intercalate "-" (ModuleName.components m) <.> "html"  haddockToHscolour :: HaddockFlags -> HscolourFlags haddockToHscolour flags =@@ -671,7 +721,7 @@       hscolourVerbosity   = haddockVerbosity   flags,       hscolourDistPref    = haddockDistPref    flags     }-----------------------------------------------------------------------------------------------+--------------------------------------------------------------------------------- -- TODO these should be moved elsewhere.  getLibSourceFiles :: LocalBuildInfo@@ -708,12 +758,8 @@ exeBuildDir :: LocalBuildInfo -> Executable -> FilePath exeBuildDir lbi exe = buildDir lbi </> exeName exe </> exeName exe ++ "-tmp" ----------------------------------------------------------------------------------------------------- boilerplate monoid instance.+-- ------------------------------------------------------------------------------+-- Boilerplate Monoid instance. instance Monoid HaddockArgs where     mempty = HaddockArgs {                 argInterfaceFile = mempty,

cabal/Cabal/Distribution/Simple/HaskellSuite.hs view

@@ -1,7 +1,10 @@+{-# LANGUAGE CPP #-} module Distribution.Simple.HaskellSuite where  import Control.Monad+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif import Data.Maybe import Data.Version import qualified Data.Map as M (empty)@@ -73,6 +76,8 @@       let         comp = Compiler {           compilerId             = CompilerId (HaskellSuite compName) compVersion,+          compilerAbiTag         = Compiler.NoAbiTag,+          compilerCompat         = [],           compilerLanguages      = languages,           compilerExtensions     = extensions,           compilerProperties     = M.empty@@ -117,7 +122,7 @@ -- 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-                     -> IO PackageIndex+                     -> IO InstalledPackageIndex getInstalledPackages verbosity packagedbs conf =   liftM (PackageIndex.fromList . concat) $ forM packagedbs $ \packagedb ->     do str <-@@ -172,6 +177,7 @@            | (ipkgid, _) <- componentPackageDeps clbi ] ++     ["-G", display language] ++     concat [ ["-X", display ex] | ex <- usedExtensions bi ] +++    cppOptions (libBuildInfo lib) ++     [ display modu | modu <- libModules lib ]  @@ -180,7 +186,7 @@   :: Verbosity   -> LocalBuildInfo   -> FilePath  -- ^install location-  -> FilePath  -- ^install location for dynamic librarys+  -> FilePath  -- ^install location for dynamic libraries   -> FilePath  -- ^Build location   -> PackageDescription   -> Library

cabal/Cabal/Distribution/Simple/Hpc.hs view

@@ -2,6 +2,7 @@ -- | -- Module      :  Distribution.Simple.Hpc -- Copyright   :  Thomas Tuegel 2011+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -10,39 +11,10 @@ -- a function for adding the necessary options to a PackageDescription to -- build test suites with HPC enabled. -{- 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. -}- module Distribution.Simple.Hpc-    ( enableCoverage+    ( Way(..), guessWay     , htmlDir+    , mixDir     , tixDir     , tixFilePath     , markupPackage@@ -50,13 +22,9 @@     ) where  import Control.Monad ( when )-import Distribution.Compiler ( CompilerFlavor(..) ) import Distribution.ModuleName ( main ) import Distribution.PackageDescription-    ( BuildInfo(..)-    , Library(..)-    , PackageDescription(..)-    , TestSuite(..)+    ( TestSuite(..)     , testModules     ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )@@ -67,7 +35,6 @@ import Distribution.Simple.Program.Hpc ( markup, union ) import Distribution.Simple.Utils ( notice ) import Distribution.Version ( anyVersion )-import Distribution.Text import Distribution.Verbosity ( Verbosity() ) import System.Directory ( createDirectoryIfMissing, doesFileExist ) import System.FilePath@@ -75,63 +42,52 @@ -- ------------------------------------------------------------------------- -- Haskell Program Coverage --- | Conditionally enable Haskell Program Coverage by adding the necessary--- GHC options to a PackageDescription.------ TODO: do this differently in the build stage by constructing local build--- info, not by modifying the original PackageDescription.----enableCoverage :: Bool                  -- ^ Enable coverage?-               -> String                -- ^ \"dist/\" prefix-               -> PackageDescription-               -> PackageDescription-enableCoverage False _ x = x-enableCoverage True distPref p =-    p { library = fmap enableLibCoverage (library p)-      , testSuites = map enableTestCoverage (testSuites p)-      }-  where-    enableBICoverage name oldBI =-        let oldOptions = options oldBI-            oldGHCOpts = lookup GHC oldOptions-            newGHCOpts = case oldGHCOpts of-                             Just xs -> (GHC, hpcOpts ++ xs)-                             _ -> (GHC, hpcOpts)-            newOptions = (:) newGHCOpts $ filter ((== GHC) . fst) oldOptions-            hpcOpts = ["-fhpc", "-hpcdir", mixDir distPref name]-        in oldBI { options = newOptions }-    enableLibCoverage l =-        l { libBuildInfo = enableBICoverage (display $ package p)-                                            (libBuildInfo l)-          }-    enableTestCoverage t =-        t { testBuildInfo = enableBICoverage (testName t) (testBuildInfo t) }+data Way = Vanilla | Prof | Dyn+  deriving (Bounded, Enum, Eq, Read, Show)  hpcDir :: FilePath  -- ^ \"dist/\" prefix+       -> Way        -> FilePath  -- ^ Directory containing component's HPC .mix files-hpcDir distPref = distPref </> "hpc"+hpcDir distPref way = distPref </> "hpc" </> wayDir+  where+    wayDir = case way of+      Vanilla -> "vanilla"+      Prof -> "prof"+      Dyn -> "dyn"  mixDir :: FilePath  -- ^ \"dist/\" prefix+       -> Way        -> FilePath  -- ^ Component name        -> FilePath  -- ^ Directory containing test suite's .mix files-mixDir distPref name = hpcDir distPref </> "mix" </> name+mixDir distPref way name = hpcDir distPref way </> "mix" </> name  tixDir :: FilePath  -- ^ \"dist/\" prefix+       -> Way        -> FilePath  -- ^ Component name        -> FilePath  -- ^ Directory containing test suite's .tix files-tixDir distPref name = hpcDir distPref </> "tix" </> name+tixDir distPref way name = hpcDir distPref way </> "tix" </> name  -- | Path to the .tix file containing a test suite's sum statistics. tixFilePath :: FilePath     -- ^ \"dist/\" prefix+            -> Way             -> FilePath     -- ^ Component name             -> FilePath     -- ^ Path to test suite's .tix file-tixFilePath distPref name = tixDir distPref name </> name <.> "tix"+tixFilePath distPref way name = tixDir distPref way name </> name <.> "tix"  htmlDir :: FilePath     -- ^ \"dist/\" prefix+        -> Way         -> FilePath     -- ^ Component name         -> FilePath     -- ^ Path to test suite's HTML markup directory-htmlDir distPref name = hpcDir distPref </> "html" </> name+htmlDir distPref way name = hpcDir distPref way </> "html" </> name +-- | Attempt to guess the way the test suites in this package were compiled+-- and linked with the library so the correct module interfaces are found.+guessWay :: LocalBuildInfo -> Way+guessWay lbi+  | withProfExe lbi = Prof+  | withDynExe lbi = Dyn+  | otherwise = Vanilla+ -- | Generate the HTML markup for a test suite. markupTest :: Verbosity            -> LocalBuildInfo@@ -140,21 +96,22 @@            -> TestSuite            -> IO () markupTest verbosity lbi distPref libName suite = do-    tixFileExists <- doesFileExist $ tixFilePath distPref $ testName suite+    tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName suite     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         markup hpc hpcVer verbosity-            (tixFilePath distPref $ testName suite) mixDirs-            (htmlDir distPref $ testName suite)+            (tixFilePath distPref way $ testName suite) mixDirs+            htmlDir_             (testModules suite ++ [ main ])         notice verbosity $ "Test coverage report written to "-                            ++ htmlDir distPref (testName suite)-                            </> "hpc_index" <.> "html"+                            ++ htmlDir_ </> "hpc_index" <.> "html"   where-    mixDirs = map (mixDir distPref) [ testName suite, libName ]+    way = guessWay lbi+    mixDirs = map (mixDir distPref way) [ testName suite, libName ]  -- | Generate the HTML markup for all of a package's test suites. markupPackage :: Verbosity@@ -164,15 +121,15 @@               -> [TestSuite]               -> IO () markupPackage verbosity lbi distPref libName suites = do-    let tixFiles = map (tixFilePath distPref . testName) suites+    let tixFiles = map (tixFilePath distPref way . testName) suites     tixFilesExist <- mapM doesFileExist tixFiles     when (and tixFilesExist) $ 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 outFile = tixFilePath distPref libName-            htmlDir' = htmlDir distPref libName+        let outFile = tixFilePath distPref way libName+            htmlDir' = htmlDir distPref way libName             excluded = concatMap testModules suites ++ [ main ]         createDirectoryIfMissing True $ takeDirectory outFile         union hpc verbosity tixFiles outFile excluded@@ -180,4 +137,5 @@         notice verbosity $ "Package coverage report written to "                            ++ htmlDir' </> "hpc_index.html"   where-    mixDirs = map (mixDir distPref) $ libName : map testName suites+    way = guessWay lbi+    mixDirs = map (mixDir distPref way) $ libName : map testName suites

− cabal/Cabal/Distribution/Simple/Hugs.hs

@@ -1,639 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Hugs--- Copyright   :  Isaac Jones 2003-2006---                Duncan Coutts 2009------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module contains most of the NHC-specific code for configuring, building--- and installing packages.--{- Copyright (c) 2003-2005, Isaac Jones-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. -}--module Distribution.Simple.Hugs (-    configure,-    getInstalledPackages,-    buildLib,-    buildExe,-    install,-    registerPackage,-  ) where--import Distribution.Package-         ( PackageName, PackageIdentifier(..), InstalledPackageId(..)-         , packageName )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo, emptyInstalledPackageInfo-         , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId-                                , sourcePackageId )-         , parseInstalledPackageInfo, showInstalledPackageInfo )-import Distribution.PackageDescription-         ( PackageDescription(..), BuildInfo(..), hcOptions, allExtensions-         , Executable(..), withExe, Library(..), withLib, libModules )-import Distribution.ModuleName (ModuleName)-import qualified Distribution.ModuleName as ModuleName-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..)-         , Compiler(..), Flag, languageToFlags, extensionsToFlags-         , PackageDB(..), PackageDBStack )-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (PackageIndex)-import Distribution.Simple.Program-         ( Program(programFindVersion)-         , ProgramConfiguration, userMaybeSpecifyPath-         , requireProgram, requireProgramVersion-         , rawSystemProgramConf, programPath-         , ffihugsProgram, hugsProgram )-import Distribution.Version-         ( Version(..), orLaterVersion )-import Distribution.Simple.PreProcess   ( ppCpp, runSimplePreProcessor )-import Distribution.Simple.PreProcess.Unlit-                                ( unlit )-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-         , InstallDirs(..), absoluteInstallDirs )-import Distribution.Simple.BuildPaths-                                ( autogenModuleName, autogenModulesDir,-                                  dllExtension )-import Distribution.Simple.Setup-         ( CopyDest(..) )-import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose-         , installOrdinaryFiles, setFileExecutable-         , withUTF8FileContents, writeFileAtomic, writeUTF8File-         , copyFileVerbose, findFile, findFileWithExtension, findModuleFiles-         , rawSystemStdInOut-         , die, info, notice )-import Language.Haskell.Extension-         ( Language(Haskell98), Extension(..), KnownExtension(..) )-import System.FilePath          ( (</>), takeExtension, (<.>),-                                  searchPathSeparator, normalise, takeDirectory )-import Distribution.System-         ( OS(..), buildOS )-import Distribution.Text-         ( display, simpleParse )-import Distribution.ParseUtils-         ( ParseResult(..) )-import Distribution.Verbosity--import Data.Char                ( isSpace )-import qualified Data.Map as M  ( empty )-import Data.Maybe               ( mapMaybe, catMaybes )-import Data.Monoid              ( Monoid(..) )-import Control.Monad            ( unless, when, filterM )-import Data.List                ( nub, sort, isSuffixOf )-import System.Directory-         ( doesFileExist, doesDirectoryExist, getDirectoryContents-         , removeDirectoryRecursive, getHomeDirectory )-import System.Exit-         ( ExitCode(ExitSuccess) )-import Distribution.Compat.Exception-import Distribution.System ( Platform )--import qualified Data.ByteString.Lazy.Char8 as BS.Char8---- -------------------------------------------------------------------------------- Configuring--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration)-configure verbosity hcPath _hcPkgPath conf = do--  (_ffihugsProg, conf') <- requireProgram verbosity ffihugsProgram-                            (userMaybeSpecifyPath "ffihugs" hcPath conf)-  (_hugsProg, version, conf'')-                        <- requireProgramVersion verbosity hugsProgram'-                            (orLaterVersion (Version [2006] [])) conf'--  let comp = Compiler {-        compilerId             = CompilerId Hugs version,-        compilerLanguages      = hugsLanguages,-        compilerExtensions     = hugsLanguageExtensions,-        compilerProperties     = M.empty-      }-      compPlatform = Nothing-  return (comp, compPlatform, conf'')--  where-    hugsProgram' = hugsProgram { programFindVersion = getVersion }--getVersion :: Verbosity -> FilePath -> IO (Maybe Version)-getVersion verbosity hugsPath = do-  (output, _err, exit) <- rawSystemStdInOut verbosity hugsPath []-                              Nothing Nothing-                              (Just (":quit", False)) False-  if exit == ExitSuccess-    then return $! findVersion output-    else return Nothing--  where-    findVersion output = do-      (monthStr, yearStr) <- selectWords output-      year  <- convertYear yearStr-      month <- convertMonth monthStr-      return (Version [year, month] [])--    selectWords output =-      case [ (month, year)-           | [_,_,"Version:", month, year,_] <- map words (lines output) ] of-        [(month, year)] -> Just (month, year)-        _               -> Nothing-    convertYear year = case reads year of-      [(y, [])] | y >= 1999 && y < 2020 -> Just y-      _                                 -> Nothing-    convertMonth month = lookup month (zip months [1..])-    months = [ "January", "February", "March", "April", "May", "June", "July"-             , "August", "September", "October", "November", "December" ]--hugsLanguages :: [(Language, Flag)]-hugsLanguages = [(Haskell98, "")] --default is 98 mode---- | The flags for the supported extensions-hugsLanguageExtensions :: [(Extension, Flag)]-hugsLanguageExtensions =-    let doFlag (f, (enable, disable)) = [(EnableExtension  f, enable),-                                         (DisableExtension f, disable)]-        alwaysOn = ("", ""{- wrong -})-        ext98 = ("-98", ""{- wrong -})-    in concatMap doFlag-    [(OverlappingInstances       , ("+o",  "-o"))-    ,(IncoherentInstances        , ("+oO", "-O"))-    ,(HereDocuments              , ("+H",  "-H"))-    ,(TypeSynonymInstances       , ext98)-    ,(RecursiveDo                , ext98)-    ,(ParallelListComp           , ext98)-    ,(MultiParamTypeClasses      , ext98)-    ,(FunctionalDependencies     , ext98)-    ,(Rank2Types                 , ext98)-    ,(PolymorphicComponents      , ext98)-    ,(ExistentialQuantification  , ext98)-    ,(ScopedTypeVariables        , ext98)-    ,(ImplicitParams             , ext98)-    ,(ExtensibleRecords          , ext98)-    ,(RestrictedTypeSynonyms     , ext98)-    ,(FlexibleContexts           , ext98)-    ,(FlexibleInstances          , ext98)-    ,(ForeignFunctionInterface   , alwaysOn)-    ,(EmptyDataDecls             , alwaysOn)-    ,(CPP                        , alwaysOn)-    ]--getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration-                     -> IO PackageIndex-getInstalledPackages verbosity packagedbs conf = do-  homedir       <- getHomeDirectory-  (hugsProg, _) <- requireProgram verbosity hugsProgram conf-  let hugsbindir = takeDirectory (programPath hugsProg)-      hugslibdir = takeDirectory hugsbindir </> "lib" </> "hugs"-      dbdirs = nub (concatMap (packageDbPaths homedir hugslibdir) packagedbs)-  indexes  <- mapM getIndividualDBPackages dbdirs-  return $! mconcat indexes--  where-    getIndividualDBPackages :: FilePath -> IO PackageIndex-    getIndividualDBPackages dbdir = do-      pkgdirs <- getPackageDbDirs dbdir-      pkgs    <- sequence [ getInstalledPackage pkgname pkgdir-                          | (pkgname, pkgdir) <- pkgdirs ]-      let pkgs' = map setInstalledPackageId (catMaybes pkgs)-      return (PackageIndex.fromList pkgs')--packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath]-packageDbPaths home hugslibdir db = case db of-  GlobalPackageDB        -> [ hugslibdir </> "packages"-                            , "/usr/local/lib/hugs/packages" ]-  UserPackageDB          -> [ home </> "lib/hugs/packages" ]-  SpecificPackageDB path -> [ path ]--getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)]-getPackageDbDirs dbdir = do-  dbexists <- doesDirectoryExist dbdir-  if not dbexists-    then return []-    else do-      entries  <- getDirectoryContents dbdir-      pkgdirs  <- sequence-        [ do pkgdirExists <- doesDirectoryExist pkgdir-             return (pkgname, pkgdir, pkgdirExists)-        | (entry, Just pkgname) <- [ (entry, simpleParse entry)-                                   | entry <- entries ]-        , let pkgdir = dbdir </> entry ]-      return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ]--getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo)-getInstalledPackage pkgname pkgdir = do-  let pkgconfFile = pkgdir </> "package.conf"-  pkgconfExists <- doesFileExist pkgconfFile--  let pathsModule = pkgdir </> ("Paths_" ++ display pkgname)  <.> "hs"-  pathsModuleExists <- doesFileExist pathsModule--  case () of-    _ | pkgconfExists     -> getFullInstalledPackageInfo pkgname pkgconfFile-      | pathsModuleExists -> getPhonyInstalledPackageInfo pkgname pathsModule-      | otherwise         -> return Nothing--getFullInstalledPackageInfo :: PackageName -> FilePath-                            -> IO (Maybe InstalledPackageInfo)-getFullInstalledPackageInfo pkgname pkgconfFile =-  withUTF8FileContents pkgconfFile $ \contents ->-    case parseInstalledPackageInfo contents of-      ParseOk _ pkginfo | packageName pkginfo == pkgname-                        -> return (Just pkginfo)-      _                 -> return Nothing---- | This is a backup option for existing versions of Hugs which do not supply--- proper installed package info files for the bundled libs. Instead we look--- for the Paths_pkgname.hs file and extract the package version from that.--- We don't know any other details for such packages, in particular we pretend--- that they have no dependencies.----getPhonyInstalledPackageInfo :: PackageName -> FilePath-                             -> IO (Maybe InstalledPackageInfo)-getPhonyInstalledPackageInfo pkgname pathsModule = do-  content <- readFile pathsModule-  case extractVersion content of-    Nothing      -> return Nothing-    Just version -> return (Just pkginfo)-      where-        pkgid   = PackageIdentifier pkgname version-        pkginfo = emptyInstalledPackageInfo { sourcePackageId = pkgid }-  where-    -- search through the Paths_pkgname.hs file, looking for a line like:-    ---    -- > version = Version {versionBranch = [2,0], versionTags = []}-    ---    -- and parse it using 'Read'. Yes we are that evil.-    ---    extractVersion content =-      case [ version-           | ("version":"=":rest) <- map words (lines content)-           , (version, []) <- reads (concat rest) ] of-        [version] -> Just version-        _         -> Nothing---- Older installed package info files did not have the installedPackageId--- field, so if it is missing then we fill it as the source package ID.-setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo-setInstalledPackageId pkginfo@InstalledPackageInfo {-                        installedPackageId = InstalledPackageId "",-                        sourcePackageId    = pkgid-                      }-                    = pkginfo {-                        --TODO use a proper named function for the conversion-                        -- from source package id to installed package id-                        installedPackageId = InstalledPackageId (display pkgid)-                      }-setInstalledPackageId pkginfo = pkginfo---- -------------------------------------------------------------------------------- Building---- |Building a package for Hugs.-buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity pkg_descr lbi lib _clbi = do-    let pref = scratchDir lbi-    createDirectoryIfMissingVerbose verbosity True pref-    copyFileVerbose verbosity (autogenModulesDir lbi </> paths_modulename)-                              (pref </> paths_modulename)-    compileBuildInfo verbosity pref [] (libModules lib) (libBuildInfo lib) lbi-  where-    paths_modulename = ModuleName.toFilePath (autogenModuleName pkg_descr)-                         <.> ".hs"-    --TODO: switch to using autogenModulesDir as a search dir, rather than-    --      always copying the file over.---- |Building an executable for Hugs.-buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe verbosity pkg_descr lbi-  exe@Executable {modulePath=mainPath, buildInfo=bi} _clbi = do-    let pref = scratchDir lbi-    createDirectoryIfMissingVerbose verbosity True pref-    -    let destDir = pref </> "programs"-    let exeMods = otherModules bi-    srcMainFile <- findFile (hsSourceDirs bi) mainPath-    let exeDir = destDir </> exeName exe-    let destMainFile = exeDir </> hugsMainFilename exe-    copyModule verbosity (EnableExtension CPP `elem` allExtensions bi) bi lbi srcMainFile destMainFile-    let destPathsFile = exeDir </> paths_modulename-    copyFileVerbose verbosity (autogenModulesDir lbi </> paths_modulename)-                              destPathsFile-    compileBuildInfo verbosity exeDir -      (maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr)) exeMods bi lbi-    compileFiles verbosity bi lbi exeDir [destMainFile, destPathsFile]--  where-    paths_modulename = ModuleName.toFilePath (autogenModuleName pkg_descr)-                         <.> ".hs"--compileBuildInfo :: Verbosity-                 -> FilePath -- ^output directory-                 -> [FilePath] -- ^library source dirs, if building exes-                 -> [ModuleName] -- ^Modules-                 -> BuildInfo-                 -> LocalBuildInfo-                 -> IO ()---TODO: should not be using mLibSrcDirs at all-compileBuildInfo verbosity destDir mLibSrcDirs mods bi lbi = do-    -- Pass 1: copy or cpp files from build directory to scratch directory-    let useCpp = EnableExtension CPP `elem` allExtensions bi-    let srcDir = buildDir lbi-        srcDirs = nub $ srcDir : hsSourceDirs bi ++ mLibSrcDirs-    info verbosity $ "Source directories: " ++ show srcDirs-    flip mapM_ mods $ \ m -> do-        fs <- findFileWithExtension suffixes srcDirs (ModuleName.toFilePath m)-        case fs of-          Nothing ->-            die ("can't find source for module " ++ display m)-          Just srcFile -> do-            let ext = takeExtension srcFile-            copyModule verbosity useCpp bi lbi srcFile-                (destDir </> ModuleName.toFilePath m <.> ext)-    -- Pass 2: compile foreign stubs in scratch directory-    stubsFileLists <- fmap catMaybes $ sequence-      [ findFileWithExtension suffixes [destDir] (ModuleName.toFilePath modu)-      | modu <- mods]-    compileFiles verbosity bi lbi destDir stubsFileLists--suffixes :: [String]-suffixes = ["hs", "lhs"]---- Copy or cpp a file from the source directory to the build directory.-copyModule :: Verbosity -> Bool -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO ()-copyModule verbosity cppAll bi lbi srcFile destFile = do-    createDirectoryIfMissingVerbose verbosity True (takeDirectory destFile)-    (exts, opts, _) <- getOptionsFromSource srcFile-    let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ]-    if cppAll || EnableExtension CPP `elem` exts || "-cpp" `elem` ghcOpts then do-        runSimplePreProcessor (ppCpp bi lbi) srcFile destFile verbosity-        return ()-      else-        copyFileVerbose verbosity srcFile destFile--compileFiles :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> [FilePath] -> IO ()-compileFiles verbosity bi lbi modDir fileList = do-    ffiFileList <- filterM testFFI fileList-    unless (null ffiFileList) $ do-        notice verbosity "Compiling FFI stubs"-        mapM_ (compileFFI verbosity bi lbi modDir) ffiFileList---- Only compile FFI stubs for a file if it contains some FFI stuff-testFFI :: FilePath -> IO Bool-testFFI file =-  withHaskellFile file $ \inp ->-    return $! "foreign" `elem` symbols (stripComments False inp)--compileFFI :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO ()-compileFFI verbosity bi lbi modDir file = do-    (_, opts, file_incs) <- getOptionsFromSource file-    let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ]-    let pkg_incs = ["\"" ++ inc ++ "\"" | inc <- includes bi]-    let incs = nub (sort (file_incs ++ includeOpts ghcOpts ++ pkg_incs))-    let pathFlag = "-P" ++ modDir ++ [searchPathSeparator]-    let hugsArgs = "-98" : pathFlag : map ("-i" ++) incs-    cfiles <- getCFiles file-    let cArgs =-            ["-I" ++ dir | dir <- includeDirs bi] ++-            ccOptions bi ++-            cfiles ++-            ["-L" ++ dir | dir <- extraLibDirs bi] ++-            ldOptions bi ++-            ["-l" ++ lib | lib <- extraLibs bi] ++-            concat [["-framework", f] | f <- frameworks bi]-    rawSystemProgramConf verbosity ffihugsProgram (withPrograms lbi)-      (hugsArgs ++ file : cArgs)--includeOpts :: [String] -> [String]-includeOpts [] = []-includeOpts ("-#include" : arg : opts) = arg : includeOpts opts-includeOpts (_ : opts) = includeOpts opts---- get C file names from CFILES pragmas throughout the source file-getCFiles :: FilePath -> IO [String]-getCFiles file =-  withHaskellFile file $ \inp ->-    let cfiles =-          [ normalise cfile-          | "{-#" : "CFILES" : rest <- map words-                                     $ lines-                                     $ stripComments True inp-          , last rest == "#-}"-          , cfile <- init rest]-     in seq (length cfiles) (return cfiles)---- List of terminal symbols in a source file.-symbols :: String -> [String]-symbols cs = case lex cs of-    (sym, cs'):_ | not (null sym) -> sym : symbols cs'-    _ -> []---- Get the non-literate source of a Haskell module.-withHaskellFile :: FilePath -> (String -> IO a) -> IO a-withHaskellFile file action =-    withUTF8FileContents file $ \text ->-        if ".lhs" `isSuffixOf` file-          then either action die (unlit file text)-          else action text---- --------------------------------------------------------------- * options in source files--- ---------------------------------------------------------------- |Read the initial part of a source file, before any Haskell code,--- and return the contents of any LANGUAGE, OPTIONS and INCLUDE pragmas.-getOptionsFromSource-    :: FilePath-    -> IO ([Extension],                 -- LANGUAGE pragma, if any-           [(CompilerFlavor,[String])], -- OPTIONS_FOO pragmas-           [String]                     -- INCLUDE pragmas-          )-getOptionsFromSource file =-    withHaskellFile file $-        (return $!)-      . foldr appendOptions ([],[],[]) . map getOptions-      . takeWhileJust . map getPragma-      . filter textLine . map (dropWhile isSpace) . lines-      . stripComments True--  where textLine [] = False-        textLine ('#':_) = False-        textLine _ = True--        getPragma :: String -> Maybe [String]-        getPragma line = case words line of-            ("{-#" : rest) | last rest == "#-}" -> Just (init rest)-            _ -> Nothing--        getOptions ("OPTIONS":opts) = ([], [(GHC, opts)], [])-        getOptions ("OPTIONS_GHC":opts) = ([], [(GHC, opts)], [])-        getOptions ("OPTIONS_NHC98":opts) = ([], [(NHC, opts)], [])-        getOptions ("OPTIONS_HUGS":opts) = ([], [(Hugs, opts)], [])-        getOptions ("LANGUAGE":ws) = (mapMaybe readExtension ws, [], [])-          where readExtension :: String -> Maybe Extension-                readExtension w = case reads w of-                    [(ext, "")] -> Just ext-                    [(ext, ",")] -> Just ext-                    _ -> Nothing-        getOptions ("INCLUDE":ws) = ([], [], ws)-        getOptions _ = ([], [], [])--        appendOptions (exts, opts, incs) (exts', opts', incs')-          = (exts++exts', opts++opts', incs++incs')---- takeWhileJust f = map fromJust . takeWhile isJust-takeWhileJust :: [Maybe a] -> [a]-takeWhileJust (Just x:xs) = x : takeWhileJust xs-takeWhileJust _ = []---- |Strip comments from Haskell source.-stripComments-    :: Bool     -- ^ preserve pragmas?-    -> String   -- ^ input source text-    -> String-stripComments keepPragmas = stripCommentsLevel 0-  where stripCommentsLevel :: Int -> String -> String-        stripCommentsLevel 0 ('"':cs) = '"':copyString cs-        stripCommentsLevel 0 ('-':'-':cs) =     -- FIX: symbols like -->-            stripCommentsLevel 0 (dropWhile (/= '\n') cs)-        stripCommentsLevel 0 ('{':'-':'#':cs)-          | keepPragmas = '{' : '-' : '#' : copyPragma cs-        stripCommentsLevel n ('{':'-':cs) = stripCommentsLevel (n+1) cs-        stripCommentsLevel 0 (c:cs) = c : stripCommentsLevel 0 cs-        stripCommentsLevel n ('-':'}':cs) = stripCommentsLevel (n-1) cs-        stripCommentsLevel n (_:cs) = stripCommentsLevel n cs-        stripCommentsLevel _ [] = []--        copyString ('\\':c:cs) = '\\' : c : copyString cs-        copyString ('"':cs) = '"' : stripCommentsLevel 0 cs-        copyString (c:cs) = c : copyString cs-        copyString [] = []--        copyPragma ('#':'-':'}':cs) = '#' : '-' : '}' : stripCommentsLevel 0 cs-        copyPragma (c:cs) = c : copyPragma cs-        copyPragma [] = []---- -------------------------------------------------------------------------------- |Install for Hugs.--- For install, copy-prefix = prefix, but for copy they're different.--- The library goes in \<copy-prefix>\/lib\/hugs\/packages\/\<pkgname>--- (i.e. \<prefix>\/lib\/hugs\/packages\/\<pkgname> on the target system).--- Each executable goes in \<copy-prefix>\/lib\/hugs\/programs\/\<exename>--- (i.e. \<prefix>\/lib\/hugs\/programs\/\<exename> on the target system)--- with a script \<copy-prefix>\/bin\/\<exename> pointing at--- \<prefix>\/lib\/hugs\/programs\/\<exename>.-install-    :: Verbosity -- ^verbosity-    -> LocalBuildInfo-    -> FilePath  -- ^Library install location-    -> FilePath  -- ^Program install location-    -> FilePath  -- ^Executable install location-    -> FilePath  -- ^Program location on target system-    -> FilePath  -- ^Build location-    -> (FilePath,FilePath)  -- ^Executable (prefix,suffix)-    -> PackageDescription-    -> IO ()---FIXME: this script should be generated at build time, just installed at this stage-install verbosity lbi libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do-    removeDirectoryRecursive libDir `catchIO` \_ -> return ()-    withLib pkg_descr $ \ lib ->-      findModuleFiles [buildPref] hugsInstallSuffixes (libModules lib)-        >>= installOrdinaryFiles verbosity libDir-    let buildProgDir = buildPref </> "programs"-    when (any (buildable . buildInfo) (executables pkg_descr)) $-        createDirectoryIfMissingVerbose verbosity True binDir-    withExe pkg_descr $ \ exe -> do-        let bi = buildInfo exe-        let theBuildDir = buildProgDir </> exeName exe-        let installDir = installProgDir </> exeName exe-        let targetDir = targetProgDir </> exeName exe-        removeDirectoryRecursive installDir `catchIO` \_ -> return ()-        findModuleFiles [theBuildDir] hugsInstallSuffixes-                        (ModuleName.main : autogenModuleName pkg_descr-                                         : otherModules (buildInfo exe))-          >>= installOrdinaryFiles verbosity installDir-        let targetName = "\"" ++ (targetDir </> hugsMainFilename exe) ++ "\""-        let hugsOptions = hcOptions Hugs (buildInfo exe)-                       ++ languageToFlags (compiler lbi) (defaultLanguage bi)-                       ++ extensionsToFlags (compiler lbi) (allExtensions bi)-            --TODO: also need to consider options, extensions etc of deps-            --      see ticket #43-        let baseExeFile = progprefix ++ (exeName exe) ++ progsuffix-        let exeFile = case buildOS of-                          Windows -> binDir </> baseExeFile <.> ".bat"-                          _       -> binDir </> baseExeFile-        let script = case buildOS of-                         Windows ->-                             let args = hugsOptions ++ [targetName, "%*"]-                             in unlines ["@echo off",-                                         unwords ("runhugs" : args)]-                         _ ->-                             let args = hugsOptions ++ [targetName, "\"$@\""]-                             in unlines ["#! /bin/sh",-                                         unwords ("runhugs" : args)]-        writeFileAtomic exeFile (BS.Char8.pack script)-        setFileExecutable exeFile--hugsInstallSuffixes :: [String]-hugsInstallSuffixes = [".hs", ".lhs", dllExtension]---- |Filename used by Hugs for the main module of an executable.--- This is a simple filename, so that Hugs will look for any auxiliary--- modules it uses relative to the directory it's in.-hugsMainFilename :: Executable -> FilePath-hugsMainFilename exe = "Main" <.> ext-  where ext = takeExtension (modulePath exe)---- -------------------------------------------------------------------------------- Registering--registerPackage-  :: Verbosity-  -> InstalledPackageInfo-  -> PackageDescription-  -> LocalBuildInfo-  -> Bool-  -> PackageDBStack-  -> IO ()-registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do-  --TODO: prefer to have it based on the packageDbs, but how do we know-  -- the package subdir based on the name? the user can set crazy libsubdir-  let installDirs = absoluteInstallDirs pkg lbi NoCopyDest-      pkgdir  | inplace   = buildDir lbi-              | otherwise = libdir installDirs-  createDirectoryIfMissingVerbose verbosity True pkgdir-  writeUTF8File (pkgdir </> "package.conf")-                (showInstalledPackageInfo installedPkgInfo)

cabal/Cabal/Distribution/Simple/Install.hs view

@@ -2,6 +2,7 @@ -- | -- Module      :  Distribution.Simple.Install -- Copyright   :  Isaac Jones 2003-2004+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -11,36 +12,6 @@ -- place based on the prefix argument. It does the generic bits and then calls -- compiler-specific functions to do the rest. -{- 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. -}- module Distribution.Simple.Install (         install,   ) where@@ -59,14 +30,13 @@          , die, info, notice, warn, matchDirFileGlob ) import Distribution.Simple.Compiler          ( CompilerFlavor(..), compilerFlavor )-import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..), fromFlag)+import Distribution.Simple.Setup (CopyFlags(..), fromFlag) -import qualified Distribution.Simple.GHC  as GHC-import qualified Distribution.Simple.NHC  as NHC-import qualified Distribution.Simple.JHC  as JHC-import qualified Distribution.Simple.LHC  as LHC-import qualified Distribution.Simple.Hugs as Hugs-import qualified Distribution.Simple.UHC  as UHC+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.Monad (when, unless)@@ -80,8 +50,7 @@          ( display )  -- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\"--- actions.  Move files into place based on the prefix argument.  FIX:--- nhc isn't implemented yet.+-- actions.  Move files into place based on the prefix argument.  install :: PackageDescription -- ^information from the .cabal file         -> LocalBuildInfo -- ^information from the configure step@@ -96,7 +65,6 @@          libdir     = libPref, --         dynlibdir  = dynlibPref, --see TODO below          datadir    = dataPref,-         progdir    = progPref,          docdir     = docPref,          htmldir    = htmlPref,          haddockdir = interfacePref,@@ -111,6 +79,8 @@       progPrefixPref = substPathTemplate (packageId pkg_descr) lbi (progPrefix lbi)       progSuffixPref = substPathTemplate (packageId pkg_descr) lbi (progSuffix lbi) +  unless (hasLibs pkg_descr || hasExes pkg_descr) $+      die "No executables and no library found. Nothing to do."   docExists <- doesDirectoryExist $ haddockPref distPref pkg_descr   info verbosity ("directory " ++ haddockPref distPref pkg_descr ++                   " does exist: " ++ show docExists)@@ -137,10 +107,12 @@         installOrdinaryFile verbosity haddockInterfaceFileSrc                                       haddockInterfaceFileDest -  let lfile = licenseFile pkg_descr-  unless (null lfile) $ do+  let lfiles = licenseFiles pkg_descr+  unless (null lfiles) $ do     createDirectoryIfMissingVerbose verbosity True docPref-    installOrdinaryFile verbosity lfile (docPref </> takeFileName lfile)+    sequence_+      [ installOrdinaryFile verbosity lfile (docPref </> takeFileName lfile)+      | lfile <- lfiles ]    let buildPref = buildDir lbi   when (hasLibs pkg_descr) $@@ -161,6 +133,10 @@                   GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr                 withExe pkg_descr $                   GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr+     GHCJS-> do withLibLBI pkg_descr lbi $+                  GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr+                withExe pkg_descr $+                  GHCJS.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr      LHC  -> do withLibLBI pkg_descr lbi $                   LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr                 withExe pkg_descr $@@ -169,12 +145,6 @@                   JHC.installLib verbosity libPref buildPref pkg_descr                 withExe pkg_descr $                   JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr-     Hugs -> do-       let targetProgPref = progdir (absoluteInstallDirs pkg_descr lbi NoCopyDest)-       let scratchPref = scratchDir lbi-       Hugs.install verbosity lbi libPref progPref binPref targetProgPref scratchPref (progPrefixPref, progSuffixPref) pkg_descr-     NHC  -> do withLibLBI pkg_descr lbi $ NHC.installLib verbosity libPref buildPref (packageId pkg_descr)-                withExe pkg_descr $ NHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref)      UHC  -> do withLib pkg_descr $ UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr      HaskellSuite {} ->        withLib pkg_descr $

cabal/Cabal/Distribution/Simple/InstallDirs.hs view

@@ -1,8 +1,12 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.InstallDirs -- Copyright   :  Isaac Jones 2003-2004+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -16,36 +20,6 @@ -- provides a 'PathTemplate' type and functions for substituting for these -- templates. -{- 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. -}- module Distribution.Simple.InstallDirs (         InstallDirs(..),         InstallDirTemplates,@@ -66,23 +40,28 @@         platformTemplateEnv,         compilerTemplateEnv,         packageTemplateEnv,+        abiTemplateEnv,         installDirsTemplateEnv,   ) where  +import Distribution.Compat.Binary (Binary) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe)+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(..))+#endif+import GHC.Generics (Generic) import System.Directory (getAppUserDataDirectory) import System.FilePath ((</>), isPathSeparator, pathSeparator) import System.FilePath (dropDrive)  import Distribution.Package-         ( PackageIdentifier, packageName, packageVersion )+         ( PackageIdentifier, packageName, packageVersion, LibraryName ) import Distribution.System          ( OS(..), buildOS, Platform(..) ) import Distribution.Compiler-         ( CompilerId, CompilerFlavor(..) )+         ( AbiTag(..), abiTagString, CompilerInfo(..), CompilerFlavor(..) ) import Distribution.Text          ( display ) @@ -92,15 +71,15 @@ #endif  -- ------------------------------------------------------------------------------ Instalation directories+-- Installation directories   -- | The directories where we will install files for packages. -- -- We have several different directories for different types of files since -- many systems have conventions whereby different types of files in a package--- are installed in different direcotries. This is particularly the case on--- unix style systems.+-- are installed in different directories. This is particularly the case on+-- Unix style systems. -- data InstallDirs dir = InstallDirs {         prefix       :: dir,@@ -109,7 +88,6 @@         libsubdir    :: dir,         dynlibdir    :: dir,         libexecdir   :: dir,-        progdir      :: dir,         includedir   :: dir,         datadir      :: dir,         datasubdir   :: dir,@@ -118,8 +96,10 @@         htmldir      :: dir,         haddockdir   :: dir,         sysconfdir   :: dir-    } deriving (Read, Show)+    } deriving (Generic, Read, Show) +instance Binary dir => Binary (InstallDirs dir)+ instance Functor InstallDirs where   fmap f dirs = InstallDirs {     prefix       = f (prefix dirs),@@ -128,7 +108,6 @@     libsubdir    = f (libsubdir dirs),     dynlibdir    = f (dynlibdir dirs),     libexecdir   = f (libexecdir dirs),-    progdir      = f (progdir dirs),     includedir   = f (includedir dirs),     datadir      = f (datadir dirs),     datasubdir   = f (datasubdir dirs),@@ -147,7 +126,6 @@       libsubdir    = mempty,       dynlibdir    = mempty,       libexecdir   = mempty,-      progdir      = mempty,       includedir   = mempty,       datadir      = mempty,       datasubdir   = mempty,@@ -170,7 +148,6 @@     libsubdir    = libsubdir a  `combine` libsubdir b,     dynlibdir    = dynlibdir a  `combine` dynlibdir b,     libexecdir   = libexecdir a `combine` libexecdir b,-    progdir      = progdir a    `combine` progdir b,     includedir   = includedir a `combine` includedir b,     datadir      = datadir a    `combine` datadir b,     datasubdir   = datasubdir a `combine` datasubdir b,@@ -197,16 +174,16 @@ -- convenient for the user to override the default installation directory -- by only having to specify --prefix=... rather than overriding each -- individually. This is done by allowing $-style variables in the dirs.--- These are expanded by textual substituion (see 'substPathTemplate').+-- These are expanded by textual substitution (see 'substPathTemplate'). -- -- A few of these installation directories are split into two components, the -- dir and subdir. The full installation path is formed by combining the two--- together with @\/@. The reason for this is compatibility with other unix+-- together with @\/@. The reason for this is compatibility with other Unix -- build systems which also support @--libdir@ and @--datadir@. We would like -- users to be able to configure @--libdir=\/usr\/lib64@ for example but -- because by default we want to support installing multiple versions of -- packages and building the same package for multiple compilers we append the--- libsubdir to get: @\/usr\/lib64\/$pkgid\/$compiler@.+-- libsubdir to get: @\/usr\/lib64\/$libname\/$compiler@. -- -- An additional complication is the need to support relocatable packages on -- systems which support such things, like Windows.@@ -236,22 +213,20 @@       bindir       = "$prefix" </> "bin",       libdir       = installLibDir,       libsubdir    = case comp of-           Hugs   -> "hugs" </> "packages" </> "$pkg"            JHC    -> "$compiler"            LHC    -> "$compiler"            UHC    -> "$pkgid"-           _other -> "$arch-$os-$compiler" </> "$pkgid",+           _other -> "$abi" </> "$libname",       dynlibdir    = "$libdir",       libexecdir   = case buildOS of-        Windows   -> "$prefix" </> "$pkgid"+        Windows   -> "$prefix" </> "$libname"         _other    -> "$prefix" </> "libexec",-      progdir      = "$libdir" </> "hugs" </> "programs",       includedir   = "$libdir" </> "$libsubdir" </> "include",       datadir      = case buildOS of         Windows   -> "$prefix"         _other    -> "$prefix" </> "share",-      datasubdir   = "$arch-$os-$compiler" </> "$pkgid",-      docdir       = "$datadir" </> "doc" </> "$arch-$os-$compiler" </> "$pkgid",+      datasubdir   = "$abi" </> "$pkgid",+      docdir       = "$datadir" </> "doc" </> "$abi" </> "$pkgid",       mandir       = "$datadir" </> "man",       htmldir      = "$docdir"  </> "html",       haddockdir   = "$htmldir",@@ -285,7 +260,6 @@       libsubdir  = subst libsubdir  [],       dynlibdir  = subst dynlibdir  [prefixVar, bindirVar, libdirVar],       libexecdir = subst libexecdir prefixBinLibVars,-      progdir    = subst progdir    prefixBinLibVars,       includedir = subst includedir prefixBinLibVars,       datadir    = subst datadir    prefixBinLibVars,       datasubdir = subst datasubdir [],@@ -312,10 +286,14 @@ -- | Convert from abstract install directories to actual absolute ones by -- substituting for all the variables in the abstract paths, to get real -- absolute path.-absoluteInstallDirs :: PackageIdentifier -> CompilerId -> CopyDest -> Platform+absoluteInstallDirs :: PackageIdentifier+                    -> LibraryName+                    -> CompilerInfo+                    -> CopyDest+                    -> Platform                     -> InstallDirs PathTemplate                     -> InstallDirs FilePath-absoluteInstallDirs pkgId compilerId copydest platform dirs =+absoluteInstallDirs pkgId libname compilerId copydest platform dirs =     (case copydest of        CopyTo destdir -> fmap ((destdir </>) . dropDrive)        _              -> id)@@ -323,7 +301,7 @@   . fmap fromPathTemplate   $ substituteInstallDirTemplates env dirs   where-    env = initialPathTemplateEnv pkgId compilerId platform+    env = initialPathTemplateEnv pkgId libname compilerId platform   -- |The location prefix for the /copy/ command.@@ -338,10 +316,13 @@ -- prevents us from making a relocatable package (also known as a \"prefix -- independent\" package). ---prefixRelativeInstallDirs :: PackageIdentifier -> CompilerId -> Platform+prefixRelativeInstallDirs :: PackageIdentifier+                          -> LibraryName+                          -> CompilerInfo+                          -> Platform                           -> InstallDirTemplates                           -> InstallDirs (Maybe FilePath)-prefixRelativeInstallDirs pkgId compilerId platform dirs =+prefixRelativeInstallDirs pkgId libname compilerId platform dirs =     fmap relative   . appendSubdirs combinePathTemplate   $ -- substitute the path template into each other, except that we map@@ -351,7 +332,7 @@       prefix = PathTemplate [Variable PrefixVar]     }   where-    env = initialPathTemplateEnv pkgId compilerId platform+    env = initialPathTemplateEnv pkgId libname compilerId platform      -- If it starts with $prefix then it's relative and produce the relative     -- path by stripping off $prefix/ or $prefix@@ -365,16 +346,20 @@ -- --------------------------------------------------------------------------- -- Path templates --- | An abstract path, posibly containing variables that need to be+-- | An abstract path, possibly containing variables that need to be -- substituted for to get a real 'FilePath'. ---newtype PathTemplate = PathTemplate [PathComponent]+newtype PathTemplate = PathTemplate [PathComponent] deriving (Eq, Generic, Ord) +instance Binary PathTemplate+ data PathComponent =        Ordinary FilePath      | Variable PathTemplateVariable-     deriving Eq+     deriving (Eq, Ord, Generic) +instance Binary PathComponent+ data PathTemplateVariable =        PrefixVar     -- ^ The @$prefix@ path variable      | BindirVar     -- ^ The @$bindir@ path variable@@ -387,16 +372,21 @@      | PkgNameVar    -- ^ The @$pkg@ package name path variable      | PkgVerVar     -- ^ The @$version@ package version path variable      | PkgIdVar      -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@+     | LibNameVar    -- ^ The @$libname@ expanded package key path variable      | CompilerVar   -- ^ The compiler name and version, eg @ghc-6.6.1@      | OSVar         -- ^ The operating system name, eg @windows@ or @linux@-     | ArchVar       -- ^ The cpu architecture name, eg @i386@ or @x86_64@+     | ArchVar       -- ^ The CPU architecture name, eg @i386@ or @x86_64@+     | AbiVar        -- ^ The Compiler's ABI identifier, $arch-$os-$compiler-$abitag+     | AbiTagVar     -- ^ The optional ABI tag for the compiler      | ExecutableNameVar -- ^ The executable name; used in shell wrappers      | TestSuiteNameVar   -- ^ The name of the test suite being run      | TestSuiteResultVar -- ^ The result of the test suite being run, eg                           -- @pass@, @fail@, or @error@.      | BenchmarkNameVar   -- ^ The name of the benchmark being run-  deriving Eq+  deriving (Eq, Ord, Generic) +instance Binary PathTemplateVariable+ type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]  -- | Convert a 'FilePath' to a 'PathTemplate' including any template vars.@@ -424,23 +414,28 @@                   Nothing                        -> [component]  -- | The initial environment has all the static stuff but no paths-initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> Platform+initialPathTemplateEnv :: PackageIdentifier+                       -> LibraryName+                       -> CompilerInfo+                       -> Platform                        -> PathTemplateEnv-initialPathTemplateEnv pkgId compilerId platform =-     packageTemplateEnv  pkgId-  ++ compilerTemplateEnv compilerId+initialPathTemplateEnv pkgId libname compiler platform =+     packageTemplateEnv  pkgId libname+  ++ compilerTemplateEnv compiler   ++ platformTemplateEnv platform+  ++ abiTemplateEnv compiler platform -packageTemplateEnv :: PackageIdentifier -> PathTemplateEnv-packageTemplateEnv pkgId =+packageTemplateEnv :: PackageIdentifier -> LibraryName -> PathTemplateEnv+packageTemplateEnv pkgId libname =   [(PkgNameVar,  PathTemplate [Ordinary $ display (packageName pkgId)])   ,(PkgVerVar,   PathTemplate [Ordinary $ display (packageVersion pkgId)])+  ,(LibNameVar,  PathTemplate [Ordinary $ display libname])   ,(PkgIdVar,    PathTemplate [Ordinary $ display pkgId])   ] -compilerTemplateEnv :: CompilerId -> PathTemplateEnv-compilerTemplateEnv compilerId =-  [(CompilerVar, PathTemplate [Ordinary $ display compilerId])+compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv+compilerTemplateEnv compiler =+  [(CompilerVar, PathTemplate [Ordinary $ display (compilerInfoId compiler)])   ]  platformTemplateEnv :: Platform -> PathTemplateEnv@@ -449,6 +444,16 @@   ,(ArchVar,     PathTemplate [Ordinary $ display arch])   ] +abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv+abiTemplateEnv compiler (Platform arch os) =+  [(AbiVar,      PathTemplate [Ordinary $ display arch ++ '-':display os +++                                          '-':display (compilerInfoId compiler) +++                                          case compilerInfoAbiTag compiler of+                                            NoAbiTag   -> ""+                                            AbiTag tag -> '-':tag])+  ,(AbiTagVar,   PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)])+  ]+ installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv installDirsTemplateEnv dirs =   [(PrefixVar,     prefix     dirs)@@ -473,6 +478,7 @@  instance Show PathTemplateVariable where   show PrefixVar     = "prefix"+  show LibNameVar     = "libname"   show BindirVar     = "bindir"   show LibdirVar     = "libdir"   show LibsubdirVar  = "libsubdir"@@ -486,6 +492,8 @@   show CompilerVar   = "compiler"   show OSVar         = "os"   show ArchVar       = "arch"+  show AbiTagVar     = "abitag"+  show AbiVar        = "abi"   show ExecutableNameVar = "executablename"   show TestSuiteNameVar   = "test-suite"   show TestSuiteResultVar = "result"@@ -497,6 +505,7 @@     [ (var, drop (length varStr) s)     | (varStr, var) <- vars     , varStr `isPrefixOf` s ]+    -- NB: order matters! Longer strings first     where vars = [("prefix",     PrefixVar)                  ,("bindir",     BindirVar)                  ,("libdir",     LibdirVar)@@ -506,11 +515,15 @@                  ,("docdir",     DocdirVar)                  ,("htmldir",    HtmldirVar)                  ,("pkgid",      PkgIdVar)+                 ,("pkgkey",     LibNameVar) -- backwards compatibility+                 ,("libname",    LibNameVar)                  ,("pkg",        PkgNameVar)                  ,("version",    PkgVerVar)                  ,("compiler",   CompilerVar)                  ,("os",         OSVar)                  ,("arch",       ArchVar)+                 ,("abitag",     AbiTagVar)+                 ,("abi",        AbiVar)                  ,("executablename", ExecutableNameVar)                  ,("test-suite", TestSuiteNameVar)                  ,("result", TestSuiteResultVar)@@ -522,7 +535,7 @@   showList = foldr (\x -> (shows x .)) id  instance Read PathComponent where-  -- for some reason we colapse multiple $ symbols here+  -- for some reason we collapse multiple $ symbols here   readsPrec _ = lex0     where lex0 [] = []           lex0 ('$':'$':s') = lex0 ('$':s')@@ -577,7 +590,13 @@ -- csidl_PROGRAM_FILES_COMMON :: CInt -- csidl_PROGRAM_FILES_COMMON = 0x002b -foreign import stdcall unsafe "shlobj.h SHGetFolderPathW"+#ifdef x86_64_HOST_ARCH+#define CALLCONV ccall+#else+#define CALLCONV stdcall+#endif++foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW"             c_SHGetFolderPath :: Ptr ()                               -> CInt                               -> Ptr ()

cabal/Cabal/Distribution/Simple/JHC.hs view

@@ -2,6 +2,7 @@ -- | -- Module      :  Distribution.Simple.JHC -- Copyright   :  Isaac Jones 2003-2006+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -9,39 +10,6 @@ -- This module contains most of the JHC-specific code for configuring, building -- and installing packages. -{--Copyright (c) 2009, Henning Thielemann-Copyright (c) 2003-2005, Isaac Jones-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. -}- module Distribution.Simple.JHC (         configure, getInstalledPackages,         buildLib, buildExe,@@ -54,14 +22,14 @@ import Distribution.InstalledPackageInfo          ( emptyInstalledPackageInfo, ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) import Distribution.Simple.BuildPaths                                 ( autogenModulesDir, exeExtension ) import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..), Compiler(..)+         ( CompilerFlavor(..), CompilerId(..), Compiler(..), AbiTag(..)          , PackageDBStack, Flag, languageToFlags, extensionsToFlags ) import Language.Haskell.Extension          ( Language(Haskell98), Extension(..), KnownExtension(..))@@ -108,6 +76,8 @@   let Just version = programVersion jhcProg       comp = Compiler {         compilerId             = CompilerId JHC version,+        compilerAbiTag         = NoAbiTag,+        compilerCompat         = [],         compilerLanguages      = jhcLanguages,         compilerExtensions     = jhcLanguageExtensions,         compilerProperties     = M.empty@@ -132,7 +102,7 @@     ]  getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration-                    -> IO PackageIndex+                    -> IO InstalledPackageIndex getInstalledPackages verbosity _packageDBs conf = do    -- jhc --list-libraries lists all available libraries.    -- How shall I find out, whether they are global or local

cabal/Cabal/Distribution/Simple/LHC.hs view

@@ -1,7 +1,9 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.LHC -- Copyright   :  Isaac Jones 2003-2007+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -29,65 +31,35 @@ -- explicitly documented) and thus what search dirs are used for various kinds -- of files. -{- Copyright (c) 2003-2005, Isaac Jones-All rights reserved.--Redistribution and use in source and binary forms, with or without-modiication, 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. -}- module Distribution.Simple.LHC (         configure, getInstalledPackages,         buildLib, buildExe,         installLib, installExe,         registerPackage,+        hcPkgInfo,         ghcOptions,         ghcVerbosityOptions  ) where  import Distribution.PackageDescription as PD          ( PackageDescription(..), BuildInfo(..), Executable(..)-         , Library(..), libModules, hcOptions, usedExtensions, allExtensions )+         , Library(..), libModules, hcOptions, hcProfOptions, hcSharedOptions+         , usedExtensions, allExtensions ) import Distribution.InstalledPackageInfo                                 ( InstalledPackageInfo                                 , parseInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-                                ( InstalledPackageInfo_(..) )+                                ( InstalledPackageInfo(..) ) import Distribution.Simple.PackageIndex import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.ParseUtils  ( ParseResult(..) ) import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..),-           LibraryName(..) )+         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) import Distribution.Simple.InstallDirs import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package-         ( Package(..) )+         ( Package(..), LibraryName, getHSLibraryName ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program          ( Program(..), ConfiguredProgram(..), ProgramConfiguration@@ -102,7 +74,7 @@ import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Compiler          ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion-         , OptimisationLevel(..), PackageDB(..), PackageDBStack+         , OptimisationLevel(..), PackageDB(..), PackageDBStack, AbiTag(..)          , Flag, languageToFlags, extensionsToFlags ) import Distribution.Version          ( Version(..), orLaterVersion )@@ -118,7 +90,9 @@ import Data.List import qualified Data.Map as M  ( empty ) import Data.Maybe               ( catMaybes )+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid              ( Monoid(..) )+#endif import System.Directory         ( removeFile, renameFile,                                   getDirectoryContents, doesFileExist,                                   getTemporaryDirectory )@@ -155,6 +129,8 @@    let comp = Compiler {         compilerId             = CompilerId LHC lhcVersion,+        compilerAbiTag         = NoAbiTag,+        compilerCompat         = [],         compilerLanguages      = languages,         compilerExtensions     = extensions,         compilerProperties     = M.empty@@ -248,7 +224,7 @@              | Just ext <- map readExtension (lines exts) ]  getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration-                     -> IO PackageIndex+                     -> IO InstalledPackageIndex getInstalledPackages verbosity packagedbs conf = do   checkPackageDbStack packagedbs   pkgss <- getInstalledPackages' lhcPkg verbosity packagedbs conf@@ -342,12 +318,8 @@ buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo                       -> Library            -> ComponentLocalBuildInfo -> IO () buildLib verbosity pkg_descr lbi lib clbi = do-  libName <- case componentLibraries clbi of-             [libName] -> return libName-             [] -> die "No library name found when building library"-             _  -> die "Multiple library names found when building library"--  let pref = buildDir lbi+  let libName = componentLibraryName clbi+      pref = buildDir lbi       pkgid = packageId pkg_descr       runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)       ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi)@@ -363,7 +335,7 @@       -- TH always needs vanilla libs, even when building for profiling    createDirectoryIfMissingVerbose verbosity True libTargetDir-  -- TODO: do we need to put hs-boot files into place for mutually recurive modules?+  -- TODO: do we need to put hs-boot files into place for mutually recursive modules?   let ghcArgs =              ["-package-name", display pkgid ]           ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity@@ -374,13 +346,13 @@               "-hisuf", "p_hi",               "-osuf", "p_o"              ]-          ++ ghcProfOptions libBi+          ++ hcProfOptions GHC libBi       ghcArgsShared = ghcArgs           ++ ["-dynamic",               "-hisuf", "dyn_hi",               "-osuf", "dyn_o", "-fPIC"              ]-          ++ ghcSharedOptions libBi+          ++ hcSharedOptions GHC libBi   unless (null (libModules lib)) $     do ifVanillaLib forceVanillaLib (runGhcProg $ lhcWrap ghcArgs)        ifProfLib (runGhcProg $ lhcWrap ghcArgsProf)@@ -490,10 +462,10 @@          runAr = rawSystemProgramConf 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-         -- but all sensible unixes use more than 4k.-         -- we could use getSysVar ArgumentLimit but that's in the unix lib+         --TODO: discover this at configure time or runtime on Unix+         -- The value is 32k on Windows and POSIX specifies a minimum of 4k+         -- but all sensible Unixes use more than 4k.+         -- we could use getSysVar ArgumentLimit but that's in the Unix lib         maxCommandLineSize = 30 * 1024      ifVanillaLib False $ xargs maxCommandLineSize@@ -559,7 +531,7 @@                 then ["-prof",                       "-hisuf", "p_hi",                       "-osuf", "p_o"-                     ] ++ ghcProfOptions exeBi+                     ] ++ hcProfOptions GHC exeBi                 else []    -- For building exe's for profiling that use TH we actually@@ -711,7 +683,7 @@      ++ ["-odir", odir]  mkGHCiLibName :: LibraryName -> String-mkGHCiLibName (LibraryName lib) = lib <.> "o"+mkGHCiLibName lib = getHSLibraryName lib <.> "o"  -- ----------------------------------------------------------------------------- -- Installing@@ -758,7 +730,7 @@ installLib    :: Verbosity               -> LocalBuildInfo               -> FilePath  -- ^install location-              -> FilePath  -- ^install location for dynamic librarys+              -> FilePath  -- ^install location for dynamic libraries               -> FilePath  -- ^Build location               -> PackageDescription               -> Library@@ -778,18 +750,18 @@   flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase </> srcFile]    -- copy the built library files over:-  ifVanilla $ mapM_ (copy builtDir targetDir)       vanillaLibNames-  ifProf    $ mapM_ (copy builtDir targetDir)       profileLibNames-  ifGHCi    $ mapM_ (copy builtDir targetDir)       ghciLibNames-  ifShared  $ mapM_ (copy builtDir dynlibTargetDir) sharedLibNames+  ifVanilla $ copy builtDir targetDir       vanillaLibName+  ifProf    $ copy builtDir targetDir       profileLibName+  ifGHCi    $ copy builtDir targetDir       ghciLibName+  ifShared  $ copy builtDir dynlibTargetDir sharedLibName    where     cid = compilerId (compiler lbi)-    libNames = componentLibraries clbi-    vanillaLibNames = map mkLibName             libNames-    profileLibNames = map mkProfLibName         libNames-    ghciLibNames    = map mkGHCiLibName         libNames-    sharedLibNames  = map (mkSharedLibName cid) libNames+    libName = componentLibraryName clbi+    vanillaLibName = mkLibName           libName+    profileLibName = mkProfLibName       libName+    ghciLibName    = mkGHCiLibName       libName+    sharedLibName  = mkSharedLibName cid libName      hasLib    = not $ null (libModules lib)                    && null (cSources (libBuildInfo lib))@@ -811,6 +783,16 @@   -> Bool   -> PackageDBStack   -> IO ()-registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do-  let Just lhcPkg = lookupProgram lhcPkgProgram (withPrograms lbi)-  HcPkg.reregister verbosity lhcPkg packageDbs (Right installedPkgInfo)+registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs =+  HcPkg.reregister (hcPkgInfo $ withPrograms lbi) 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.useSingleFileDb = True+                                 }+  where+    Just lhcPkgProg = lookupProgram lhcPkgProgram conf

cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs view

@@ -1,7 +1,10 @@+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.LocalBuildInfo -- Copyright   :  Isaac Jones 2003-2004+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -14,47 +17,18 @@ -- flags. It gets saved and reloaded from a file (@dist\/setup-config@). It gets -- passed in to very many subsequent build actions. -{- 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. -}- module Distribution.Simple.LocalBuildInfo (         LocalBuildInfo(..),         externalPackageDeps,         inplacePackageId,+        localPackageKey,+        localLibraryName,          -- * Buildable package components         Component(..),         ComponentName(..),         showComponentName,         ComponentLocalBuildInfo(..),-        LibraryName(..),         foldComponent,         componentName,         componentBuildInfo,@@ -69,6 +43,7 @@         allComponentsInBuildOrder,         componentsInBuildOrder,         checkComponentsCyclic,+        depLibraryPaths,          withAllComponentsInBuildOrder,         withComponentsInBuildOrder,@@ -89,28 +64,41 @@                                                substPathTemplate, ) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.Program (ProgramConfiguration)+import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.PackageDescription          ( PackageDescription(..), withLib, Library(libBuildInfo), withExe          , Executable(exeName, buildInfo), withTest, TestSuite(..)-         , BuildInfo(buildable), Benchmark(..) )+         , BuildInfo(buildable), Benchmark(..), ModuleRenaming(..) )+import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package-         ( PackageId, Package(..), InstalledPackageId(..) )+         ( PackageId, Package(..), InstalledPackageId(..)+         , PackageName, LibraryName(..), PackageKey(..) ) import Distribution.Simple.Compiler-         ( Compiler(..), PackageDBStack, OptimisationLevel )+         ( Compiler, compilerInfo, PackageDBStack, DebugInfoLevel+         , OptimisationLevel, ProfDetailLevel ) import Distribution.Simple.PackageIndex-         ( PackageIndex )+         ( InstalledPackageIndex, allPackages )+import Distribution.ModuleName ( ModuleName ) import Distribution.Simple.Setup          ( ConfigFlags )+import Distribution.Simple.Utils+         ( shortRelativePath ) import Distribution.Text          ( display ) import Distribution.System-          ( Platform )-import Data.List (nub, find)-import Data.Graph-import Data.Tree  (flatten)+         ( Platform (..) )+ 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.Map (Map) +import System.Directory (doesDirectoryExist, canonicalizePath)+ -- | Data cached after configuration step.  See also -- 'Distribution.Simple.Setup.ConfigFlags'. data LocalBuildInfo = LocalBuildInfo {@@ -121,7 +109,7 @@         -- ^ 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 differnt+                -- ^ The installation directories for the various different                 -- kinds of files         --TODO: inplaceDirTemplates :: InstallDirs FilePath         compiler      :: Compiler,@@ -130,13 +118,10 @@                 -- ^ The platform we're building for         buildDir      :: FilePath,                 -- ^ Where to build the package.-        --TODO: eliminate hugs's scratchDir, use builddir-        scratchDir    :: FilePath,-                -- ^ Where to put the result of the Hugs build.         componentsConfigs   :: [(ComponentName, ComponentLocalBuildInfo, [ComponentName])],                 -- ^ All the components to build, ordered by topological sort, and with their dependencies                 -- over the intrapackage dependency graph-        installedPkgs :: PackageIndex,+        installedPkgs :: InstalledPackageIndex,                 -- ^ All the info about the installed packages that the                 -- current package depends on (directly or indirectly).         pkgDescrFile  :: Maybe FilePath,@@ -144,6 +129,7 @@         localPkgDescr :: PackageDescription,                 -- ^ The resolved package description, that does not contain                 -- any conditionals.+        instantiatedWith :: [(ModuleName, (InstalledPackageInfo, ModuleName))],         withPrograms  :: ProgramConfiguration, -- ^Location and args for all programs         withPackageDB :: PackageDBStack,  -- ^What package database to use, global\/user         withVanillaLib:: Bool,  -- ^Whether to build normal libs.@@ -151,15 +137,41 @@         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-  } deriving (Read, Show)+        progSuffix    :: PathTemplate, -- ^Suffix to be appended to installed executables+        relocatable   :: Bool --  ^Whether to build a relocatable package+  } deriving (Generic, Read, Show) +instance Binary LocalBuildInfo++-- | Extract the 'PackageKey' from the library component of a+-- 'LocalBuildInfo' if it exists, or make a fake package key based+-- on the package ID.+localPackageKey :: LocalBuildInfo -> PackageKey+localPackageKey lbi =+    foldr go (OldPackageKey (package (localPkgDescr lbi))) (componentsConfigs lbi)+  where go (_, clbi, _) old_pk = case clbi of+            LibComponentLocalBuildInfo { componentPackageKey = pk } -> pk+            _ -> old_pk++-- | Extract the 'LibraryName' from the library component of a+-- 'LocalBuildInfo' if it exists, or make a library name based+-- on the package ID.+localLibraryName :: LocalBuildInfo -> LibraryName+localLibraryName lbi =+    foldr go (LibraryName (display (package (localPkgDescr lbi)))) (componentsConfigs lbi)+  where go (_, clbi, _) old_n = case clbi of+            LibComponentLocalBuildInfo { componentLibraryName = n } -> n+            _ -> old_n+ -- | External package dependencies for the package as a whole. This is the -- union of the individual 'componentPackageDeps', less any internal deps. externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)]@@ -193,8 +205,10 @@                    | CExeName   String                    | CTestName  String                    | CBenchName String-                   deriving (Show, Eq, Ord, Read)+                   deriving (Eq, Generic, Ord, Read, Show) +instance Binary ComponentName+ showComponentName :: ComponentName -> String showComponentName CLibName          = "library" showComponentName (CExeName   name) = "executable '" ++ name ++ "'"@@ -208,19 +222,27 @@     -- satisfied in terms of version ranges. This field fixes those dependencies     -- to the specific versions available on this machine for this compiler.     componentPackageDeps :: [(InstalledPackageId, PackageId)],-    componentLibraries :: [LibraryName]+    componentPackageKey :: PackageKey,+    componentLibraryName :: LibraryName,+    componentExposedModules :: [Installed.ExposedModule],+    componentPackageRenaming :: Map PackageName ModuleRenaming   }   | ExeComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)]+    componentPackageDeps :: [(InstalledPackageId, PackageId)],+    componentPackageRenaming :: Map PackageName ModuleRenaming   }   | TestComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)]+    componentPackageDeps :: [(InstalledPackageId, PackageId)],+    componentPackageRenaming :: Map PackageName ModuleRenaming   }   | BenchComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)]+    componentPackageDeps :: [(InstalledPackageId, PackageId)],+    componentPackageRenaming :: Map PackageName ModuleRenaming   }-  deriving (Read, Show)+  deriving (Generic, Read, Show) +instance Binary ComponentLocalBuildInfo+ foldComponent :: (Library -> a)               -> (Executable -> a)               -> (TestSuite -> a)@@ -232,9 +254,6 @@ foldComponent _ _ f _ (CTest  tst) = f tst foldComponent _ _ _ f (CBench bch) = f bch -data LibraryName = LibraryName String-    deriving (Read, Show)- componentBuildInfo :: Component -> BuildInfo componentBuildInfo =   foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo@@ -407,7 +426,63 @@          []    -> Nothing          (c:_) -> Just (map vertexToNode c) +-- | Determine the directories containing the dynamic libraries of the+-- transitive dependencies of the component we are building.+--+-- When wanted, and possible, returns paths relative to the installDirs 'prefix'+depLibraryPaths :: Bool -- ^ Building for inplace?+                -> Bool -- ^ Generate prefix-relative library paths+                -> LocalBuildInfo+                -> ComponentLocalBuildInfo -- ^ Component that is being built+                -> IO [FilePath]+depLibraryPaths inplace relative lbi clbi = do+    let pkgDescr    = localPkgDescr lbi+        installDirs = absoluteInstallDirs pkgDescr lbi NoCopyDest+        executable  = case clbi of+                        ExeComponentLocalBuildInfo {} -> True+                        _                             -> False+        relDir | executable = bindir installDirs+               | otherwise  = libdir installDirs +    let hasInternalDeps = not $ null+                        $ [ pkgid+                          | (_,pkgid) <- componentPackageDeps clbi+                          , internal pkgid+                          ]++    let ipkgs          = allPackages (installedPkgs lbi)+        allDepLibDirs  = concatMap Installed.libraryDirs ipkgs+        internalLib+          | inplace    = buildDir lbi+          | otherwise  = libdir installDirs+        allDepLibDirs' = if hasInternalDeps+                            then internalLib : allDepLibDirs+                            else allDepLibDirs+    allDepLibDirsC <- mapM canonicalizePathNoFail allDepLibDirs'++    let p                = prefix installDirs+        prefixRelative l = isJust (stripPrefix p l)+        libPaths+          | relative &&+            prefixRelative relDir = map (\l ->+                                          if prefixRelative l+                                             then shortRelativePath relDir l+                                             else l+                                        ) allDepLibDirsC+          | otherwise             = allDepLibDirsC++    return libPaths+  where+    internal pkgid = pkgid == packageId (localPkgDescr lbi)+    -- 'canonicalizePath' fails on UNIX when the directory does not exists.+    -- So just don't canonicalize when it doesn't exist.+    canonicalizePathNoFail p = do+      exists <- doesDirectoryExist p+      if exists+         then canonicalizePath p+         else return p++ -- ----------------------------------------------------------------------------- -- Wrappers for a couple functions from InstallDirs @@ -417,7 +492,8 @@ absoluteInstallDirs pkg lbi copydest =   InstallDirs.absoluteInstallDirs     (packageId pkg)-    (compilerId (compiler lbi))+    (localLibraryName lbi)+    (compilerInfo (compiler lbi))     copydest     (hostPlatform lbi)     (installDirTemplates lbi)@@ -428,7 +504,8 @@ prefixRelativeInstallDirs pkg_descr lbi =   InstallDirs.prefixRelativeInstallDirs     (packageId pkg_descr)-    (compilerId (compiler lbi))+    (localLibraryName lbi)+    (compilerInfo (compiler lbi))     (hostPlatform lbi)     (installDirTemplates lbi) @@ -438,5 +515,6 @@                                 . ( InstallDirs.substPathTemplate env )     where env = initialPathTemplateEnv                    pkgid-                   (compilerId (compiler lbi))+                   (localLibraryName lbi)+                   (compilerInfo (compiler lbi))                    (hostPlatform lbi)

− cabal/Cabal/Distribution/Simple/NHC.hs

@@ -1,436 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.NHC--- Copyright   :  Isaac Jones 2003-2006---                Duncan Coutts 2009------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module contains most of the NHC-specific code for configuring, building--- and installing packages.--{- Copyright (c) 2003-2005, Isaac Jones-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. -}--module Distribution.Simple.NHC (-    configure,-    getInstalledPackages,-    buildLib,-    buildExe,-    installLib,-    installExe,-  ) where--import Distribution.Package-         ( PackageName, PackageIdentifier(..), InstalledPackageId(..)-         , packageName )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo-         , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId-                                , sourcePackageId )-         , emptyInstalledPackageInfo, parseInstalledPackageInfo )-import Distribution.PackageDescription-        ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)-        , hcOptions, usedExtensions )-import Distribution.ModuleName (ModuleName)-import qualified Distribution.ModuleName as ModuleName-import Distribution.Simple.LocalBuildInfo-        ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) )-import Distribution.Simple.BuildPaths-        ( mkLibName, objExtension, exeExtension )-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..), Compiler(..)-         , Flag, languageToFlags, extensionsToFlags-         , PackageDB(..), PackageDBStack )-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (PackageIndex)-import Language.Haskell.Extension-         ( Language(Haskell98), Extension(..), KnownExtension(..) )-import Distribution.Simple.Program-         ( ProgramConfiguration, userMaybeSpecifyPath, programPath-         , requireProgram, requireProgramVersion, lookupProgram-         , nhcProgram, hmakeProgram, ldProgram, arProgram-         , rawSystemProgramConf )-import Distribution.Simple.Utils-        ( die, info, findFileWithExtension, findModuleFiles-        , installOrdinaryFile, installExecutableFile, installOrdinaryFiles-        , createDirectoryIfMissingVerbose, withUTF8FileContents )-import Distribution.Version-        ( Version(..), orLaterVersion )-import Distribution.Verbosity-import Distribution.Text-         ( display, simpleParse )-import Distribution.ParseUtils-         ( ParseResult(..) )--import System.FilePath-        ( (</>), (<.>), normalise, takeDirectory, dropExtension )-import System.Directory-         ( doesFileExist, doesDirectoryExist, getDirectoryContents-         , removeFile, getHomeDirectory )--import Data.Char               ( toLower )-import Data.List               ( nub )-import Data.Maybe              ( catMaybes )-import qualified Data.Map as M ( empty )-import Data.Monoid             ( Monoid(..) )-import Control.Monad           ( when, unless )-import Distribution.Compat.Exception-import Distribution.System ( Platform )---- -------------------------------------------------------------------------------- Configuring--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration)-configure verbosity hcPath _hcPkgPath conf = do--  (_nhcProg, nhcVersion, conf') <--    requireProgramVersion verbosity nhcProgram-      (orLaterVersion (Version [1,20] []))-      (userMaybeSpecifyPath "nhc98" hcPath conf)--  (_hmakeProg, _hmakeVersion, conf'') <--    requireProgramVersion verbosity hmakeProgram-     (orLaterVersion (Version [3,13] [])) conf'-  (_ldProg, conf''')   <- requireProgram verbosity ldProgram conf''-  (_arProg, conf'''')  <- requireProgram verbosity arProgram conf'''--  --TODO: put this stuff in a monad so we can say just:-  -- requireProgram hmakeProgram (orLaterVersion (Version [3,13] []))-  -- requireProgram ldProgram anyVersion-  -- requireProgram ldPrograrProgramam anyVersion-  -- unless (null (cSources bi)) $ requireProgram ccProgram anyVersion--  let comp = Compiler {-        compilerId         = CompilerId NHC nhcVersion,-        compilerLanguages  = nhcLanguages,-        compilerExtensions = nhcLanguageExtensions,-        compilerProperties = M.empty-      }-      compPlatform = Nothing-  return (comp, compPlatform,  conf'''')--nhcLanguages :: [(Language, Flag)]-nhcLanguages = [(Haskell98, "-98")]---- | The flags for the supported extensions-nhcLanguageExtensions :: [(Extension, Flag)]-nhcLanguageExtensions =-    -- TODO: pattern guards in 1.20-     -- NHC doesn't enforce the monomorphism restriction at all.-     -- Technically it therefore doesn't support MonomorphismRestriction,-     -- but that would mean it doesn't support Haskell98, so we pretend-     -- that it does.-    [(EnableExtension  MonomorphismRestriction,   "")-    ,(DisableExtension MonomorphismRestriction,   "")-     -- Similarly, I assume the FFI is always on-    ,(EnableExtension  ForeignFunctionInterface,  "")-    ,(DisableExtension ForeignFunctionInterface,  "")-     -- Similarly, I assume existential quantification is always on-    ,(EnableExtension  ExistentialQuantification, "")-    ,(DisableExtension ExistentialQuantification, "")-     -- Similarly, I assume empty data decls is always on-    ,(EnableExtension  EmptyDataDecls,            "")-    ,(DisableExtension EmptyDataDecls,            "")-    ,(EnableExtension  NamedFieldPuns,            "-puns")-    ,(DisableExtension NamedFieldPuns,            "-nopuns")-     -- CPP can't actually be turned off, but we pretend that it can-    ,(EnableExtension  CPP,                       "-cpp")-    ,(DisableExtension CPP,                       "")-    ]--getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration-                     -> IO PackageIndex-getInstalledPackages verbosity packagedbs conf = do-  homedir      <- getHomeDirectory-  (nhcProg, _) <- requireProgram verbosity nhcProgram conf-  let bindir = takeDirectory (programPath nhcProg)-      incdir = takeDirectory bindir </> "include" </> "nhc98"-      dbdirs = nub (concatMap (packageDbPaths homedir incdir) packagedbs)-  indexes  <- mapM getIndividualDBPackages dbdirs-  return $! mconcat indexes--  where-    getIndividualDBPackages :: FilePath -> IO PackageIndex-    getIndividualDBPackages dbdir = do-      pkgdirs <- getPackageDbDirs dbdir-      pkgs    <- sequence [ getInstalledPackage pkgname pkgdir-                          | (pkgname, pkgdir) <- pkgdirs ]-      let pkgs' = map setInstalledPackageId (catMaybes pkgs)-      return (PackageIndex.fromList pkgs')--packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath]-packageDbPaths _home incdir db = case db of-  GlobalPackageDB        -> [ incdir </> "packages" ]-  UserPackageDB          -> [] --TODO any standard per-user db?-  SpecificPackageDB path -> [ path ]--getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)]-getPackageDbDirs dbdir = do-  dbexists <- doesDirectoryExist dbdir-  if not dbexists-    then return []-    else do-      entries  <- getDirectoryContents dbdir-      pkgdirs  <- sequence-        [ do pkgdirExists <- doesDirectoryExist pkgdir-             return (pkgname, pkgdir, pkgdirExists)-        | (entry, Just pkgname) <- [ (entry, simpleParse entry)-                                   | entry <- entries ]-        , let pkgdir = dbdir </> entry ]-      return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ]--getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo)-getInstalledPackage pkgname pkgdir = do-  let pkgconfFile = pkgdir </> "package.conf"-  pkgconfExists <- doesFileExist pkgconfFile--  let cabalFile = pkgdir <.> "cabal"-  cabalExists <- doesFileExist cabalFile--  case () of-    _ | pkgconfExists -> getFullInstalledPackageInfo pkgname pkgconfFile-      | cabalExists   -> getPhonyInstalledPackageInfo pkgname cabalFile-      | otherwise     -> return Nothing--getFullInstalledPackageInfo :: PackageName -> FilePath-                            -> IO (Maybe InstalledPackageInfo)-getFullInstalledPackageInfo pkgname pkgconfFile =-  withUTF8FileContents pkgconfFile $ \contents ->-    case parseInstalledPackageInfo contents of-      ParseOk _ pkginfo | packageName pkginfo == pkgname-                        -> return (Just pkginfo)-      _                 -> return Nothing---- | This is a backup option for existing versions of nhc98 which do not supply--- proper installed package info files for the bundled libs. Instead we look--- for the .cabal file and extract the package version from that.--- We don't know any other details for such packages, in particular we pretend--- that they have no dependencies.----getPhonyInstalledPackageInfo :: PackageName -> FilePath-                             -> IO (Maybe InstalledPackageInfo)-getPhonyInstalledPackageInfo pkgname pathsModule = do-  content <- readFile pathsModule-  case extractVersion content of-    Nothing      -> return Nothing-    Just version -> return (Just pkginfo)-      where-        pkgid   = PackageIdentifier pkgname version-        pkginfo = emptyInstalledPackageInfo { sourcePackageId = pkgid }-  where-    -- search through the .cabal file, looking for a line like:-    ---    -- > version: 2.0-    ---    extractVersion :: String -> Maybe Version-    extractVersion content =-      case catMaybes (map extractVersionLine (lines content)) of-        [version] -> Just version-        _         -> Nothing-    extractVersionLine :: String -> Maybe Version-    extractVersionLine line =-      case words line of-        [versionTag, ":", versionStr]-          | map toLower versionTag == "version"  -> simpleParse versionStr-        [versionTag,      versionStr]-          | map toLower versionTag == "version:" -> simpleParse versionStr-        _                                        -> Nothing---- Older installed package info files did not have the installedPackageId--- field, so if it is missing then we fill it as the source package ID.-setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo-setInstalledPackageId pkginfo@InstalledPackageInfo {-                        installedPackageId = InstalledPackageId "",-                        sourcePackageId    = pkgid-                      }-                    = pkginfo {-                        --TODO use a proper named function for the conversion-                        -- from source package id to installed package id-                        installedPackageId = InstalledPackageId (display pkgid)-                      }-setInstalledPackageId pkginfo = pkginfo---- -------------------------------------------------------------------------------- Building---- |FIX: For now, the target must contain a main module.  Not used--- ATM. Re-add later.-buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity pkg_descr lbi lib clbi = do-  libName <- case componentLibraries clbi of-             [libName] -> return libName-             [] -> die "No library name found when building library"-             _  -> die "Multiple library names found when building library"-  let conf = withPrograms lbi-      Just nhcProg = lookupProgram nhcProgram conf-  let bi = libBuildInfo lib-      modules = exposedModules lib ++ otherModules bi-      -- Unsupported extensions have already been checked by configure-      languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi)-                   ++ extensionsToFlags (compiler lbi) (usedExtensions bi)-  inFiles <- getModulePaths lbi bi modules-  let targetDir = buildDir lbi-      srcDirs  = nub (map takeDirectory inFiles)-      destDirs = map (targetDir </>) srcDirs-  mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs-  rawSystemProgramConf verbosity hmakeProgram conf $-       ["-hc=" ++ programPath nhcProg]-    ++ nhcVerbosityOptions verbosity-    ++ ["-d", targetDir, "-hidir", targetDir]-    ++ maybe [] (hcOptions NHC . libBuildInfo)-                           (library pkg_descr)-    ++ languageFlags-    ++ concat [ ["-package", display (packageName pkgid) ]-              | (_, pkgid) <- componentPackageDeps clbi ]-    ++ inFiles-{--  -- build any C sources-  unless (null (cSources bi)) $ do-     info verbosity "Building C Sources..."-     let commonCcArgs = (if verbosity >= deafening then ["-v"] else [])-                     ++ ["-I" ++ dir | dir <- includeDirs bi]-                     ++ [opt | opt <- ccOptions bi]-                     ++ (if withOptimization lbi then ["-O2"] else [])-     flip mapM_ (cSources bi) $ \cfile -> do-       let ofile = targetDir </> cfile `replaceExtension` objExtension-       createDirectoryIfMissingVerbose verbosity True (takeDirectory ofile)-       rawSystemProgramConf verbosity hmakeProgram conf-         (commonCcArgs ++ ["-c", cfile, "-o", ofile])--}-  -- link:-  info verbosity "Linking..."-  let --cObjs = [ targetDir </> cFile `replaceExtension` objExtension-      --        | cFile <- cSources bi ]-      libFilePath = targetDir </> mkLibName libName-      hObjs = [ targetDir </> ModuleName.toFilePath m <.> objExtension-              | m <- modules ]--  unless (null hObjs {-&& null cObjs-}) $ do-    -- first remove library if it exists-    removeFile libFilePath `catchIO` \_ -> return ()--    let arVerbosity | verbosity >= deafening = "v"-                    | verbosity >= normal = ""-                    | otherwise = "c"--    rawSystemProgramConf verbosity arProgram (withPrograms lbi) $-         ["q"++ arVerbosity, libFilePath]-      ++ hObjs---    ++ cObjs---- | Building an executable for NHC.-buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe verbosity pkg_descr lbi exe clbi = do-  let conf = withPrograms lbi-      Just nhcProg = lookupProgram nhcProgram conf-  when (dropExtension (modulePath exe) /= exeName exe) $-    die $ "hmake does not support exe names that do not match the name of "-       ++ "the 'main-is' file. You will have to rename your executable to "-       ++ show (dropExtension (modulePath exe))-  let bi = buildInfo exe-      modules = otherModules bi-      -- Unsupported extensions have already been checked by configure-      languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi)-                   ++ extensionsToFlags (compiler lbi) (usedExtensions bi)-  inFiles <- getModulePaths lbi bi modules-  let targetDir = buildDir lbi </> exeName exe-      exeDir    = targetDir </> (exeName exe ++ "-tmp")-      srcDirs   = nub (map takeDirectory (modulePath exe : inFiles))-      destDirs  = map (exeDir </>) srcDirs-  mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs-  rawSystemProgramConf verbosity hmakeProgram conf $-       ["-hc=" ++ programPath nhcProg]-    ++ nhcVerbosityOptions verbosity-    ++ ["-d", targetDir, "-hidir", targetDir]-    ++ maybe [] (hcOptions NHC . libBuildInfo)-                           (library pkg_descr)-    ++ languageFlags-    ++ concat [ ["-package", display (packageName pkgid) ]-              | (_, pkgid) <- componentPackageDeps clbi ]-    ++ inFiles-    ++ [exeName exe]--nhcVerbosityOptions :: Verbosity -> [String]-nhcVerbosityOptions verbosity-     | verbosity >= deafening = ["-v"]-     | verbosity >= normal    = []-     | otherwise              = ["-q"]----TODO: where to put this? it's duplicated in .Simple too-getModulePaths :: LocalBuildInfo -> BuildInfo -> [ModuleName] -> IO [FilePath]-getModulePaths lbi bi modules = sequence-   [ findFileWithExtension ["hs", "lhs"] (buildDir lbi : hsSourceDirs bi)-       (ModuleName.toFilePath module_) >>= maybe (notFound module_) (return . normalise)-   | module_ <- modules ]-   where notFound module_ = die $ "can't find source for module " ++ display module_---- -------------------------------------------------------------------------------- Installing---- |Install executables for NHC.-installExe :: Verbosity -- ^verbosity-           -> FilePath  -- ^install location-           -> FilePath  -- ^Build location-           -> (FilePath, FilePath)  -- ^Executable (prefix,suffix)-           -> Executable-           -> IO ()-installExe verbosity pref buildPref (progprefix,progsuffix) exe-    = do createDirectoryIfMissingVerbose verbosity True pref-         let exeBaseName = exeName exe-             exeFileName = exeBaseName <.> exeExtension-             fixedExeFileName = (progprefix ++ exeBaseName ++ progsuffix) <.> exeExtension-         installExecutableFile verbosity-           (buildPref </> exeBaseName </> exeFileName)-           (pref </> fixedExeFileName)---- |Install for nhc98: .hi and .a files-installLib    :: Verbosity -- ^verbosity-              -> FilePath  -- ^install location-              -> FilePath  -- ^Build location-              -> PackageIdentifier-              -> Library-              -> ComponentLocalBuildInfo-              -> IO ()-installLib verbosity pref buildPref _pkgid lib clbi-    = do let bi = libBuildInfo lib-             modules = exposedModules lib ++ otherModules bi-         findModuleFiles [buildPref] ["hi"] modules-           >>= installOrdinaryFiles verbosity pref-         let libNames = map mkLibName (componentLibraries clbi)-             installLib' libName = installOrdinaryFile verbosity-                                                       (buildPref </> libName)-                                                       (pref </> libName)-         mapM_ installLib' libNames

cabal/Cabal/Distribution/Simple/PackageIndex.hs view

@@ -1,3 +1,6 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.PackageIndex@@ -12,6 +15,7 @@ -- module Distribution.Simple.PackageIndex (   -- * Package index data type+  InstalledPackageIndex,   PackageIndex,    -- * Creating an index@@ -32,6 +36,7 @@   -- ** Precise lookups   lookupInstalledPackageId,   lookupSourcePackageId,+  lookupPackageId,   lookupPackageName,   lookupDependency, @@ -57,47 +62,52 @@   moduleNameIndex,   ) where -import Prelude hiding (lookup) import Control.Exception (assert)-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.Tree  as Tree-import qualified Data.Graph as Graph-import qualified Data.Array as Array import Data.Array ((!))+import qualified Data.Array as Array+import Distribution.Compat.Binary (Binary)+import qualified Data.Graph as Graph import Data.List as List          ( null, foldl', sort          , groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy )+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(..))+#endif+import Data.Map (Map)+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)  import Distribution.Package          ( PackageName(..), PackageId          , Package(..), packageName, packageVersion          , Dependency(Dependency)--, --PackageFixedDeps(..)-         , InstalledPackageId(..) )+         , InstalledPackageId(..)+         , HasInstalledPackageId(..), PackageInstalled(..) ) import Distribution.ModuleName          ( ModuleName ) import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo, installedPackageId )+         ( InstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Version          ( Version, withinRange ) import Distribution.Simple.Utils (lowercase, comparing, equating) - -- | The collection of information about packages from one or more 'PackageDB's.+-- These packages generally should have an instance of 'PackageInstalled' -- -- Packages are uniquely identified in by their 'InstalledPackageId', they can--- also be effeciently looked up by package name or by name and version.+-- also be efficiently looked up by package name or by name and version. ---data PackageIndex = PackageIndex+data PackageIndex a = PackageIndex   -- The primary index. Each InstalledPackageInfo record is uniquely identified   -- by its InstalledPackageId.   ---  !(Map InstalledPackageId InstalledPackageInfo)+  !(Map InstalledPackageId a) -  -- This auxillary index maps package names (case-sensitively) to all the+  -- This auxiliary index maps package names (case-sensitively) to all the   -- versions and instances of that package. This allows us to find all   -- versions satisfying a dependency.   --@@ -108,18 +118,24 @@   --   -- FIXME: Clarify what "preference order" means. Check that this invariant is   -- preserved. See #1463 for discussion.-  !(Map PackageName (Map Version [InstalledPackageInfo]))+  !(Map PackageName (Map Version [a])) -  deriving (Show, Read)+  deriving (Generic, Show, Read) -instance Monoid PackageIndex where+instance Binary a => Binary (PackageIndex a)++-- | The default package index which contains 'InstalledPackageInfo'.  Normally+-- use this.+type InstalledPackageIndex = PackageIndex InstalledPackageInfo++instance HasInstalledPackageId a => Monoid (PackageIndex a) where   mempty  = PackageIndex Map.empty Map.empty   mappend = merge   --save one mappend with empty in the common case:   mconcat [] = mempty   mconcat xs = foldr1 mappend xs -invariant :: PackageIndex -> Bool+invariant :: HasInstalledPackageId a => PackageIndex a -> Bool invariant (PackageIndex pids pnames) =      map installedPackageId (Map.elems pids)   == sort@@ -140,9 +156,10 @@ -- * Internal helpers -- -mkPackageIndex :: Map InstalledPackageId InstalledPackageInfo-               -> Map PackageName (Map Version [InstalledPackageInfo])-               -> PackageIndex+mkPackageIndex :: HasInstalledPackageId a+               => Map InstalledPackageId a+               -> Map PackageName (Map Version [a])+               -> PackageIndex a mkPackageIndex pids pnames = assert (invariant index) index   where index = PackageIndex pids pnames @@ -156,7 +173,7 @@ -- If there are duplicates by 'InstalledPackageId' then later ones mask earlier -- ones. ---fromList :: [InstalledPackageInfo] -> PackageIndex+fromList :: HasInstalledPackageId a => [a] -> PackageIndex a fromList pkgs = mkPackageIndex pids pnames   where     pids      = Map.fromList [ (installedPackageId pkg, pkg) | pkg <- pkgs ]@@ -188,9 +205,10 @@ -- result when we do a lookup by source 'PackageId'. This is the mechanism we -- use to prefer user packages over global packages. ---merge :: PackageIndex -> PackageIndex -> PackageIndex+merge :: HasInstalledPackageId a => PackageIndex a -> PackageIndex a+      -> PackageIndex a merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) =-  mkPackageIndex (Map.union pids1 pids2)+  mkPackageIndex (Map.unionWith (\_ y -> y) pids1 pids2)                  (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2)   where     -- Packages in the second list mask those in the first, however preferred@@ -204,7 +222,7 @@ -- This is equivalent to (but slightly quicker than) using 'mappend' or -- 'merge' with a singleton index. ---insert :: InstalledPackageInfo -> PackageIndex -> PackageIndex+insert :: HasInstalledPackageId a => a -> PackageIndex a -> PackageIndex a insert pkg (PackageIndex pids pnames) =     mkPackageIndex pids' pnames' @@ -226,7 +244,9 @@  -- | Removes a single installed package from the index. ---deleteInstalledPackageId :: InstalledPackageId -> PackageIndex -> PackageIndex+deleteInstalledPackageId :: HasInstalledPackageId a+                         => InstalledPackageId -> PackageIndex a+                         -> PackageIndex a deleteInstalledPackageId ipkgid original@(PackageIndex pids pnames) =   case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of     (Nothing,     _)     -> original@@ -248,7 +268,8 @@  -- | Removes all packages with this source 'PackageId' from the index. ---deleteSourcePackageId :: PackageId -> PackageIndex -> PackageIndex+deleteSourcePackageId :: HasInstalledPackageId a => PackageId -> PackageIndex a+                      -> PackageIndex a deleteSourcePackageId pkgid original@(PackageIndex pids pnames) =   case Map.lookup (packageName pkgid) pnames of     Nothing     -> original@@ -268,7 +289,8 @@  -- | Removes all packages with this (case-sensitive) name from the index. ---deletePackageName :: PackageName -> PackageIndex -> PackageIndex+deletePackageName :: HasInstalledPackageId a => PackageName -> PackageIndex a+                  -> PackageIndex a deletePackageName name original@(PackageIndex pids pnames) =   case Map.lookup name pnames of     Nothing     -> original@@ -291,14 +313,14 @@  -- | Get all the packages from the index. ---allPackages :: PackageIndex -> [InstalledPackageInfo]+allPackages :: PackageIndex a -> [a] allPackages (PackageIndex pids _) = Map.elems pids  -- | Get all the packages from the index. -- -- They are grouped by package name (case-sensitively). ---allPackagesByName :: PackageIndex -> [(PackageName, [InstalledPackageInfo])]+allPackagesByName :: PackageIndex a -> [(PackageName, [a])] allPackagesByName (PackageIndex _ pnames) =   [ (pkgname, concat (Map.elems pvers))   | (pkgname, pvers) <- Map.toList pnames ]@@ -307,7 +329,8 @@ -- -- They are grouped by source package id (package name and version). ---allPackagesBySourcePackageId :: PackageIndex -> [(PackageId, [InstalledPackageInfo])]+allPackagesBySourcePackageId :: HasInstalledPackageId a => PackageIndex a+                             -> [(PackageId, [a])] allPackagesBySourcePackageId (PackageIndex _ pnames) =   [ (packageId ipkg, ipkgs)   | pvers <- Map.elems pnames@@ -322,8 +345,8 @@ -- Since multiple package DBs mask each other by 'InstalledPackageId', -- then we get back at most one package. ---lookupInstalledPackageId :: PackageIndex -> InstalledPackageId-                         -> Maybe InstalledPackageInfo+lookupInstalledPackageId :: PackageIndex a -> InstalledPackageId+                         -> Maybe a lookupInstalledPackageId (PackageIndex pids _) pid = Map.lookup pid pids  @@ -333,7 +356,7 @@ -- but different 'InstalledPackageId'. They are returned in order of -- preference, with the most preferred first. ---lookupSourcePackageId :: PackageIndex -> PackageId -> [InstalledPackageInfo]+lookupSourcePackageId :: PackageIndex a -> PackageId -> [a] lookupSourcePackageId (PackageIndex _ pnames) pkgid =   case Map.lookup (packageName pkgid) pnames of     Nothing     -> []@@ -341,11 +364,18 @@       Nothing   -> []       Just pkgs -> pkgs -- in preference order +-- | Convenient alias of 'lookupSourcePackageId', but assuming only+-- one package per package ID.+lookupPackageId :: PackageIndex a -> PackageId -> Maybe a+lookupPackageId index pkgid = case lookupSourcePackageId index pkgid  of+    []    -> Nothing+    [pkg] -> Just pkg+    _     -> error "Distribution.Simple.PackageIndex: multiple matches found"  -- | Does a lookup by source package name. ---lookupPackageName :: PackageIndex -> PackageName-                  -> [(Version, [InstalledPackageInfo])]+lookupPackageName :: PackageIndex a -> PackageName+                  -> [(Version, [a])] lookupPackageName (PackageIndex _ pnames) name =   case Map.lookup name pnames of     Nothing     -> []@@ -357,8 +387,8 @@ -- We get back any number of versions of the specified package name, all -- satisfying the version range constraint. ---lookupDependency :: PackageIndex -> Dependency-                 -> [(Version, [InstalledPackageInfo])]+lookupDependency :: PackageIndex a -> Dependency+                 -> [(Version, [a])] lookupDependency (PackageIndex _ pnames) (Dependency name versionRange) =   case Map.lookup name pnames of     Nothing    -> []@@ -372,17 +402,17 @@  -- | Does a case-insensitive search by package name. ----- If there is only one package that compares case-insentiviely to this 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-insentiviely but one matches exactly then it is also+-- If several match case-insensitively but one matches exactly then it is also -- unambiguous. ----- If however several match case-insentiviely and none match exactly then we+-- 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 -> String -> SearchResult [InstalledPackageInfo]+searchByName :: PackageIndex a -> String -> SearchResult [a] searchByName (PackageIndex _ pnames) name =   case [ pkgs | pkgs@(PackageName name',_) <- Map.toList pnames               , lowercase name' == lname ] of@@ -399,7 +429,7 @@ -- -- That is, all packages that contain the given string in their name. ---searchByNameSubstring :: PackageIndex -> String -> [InstalledPackageInfo]+searchByNameSubstring :: PackageIndex a -> String -> [a] searchByNameSubstring (PackageIndex _ pnames) searchterm =   [ pkg   | (PackageName name, pvers) <- Map.toList pnames@@ -423,11 +453,11 @@ -- list of groups of packages where within each group they all depend on each -- other, directly or indirectly. ---dependencyCycles :: PackageIndex -> [[InstalledPackageInfo]]+dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]] dependencyCycles index =   [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]   where-    adjacencyList = [ (pkg, installedPackageId pkg, IPI.depends pkg)+    adjacencyList = [ (pkg, installedPackageId pkg, installedDepends pkg)                     | pkg <- allPackages index ]  @@ -435,15 +465,15 @@ -- -- Returns such packages along with the dependencies that they're missing. ---brokenPackages :: PackageIndex -> [(InstalledPackageInfo, [InstalledPackageId])]+brokenPackages :: PackageInstalled a => PackageIndex a+               -> [(a, [InstalledPackageId])] brokenPackages index =   [ (pkg, missing)   | pkg  <- allPackages index-  , let missing = [ pkg' | pkg' <- IPI.depends pkg+  , let missing = [ pkg' | pkg' <- installedDepends pkg                          , isNothing (lookupInstalledPackageId index pkg') ]   , not (null missing) ] - -- | Tries to take the transitive closure of the package dependencies. -- -- If the transitive closure is complete then it returns that subset of the@@ -452,10 +482,10 @@ -- * Note that if the result is @Right []@ it is because at least one of -- the original given 'PackageId's do not occur in the index. ---dependencyClosure :: PackageIndex+dependencyClosure :: PackageInstalled a => PackageIndex a                   -> [InstalledPackageId]-                  -> Either PackageIndex-                            [(InstalledPackageInfo, [InstalledPackageId])]+                  -> Either (PackageIndex a)+                            [(a, [InstalledPackageId])] dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of   (completed, []) -> Left completed   (completed, _)  -> Right (brokenPackages completed)@@ -467,15 +497,15 @@         Just _  -> closure completed  failed pkgids         Nothing -> closure completed' failed pkgids'           where completed' = insert pkg completed-                pkgids'    = IPI.depends pkg ++ pkgids+                pkgids'    = installedDepends pkg ++ pkgids  -- | Takes the transitive closure of the packages reverse dependencies. -- -- * The given 'PackageId's must be in the index. ---reverseDependencyClosure :: PackageIndex+reverseDependencyClosure :: PackageInstalled a => PackageIndex a                          -> [InstalledPackageId]-                         -> [InstalledPackageInfo]+                         -> [a] reverseDependencyClosure index =     map vertexToPkg   . concatMap Tree.flatten@@ -487,13 +517,13 @@     reverseDepGraph = Graph.transposeG depGraph     noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" -topologicalOrder :: PackageIndex -> [InstalledPackageInfo]+topologicalOrder :: PackageInstalled a => PackageIndex a -> [a] topologicalOrder index = map toPkgId                        . Graph.topSort                        $ graph   where (graph, toPkgId, _) = dependencyGraph index -reverseTopologicalOrder :: PackageIndex -> [InstalledPackageInfo]+reverseTopologicalOrder :: PackageInstalled a => PackageIndex a -> [a] reverseTopologicalOrder index = map toPkgId                               . Graph.topSort                               . Graph.transposeG@@ -505,14 +535,14 @@ -- Dependencies on other packages that are not in the index are discarded. -- You can check if there are any such dependencies with 'brokenPackages'. ---dependencyGraph :: PackageIndex+dependencyGraph :: PackageInstalled a => PackageIndex a                 -> (Graph.Graph,-                    Graph.Vertex -> InstalledPackageInfo,+                    Graph.Vertex -> a,                     InstalledPackageId -> Maybe Graph.Vertex) dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex)   where     graph = Array.listArray bounds-              [ [ v | Just v <- map id_to_vertex (IPI.depends pkg) ]+              [ [ v | Just v <- map id_to_vertex (installedDepends pkg) ]               | pkg <- pkgs ]      pkgs             = sortBy (comparing packageId) (allPackages index)@@ -536,7 +566,7 @@ -- depend on it and the versions they require. These are guaranteed to be -- distinct. ---dependencyInconsistencies :: PackageIndex+dependencyInconsistencies :: PackageInstalled a => PackageIndex a                           -> [(PackageName, [(PackageId, Version)])] dependencyInconsistencies index =   [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids])@@ -548,29 +578,39 @@         --   for each package with that name,         --     the InstalledPackageInfo and the package Ids of packages         --     that depend on it.-        inverseIndex :: Map PackageName-                            (Map InstalledPackageId-                                 (InstalledPackageInfo, [PackageId]))         inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))           [ (packageName dep,              Map.fromList [(ipid,(dep,[packageId pkg]))])           | pkg <- allPackages index-          , ipid <- IPI.depends pkg+          , ipid <- installedDepends pkg           , Just dep <- [lookupInstalledPackageId index ipid]           ] -        reallyIsInconsistent :: [InstalledPackageInfo] -> Bool+        reallyIsInconsistent :: PackageInstalled a => [a] -> Bool         reallyIsInconsistent []       = False         reallyIsInconsistent [_p]     = False         reallyIsInconsistent [p1, p2] =-             installedPackageId p1 `notElem` IPI.depends p2-          && installedPackageId p2 `notElem` IPI.depends p1+          let pid1 = installedPackageId p1+              pid2 = installedPackageId p2+          in pid1 `notElem` installedDepends p2+          && pid2 `notElem` installedDepends p1         reallyIsInconsistent _ = True --moduleNameIndex :: PackageIndex -> Map ModuleName [InstalledPackageInfo]+-- | A rough approximation of GHC's module finder, takes a+-- 'InstalledPackageIndex' and turns it into a map from module names to their+-- source packages.  It's used to initialize the @build-deps@ field in @cabal+-- init@.+moduleNameIndex :: InstalledPackageIndex -> Map ModuleName [InstalledPackageInfo] moduleNameIndex index =-  Map.fromListWith (++)-    [ (moduleName, [pkg])-    | pkg        <- allPackages index-    , moduleName <- IPI.exposedModules pkg ]+  Map.fromListWith (++) $ do+    pkg <- allPackages index+    IPI.ExposedModule m reexport _ <- IPI.exposedModules pkg+    case reexport of+        Nothing -> return (m, [pkg])+        Just (IPI.OriginalModule _ 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+        -- downstream package, since the upstream package has the wrong+        -- module name!

cabal/Cabal/Distribution/Simple/PreProcess.hs view

@@ -2,6 +2,7 @@ -- | -- Module      :  Distribution.Simple.PreProcess -- Copyright   :  (c) 2003-2005, Isaac Jones, Malcolm Wallace+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -16,39 +17,9 @@ -- handlers. This module is not as good as it could be, it could really do with -- a rewrite to address some of the problems we have with pre-processors. -{- Copyright (c) 2003-2005, Isaac Jones, Malcolm Wallace-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. -}--module Distribution.Simple.PreProcess (preprocessComponent, knownSuffixHandlers,-                                ppSuffixes, PPSuffixHandler, PreProcessor(..),+module Distribution.Simple.PreProcess (preprocessComponent, preprocessExtras,+                                knownSuffixHandlers, ppSuffixes,+                                PPSuffixHandler, PreProcessor(..),                                 mkSimplePreProcessor, runSimplePreProcessor,                                 ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs,                                 ppHappy, ppAlex, ppUnlit, platformDefines@@ -69,26 +40,29 @@          , TestSuiteInterface(..)          , Benchmark(..), benchmarkModules, BenchmarkInterface(..) ) import qualified Distribution.InstalledPackageInfo as Installed-         ( InstalledPackageInfo_(..) )+         ( InstalledPackageInfo(..) ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.CCompiler          ( cSourceExtensions ) import Distribution.Simple.Compiler-         ( CompilerFlavor(..), compilerFlavor, compilerVersion )+         ( CompilerFlavor(..)+         , compilerFlavor, compilerCompatVersion, compilerVersion ) import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(..), Component(..) ) import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName) import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File          , die, setupMessage, intercalate, copyFileVerbose, moreRecentFile-         , findFileWithExtension, findFileWithExtension' )+         , findFileWithExtension, findFileWithExtension'+         , getDirectoryContentsRecursive ) import Distribution.Simple.Program          ( Program(..), ConfiguredProgram(..), programPath-         , lookupProgram, requireProgram, requireProgramVersion+         , requireProgram, requireProgramVersion          , rawSystemProgramConf, rawSystemProgram          , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram-         , happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram )-import Distribution.Simple.Test ( writeSimpleTestStub, stubFilePath, stubName )+         , happyProgram, alexProgram, ghcProgram, ghcjsProgram, gccProgram )+import Distribution.Simple.Test.LibV09+         ( writeSimpleTestStub, stubFilePath, stubName ) import Distribution.System          ( OS(..), buildOS, Arch(..), Platform(..) ) import Distribution.Text@@ -97,11 +71,12 @@ import Distribution.Verbosity  import Data.Maybe (fromMaybe)-import Data.List (nub)+import Data.List (nub, isSuffixOf) import System.Directory (doesFileExist) import System.Info (os, arch) import System.FilePath (splitExtension, dropExtensions, (</>), (<.>),-                        takeDirectory, normalise, replaceExtension)+                        takeDirectory, normalise, replaceExtension,+                        takeExtensions)  -- |The interface to a preprocessor, which may be implemented using an -- external program, but need not be.  The arguments are the name of@@ -126,12 +101,12 @@ -- -- The reason for splitting it up this way is that some pre-processors don't -- simply generate one output .hs file from one input file but have--- dependencies on other genereated files (notably c2hs, where building one+-- dependencies on other generated files (notably c2hs, where building one -- .hs file may require reading other .chi files, and then compiling the .hs -- file may require reading a generated .h file). In these cases the generated -- files need to embed relative path names to each other (eg the generated .hs -- file mentions the .h file in the FFI imports). This path must be relative to--- the base directory where the genereated files are located, it cannot be+-- the base directory where the generated files are located, it cannot be -- relative to the top level of the build tree because the compilers do not -- look for .h files relative to there, ie we do not use \"-I .\", instead we -- use \"-I dist\/build\" (or whatever dist dir has been set by the user)@@ -157,6 +132,13 @@                   -> IO ()     -- Should exit if the preprocessor fails   } +-- | Function to determine paths to possible extra C sources for a+-- preprocessor: just takes the path to the build directory and uses+-- this to search for C sources with names that match the+-- preprocessor's output name format.+type PreProcessorExtras = FilePath -> IO [FilePath]++ mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ())                       -> (FilePath, FilePath)                       -> (FilePath, FilePath) -> Verbosity -> IO ()@@ -221,11 +203,9 @@       BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark "                                  ++ "type " ++ display tt   where-    builtinHaskellSuffixes-      | NHC == compilerFlavor (compiler lbi) = ["hs", "lhs", "gc"]-      | otherwise                            = ["hs", "lhs"]-    builtinCSuffixes = cSourceExtensions-    builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes+    builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"]+    builtinCSuffixes       = cSourceExtensions+    builtinSuffixes        = builtinHaskellSuffixes ++ builtinCSuffixes     localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers]     pre dirs dir lhndlrs fp =       preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs@@ -281,7 +261,7 @@       Just (psrcLoc, psrcRelFile) -> do             let (srcStem, ext) = splitExtension psrcRelFile                 psrcFile = psrcLoc </> psrcRelFile-                pp = fromMaybe (error "Internal error in preProcess module: Just expected")+                pp = fromMaybe (error "Distribution.Simple.PreProcess: Just expected")                                (lookup (tailNotNull ext) handlers)             -- Preprocessing files for 'sdist' is different from preprocessing             -- for 'build'.  When preprocessing for sdist we preprocess to@@ -364,27 +344,28 @@ ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor ppCpp' extraArgs bi lbi =   case compilerFlavor (compiler lbi) of-    GHC -> ppGhcCpp (cppArgs ++ extraArgs) bi lbi-    _   -> ppCpphs  (cppArgs ++ extraArgs) bi lbi-+    GHC   -> ppGhcCpp ghcProgram   (>= Version [6,6] []) args bi lbi+    GHCJS -> ppGhcCpp ghcjsProgram (const True)          args bi lbi+    _     -> ppCpphs  args bi lbi   where cppArgs = getCppOptions bi lbi+        args    = cppArgs ++ extraArgs -ppGhcCpp :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor-ppGhcCpp extraArgs _bi lbi =+ppGhcCpp :: Program -> (Version -> Bool)+         -> [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor+ppGhcCpp program xHs extraArgs _bi lbi =   PreProcessor {     platformIndependent = False,     runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do-      (ghcProg, ghcVersion, _) <- requireProgramVersion verbosity-                                    ghcProgram anyVersion (withPrograms lbi)-      rawSystemProgram verbosity ghcProg $+      (prog, version, _) <- requireProgramVersion verbosity+                              program anyVersion (withPrograms lbi)+      rawSystemProgram verbosity prog $           ["-E", "-cpp"]           -- This is a bit of an ugly hack. We're going to           -- unlit the file ourselves later on if appropriate,           -- so we need GHC not to unlit it now or it'll get           -- double-unlitted. In the future we might switch to           -- using cpphs --unlit instead.-       ++ (if ghcVersion >= Version [6,6] [] then ["-x", "hs"] else [])-       ++ (if use_optP_P lbi then ["-optP-P"] else [])+       ++ (if xHs version then ["-x", "hs"] else [])        ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi </> cppHeaderName) ]        ++ ["-o", outFile, inFile]        ++ extraArgs@@ -406,16 +387,6 @@         ++ extraArgs   } --- Haddock versions before 0.8 choke on #line and #file pragmas.  Those--- pragmas are necessary for correct links when we preprocess.  So use--- -optP-P only if the Haddock version is prior to 0.8.-use_optP_P :: LocalBuildInfo -> Bool-use_optP_P lbi- = case lookupProgram haddockProgram (withPrograms lbi) of-     Just (ConfiguredProgram { programVersion = Just version })-       | version >= Version [0,8] [] -> False-     _                               -> True- ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor ppHsc2hs bi lbi =   PreProcessor {@@ -481,8 +452,9 @@     isOSX = case buildOS of OSX -> True; _ -> False     isELF = case buildOS of OSX -> False; Windows -> False; _ -> True;     packageHacks = case compilerFlavor (compiler lbi) of-      GHC -> hackRtsPackage-      _   -> id+      GHC   -> hackRtsPackage+      GHCJS -> hackRtsPackage+      _     -> id     -- We don't link in the actual Haskell libraries of our dependencies, so     -- the -u flags in the ldOptions of the rts package mean linking fails on     -- OS X (it's ld is a tad stricter than gnu ld). Thus we remove the@@ -493,6 +465,9 @@            -> PackageIndex.insert rts { Installed.ldOptions = [] } index         _  -> error "No (or multiple) ghc rts package is registered!!" +ppHsc2hsExtras :: PreProcessorExtras+ppHsc2hsExtras buildBaseDir = filter ("_hsc.c" `isSuffixOf`) `fmap`+                              getDirectoryContentsRecursive buildBaseDir  ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor ppC2hs bi lbi =@@ -509,6 +484,7 @@           -- Options from the current package:            [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ]         ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ]+        ++ [ "--cppopts=-include" ++ (autogenModulesDir lbi </> cppHeaderName) ]         ++ [ "--include=" ++ outBaseDir ]            -- Options from dependent packages@@ -528,6 +504,10 @@   where     pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) +ppC2hsExtras :: PreProcessorExtras+ppC2hsExtras d = filter (\p -> takeExtensions p == ".chs.c") `fmap`+                 getDirectoryContentsRecursive d+ --TODO: perhaps use this with hsc2hs too --TODO: remove cc-options from cpphs for cabal-version: >= 1.10 getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]@@ -546,9 +526,14 @@       ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++       map (\os'   -> "-D" ++ os'   ++ "_HOST_OS=1")   osStr ++       map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr+    GHCJS ->+      compatGlasgowHaskell +++      ["-D__GHCJS__=" ++ versionInt version] +++      ["-D" ++ os   ++ "_BUILD_OS=1"] +++      ["-D" ++ arch ++ "_BUILD_ARCH=1"] +++      map (\os'   -> "-D" ++ os'   ++ "_HOST_OS=1")   osStr +++      map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr     JHC  -> ["-D__JHC__=" ++ versionInt version]-    NHC  -> ["-D__NHC__=" ++ versionInt version]-    Hugs -> ["-D__HUGS__"]     HaskellSuite {} ->       ["-D__HASKELL_SUITE__"] ++         map (\os'   -> "-D" ++ os'   ++ "_HOST_OS=1")   osStr ++@@ -558,6 +543,9 @@     comp = compiler lbi     Platform hostArch hostOS = hostPlatform lbi     version = compilerVersion comp+    compatGlasgowHaskell =+      maybe [] (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v])+               (compilerCompatVersion GHC comp)     -- TODO: move this into the compiler abstraction     -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all     -- the other compilers. Check if that's really what they want.@@ -580,12 +568,16 @@       FreeBSD   -> ["freebsd"]       OpenBSD   -> ["openbsd"]       NetBSD    -> ["netbsd"]+      DragonFly -> ["dragonfly"]       Solaris   -> ["solaris2"]       AIX       -> ["aix"]       HPUX      -> ["hpux"]       IRIX      -> ["irix"]       HaLVM     -> []       IOS       -> ["ios"]+      Android   -> ["android"]+      Ghcjs     -> ["ghcjs"]+      Hurd      -> ["hurd"]       OtherOS _ -> []     archStr = case hostArch of       I386        -> ["i386"]@@ -603,6 +595,7 @@       Rs6000      -> ["rs6000"]       M68k        -> ["m68k"]       Vax         -> ["vax"]+      JavaScript  -> ["javascript"]       OtherArch _ -> []  ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor@@ -610,6 +603,7 @@   where pp = standardPP lbi happyProgram (hcFlags hc)         hc = compilerFlavor (compiler lbi)         hcFlags GHC = ["-agc"]+        hcFlags GHCJS = ["-agc"]         hcFlags _ = []  ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor@@ -617,6 +611,7 @@   where pp = standardPP lbi alexProgram (hcFlags hc)         hc = compilerFlavor (compiler lbi)         hcFlags GHC = ["-g"]+        hcFlags GHCJS = ["-g"]         hcFlags _ = []  standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor@@ -643,3 +638,33 @@   , ("ly",     ppHappy)   , ("cpphs",  ppCpp)   ]++-- |Standard preprocessors with possible extra C sources: c2hs, hsc2hs.+knownExtrasHandlers :: [ PreProcessorExtras ]+knownExtrasHandlers = [ ppC2hsExtras, ppHsc2hsExtras ]++-- | Find any extra C sources generated by preprocessing that need to+-- be added to the component (addresses issue #238).+preprocessExtras :: Component+                 -> LocalBuildInfo+                 -> IO [FilePath]+preprocessExtras comp lbi = case comp of+  CLib _ -> pp $ buildDir lbi+  (CExe Executable { exeName = nm }) ->+    pp $ buildDir lbi </> nm </> nm ++ "-tmp"+  CTest test -> do+    case testInterface test of+      TestSuiteExeV10 _ _ ->+          pp $ buildDir lbi </> testName test </> testName test ++ "-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+    case benchmarkInterface bm of+      BenchmarkExeV10 _ _ ->+          pp $ buildDir lbi </> benchmarkName bm </> benchmarkName bm ++ "-tmp"+      BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark "+                                 ++ "type " ++ display tt+  where+    pp dir = (map (dir </>) . concat) `fmap` forM knownExtrasHandlers ($ dir)

cabal/Cabal/Distribution/Simple/Program.hs view

@@ -58,7 +58,7 @@     , runProgramInvocation     , getProgramInvocationOutput -    -- * The collection of unconfigured and configured progams+    -- * The collection of unconfigured and configured programs     , builtinPrograms      -- * The collection of configured programs we can run@@ -79,6 +79,7 @@     , userSpecifyArgss     , userSpecifiedArgs     , lookupProgram+    , lookupProgramVersion     , updateProgram     , configureProgram     , configureAllKnownPrograms@@ -91,13 +92,12 @@     -- * Programs that Cabal knows about     , ghcProgram     , ghcPkgProgram+    , ghcjsProgram+    , ghcjsPkgProgram     , lhcProgram     , lhcPkgProgram-    , nhcProgram     , hmakeProgram     , jhcProgram-    , hugsProgram-    , ffihugsProgram     , uhcProgram     , gccProgram     , arProgram@@ -168,8 +168,8 @@     Nothing             -> die notFound     Just configuredProg -> runProgram verbosity configuredProg args  where-   notFound = "The program " ++ programName prog-           ++ " is required but it could not be found"+   notFound = "The program '" ++ programName prog+           ++ "' is required but it could not be found"  -- | Looks up the given program in the program database and runs it. --@@ -183,8 +183,8 @@     Nothing             -> die notFound     Just configuredProg -> getProgramOutput verbosity configuredProg args  where-   notFound = "The program " ++ programName prog-           ++ " is required but it could not be found"+   notFound = "The program '" ++ programName prog+           ++ "' is required but it could not be found"   ---------------------

cabal/Cabal/Distribution/Simple/Program/Ar.hs view

@@ -15,22 +15,21 @@     multiStageProgramInvocation   ) where -import Control.Monad (when, unless)+import Control.Monad (unless) 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-         ( ProgramConfiguration, arProgram, requireProgram )+         ( arProgram, requireProgram ) import Distribution.Simple.Program.Run          ( programInvocation, multiStageProgramInvocation          , runProgramInvocation )-import qualified Distribution.Simple.Program.Strip as Strip-         ( stripLib ) import Distribution.Simple.Utils          ( dieWithLocation, withTempDirectory ) import Distribution.System-         ( OS(..), buildOS )+         ( Arch(..), OS(..), Platform(..) ) import Distribution.Verbosity          ( Verbosity, deafening, verbose ) import System.Directory (doesFileExist, renameFile)@@ -41,13 +40,13 @@  -- | Call @ar@ to create a library archive from a bunch of object files. ---createArLibArchive :: Verbosity -> ProgramConfiguration -> Bool+createArLibArchive :: Verbosity -> LocalBuildInfo                    -> FilePath -> [FilePath] -> IO ()-createArLibArchive verbosity progConf stripLib targetPath files = do+createArLibArchive verbosity lbi targetPath files = do   (ar, _) <- requireProgram verbosity arProgram progConf    let (targetDir, targetName) = splitFileName targetPath-  withTempDirectory verbosity targetDir targetName $ \ tmpDir -> do+  withTempDirectory verbosity targetDir "objs" $ \ tmpDir -> do   let tmpPath = tmpDir </> targetName    -- The args to use with "ar" are actually rather subtle and system-dependent.@@ -64,12 +63,12 @@   -- When we need to call ar multiple times we use "ar q" and for the last   -- call on OSX we use "ar qs" so that it'll make the index. -  let simpleArgs  = case buildOS of+  let simpleArgs  = case hostOS of              OSX -> ["-r", "-s"]              _   -> ["-r"]        initialArgs = ["-q"]-      finalArgs   = case buildOS of+      finalArgs   = case hostOS of              OSX -> ["-q", "-s"]              _   -> ["-q"] @@ -85,12 +84,14 @@         | inv <- multiStageProgramInvocation                    simple (initial, middle, final) files ] -  when stripLib $ Strip.stripLib verbosity progConf tmpPath-  wipeMetadata tmpPath+  unless (hostArch == Arm) $ -- See #1537+    wipeMetadata tmpPath   equal <- filesEqual tmpPath targetPath   unless equal $ renameFile tmpPath targetPath    where+    progConf = withPrograms lbi+    Platform hostArch hostOS = hostPlatform lbi     verbosityOpts v | v >= deafening = ["-v"]                     | v >= verbose   = []                     | otherwise      = ["-c"]@@ -119,6 +120,7 @@         , "0     " -- GID, 6 bytes         , "0644    " -- mode, 8 bytes         ]+    headerSize :: Int     headerSize = 60      -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details

cabal/Cabal/Distribution/Simple/Program/Builtin.hs view

@@ -12,19 +12,18 @@ -- module Distribution.Simple.Program.Builtin ( -    -- * The collection of unconfigured and configured progams+    -- * The collection of unconfigured and configured programs     builtinPrograms,      -- * Programs that Cabal knows about     ghcProgram,     ghcPkgProgram,+    ghcjsProgram,+    ghcjsPkgProgram,     lhcProgram,     lhcPkgProgram,-    nhcProgram,     hmakeProgram,     jhcProgram,-    hugsProgram,-    ffihugsProgram,     haskellSuiteProgram,     haskellSuitePkgProgram,     uhcProgram,@@ -46,13 +45,30 @@     hpcProgram,   ) where -import Distribution.Simple.Program.Types-         ( Program(..), simpleProgram ) import Distribution.Simple.Program.Find          ( findProgramOnSearchPath )+import Distribution.Simple.Program.Internal+         ( stripExtractVersion )+import Distribution.Simple.Program.Run+         ( getProgramInvocationOutput, programInvocation )+import Distribution.Simple.Program.Types+         ( Program(..), ConfiguredProgram(..), simpleProgram ) import Distribution.Simple.Utils          ( findProgramVersion )+import Distribution.Compat.Exception+         ( catchIO )+import Distribution.Verbosity+         ( lessVerbose )+import Distribution.Version+         ( Version(..), withinRange, earlierVersion, laterVersion+         , intersectVersionRanges )+import Data.Char+         ( isDigit ) +import Data.List+         ( isInfixOf )+import qualified Data.Map as Map+ -- ------------------------------------------------------------ -- * Known programs -- ------------------------------------------------------------@@ -65,11 +81,10 @@     -- compilers and related progs       ghcProgram     , ghcPkgProgram-    , hugsProgram-    , ffihugsProgram+    , ghcjsProgram+    , ghcjsPkgProgram     , haskellSuiteProgram     , haskellSuitePkgProgram-    , nhcProgram     , hmakeProgram     , jhcProgram     , lhcProgram@@ -97,7 +112,23 @@  ghcProgram :: Program ghcProgram = (simpleProgram "ghc") {-    programFindVersion = findProgramVersion "--numeric-version" id+    programFindVersion = findProgramVersion "--numeric-version" id,++    -- Workaround for https://ghc.haskell.org/trac/ghc/ticket/8825+    -- (spurious warning on non-english locales)+    programPostConf    = \_verbosity ghcProg ->+    do let ghcProg' = ghcProg {+             programOverrideEnv = ("LANGUAGE", Just "en")+                                  : programOverrideEnv ghcProg+             }+           -- 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] [])+       return $ maybe ghcProg+         (\v -> if withinRange v affectedVersionRange+                then ghcProg' else ghcProg)+         (programVersion ghcProg)   }  ghcPkgProgram :: Program@@ -110,6 +141,22 @@         _               -> ""   } +ghcjsProgram :: Program+ghcjsProgram = (simpleProgram "ghcjs") {+    programFindVersion = findProgramVersion "--numeric-ghcjs-version" id+  }++-- note: version is the version number of the GHC version that ghcjs-pkg was built with+ghcjsPkgProgram :: Program+ghcjsPkgProgram = (simpleProgram "ghcjs-pkg") {+    programFindVersion = findProgramVersion "--version" $ \str ->+      -- Invoking "ghcjs-pkg --version" gives a string like+      -- "GHCJS package manager version 6.4.1"+      case words str of+        (_:_:_:_:ver:_) -> ver+        _               -> ""+  }+ lhcProgram :: Program lhcProgram = (simpleProgram "lhc") {     programFindVersion = findProgramVersion "--numeric-version" id@@ -125,16 +172,6 @@         _               -> ""   } -nhcProgram :: Program-nhcProgram = (simpleProgram "nhc98") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      -- Invoking "nhc98 --version" gives a string like-      -- "/usr/local/bin/nhc98: v1.20 (2007-11-22)"-      case words str of-        (_:('v':ver):_) -> ver-        _               -> ""-  }- hmakeProgram :: Program hmakeProgram = (simpleProgram "hmake") {     programFindVersion = findProgramVersion "--version" $ \str ->@@ -170,13 +207,6 @@                 _ -> ""     } --- AArgh! Finding the version of hugs or ffihugs is almost impossible.-hugsProgram :: Program-hugsProgram = simpleProgram "hugs"--ffihugsProgram :: Program-ffihugsProgram = simpleProgram "ffihugs"- -- This represents a haskell-suite compiler. Of course, the compiler -- itself probably is not called "haskell-suite", so this is not a real -- program. (But we don't know statically the name of the actual compiler,@@ -226,7 +256,7 @@       -- Invoking "alex --version" gives a string like       -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow"       case words str of-        (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver+        (_:_:ver:_) -> takeWhile (\x -> isDigit x || x == '.') ver         _           -> ""   } @@ -239,7 +269,10 @@ arProgram = simpleProgram "ar"  stripProgram :: Program-stripProgram = simpleProgram "strip"+stripProgram = (simpleProgram "strip") {+    programFindVersion = \verbosity ->+      findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity)+  }  hsc2hsProgram :: Program hsc2hsProgram = (simpleProgram "hsc2hs") {@@ -292,7 +325,19 @@ ldProgram = simpleProgram "ld"  tarProgram :: Program-tarProgram = simpleProgram "tar"+tarProgram = (simpleProgram "tar") {+  -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the+  -- '--format' option.+  programPostConf = \verbosity tarProg -> do+     tarHelpOutput <- getProgramInvocationOutput+                      verbosity (programInvocation tarProg ["--help"])+                      -- Some versions of tar don't support '--help'.+                      `catchIO` (\_ -> return "")+     let k = "Supports --format"+         v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO"+         m = Map.insert k v (programProperties tarProg)+     return $ tarProg { programProperties = m }+  }  cppProgram :: Program cppProgram = simpleProgram "cpp"

cabal/Cabal/Distribution/Simple/Program/Db.hs view

@@ -1,3 +1,6 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Program.Db@@ -34,6 +37,7 @@     knownPrograms,     getProgramSearchPath,     setProgramSearchPath,+    modifyProgramSearchPath,     userSpecifyPath,     userSpecifyPaths,     userMaybeSpecifyPath,@@ -47,6 +51,7 @@     -- ** Query and manipulate the program db     configureProgram,     configureAllKnownPrograms,+    lookupProgramVersion,     reconfigurePrograms,     requireProgram,     requireProgramVersion,@@ -69,6 +74,10 @@ import Distribution.Verbosity          ( Verbosity ) +import Distribution.Compat.Binary (Binary(..))+#if __GLASGOW_HASKELL__ < 710+import Data.Functor ((<$>))+#endif import Data.List          ( foldl' ) import Data.Maybe@@ -131,7 +140,13 @@     [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r)     | (s', r) <- readsPrec p s ] +instance Binary ProgramDb where+  put = put . configuredProgs+  get = do+      progs <- get+      return $! emptyProgramDb { configuredProgs = progs } + -- | The Read\/Show instance does not preserve all the unconfigured 'Programs' -- because 'Program' is not in Read\/Show because it contains functions. So to -- fully restore a deserialised 'ProgramDb' use this function to add@@ -171,7 +186,7 @@  -- | Get the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This is the default list of locations where programs are looked for when--- configuring them. This can be overriden for specific programs (with+-- configuring them. This can be overridden for specific programs (with -- 'userSpecifyPath'), and specific known programs can modify or ignore this -- search path in their own configuration code. --@@ -185,6 +200,16 @@ setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb setProgramSearchPath searchpath db = db { progSearchPath = searchpath } +-- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'.+-- This will affect programs that are configured from here on, so you+-- should usually modify it before configuring any programs.+--+modifyProgramSearchPath :: (ProgramSearchPath -> ProgramSearchPath)+                        -> ProgramDb+                        -> ProgramDb+modifyProgramSearchPath f db =+  setProgramSearchPath (f $ getProgramSearchPath db) db+ -- |User-specify this path.  Basically override any path information -- for this program in the configuration. If it's not a known -- program ignore it.@@ -274,8 +299,8 @@ -- Configuring known programs  -- | Try to configure a specific program. If the program is already included in--- the colleciton of unconfigured programs then we use any user-supplied--- location and arguments. If the program gets configured sucessfully it gets+-- the collection of unconfigured programs then we use any user-supplied+-- location and arguments. If the program gets configured successfully it gets -- added to the configured collection. -- -- Note that it is not a failure if the program cannot be configured. It's only@@ -284,7 +309,7 @@ -- -- The reason for it not being a failure at this stage is that we don't know up -- front all the programs we will need, so we try to configure them all.--- To verify that a program was actually sucessfully configured use+-- To verify that a program was actually successfully configured use -- 'requireProgram'. -- configureProgram :: Verbosity@@ -317,6 +342,7 @@             programDefaultArgs  = [],             programOverrideArgs = userSpecifiedArgs prog conf,             programOverrideEnv  = [("PATH", Just newPath)],+            programProperties   = Map.empty,             programLocation     = location           }       configuredProg' <- programPostConf prog verbosity configuredProg@@ -383,50 +409,63 @@     Nothing             -> die notFound     Just configuredProg -> return (configuredProg, conf') -  where notFound       = "The program " ++ programName prog-                      ++ " is required but it could not be found."+  where notFound       = "The program '" ++ programName prog+                      ++ "' is required but it could not be found."   -- | Check that a program is configured and available to be run. ----- Additionally check that the version of the program number is suitable and--- return it. For example you could require 'AnyVersion' or--- @'orLaterVersion' ('Version' [1,0] [])@+-- Additionally check that the program version number is suitable and return+-- it. For example you could require 'AnyVersion' or @'orLaterVersion'+-- ('Version' [1,0] [])@ ----- It raises an exception if the program could not be configured or the version--- is unsuitable, otherwise it returns the configured program and its version--- number.+-- It returns the configured program, its version number and a possibly updated+-- 'ProgramDb'. If the program could not be configured or the version is+-- unsuitable, it returns an error value. ---requireProgramVersion :: Verbosity -> Program -> VersionRange-                      -> ProgramDb-                      -> IO (ConfiguredProgram, Version, ProgramDb)-requireProgramVersion verbosity prog range conf = do+lookupProgramVersion+  :: Verbosity -> Program -> VersionRange -> ProgramDb+  -> IO (Either String (ConfiguredProgram, Version, ProgramDb))+lookupProgramVersion verbosity prog range programDb = 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+  programDb' <- case lookupProgram prog programDb of+    Nothing -> configureProgram verbosity prog programDb+    Just _  -> return programDb -  case lookupProgram prog conf' of-    Nothing                           -> die notFound+  case lookupProgram prog programDb' of+    Nothing                           -> return $! Left notFound     Just configuredProg@ConfiguredProgram { programLocation = location } ->       case programVersion configuredProg of         Just version-          | withinRange version range -> return (configuredProg, version, conf')-          | otherwise                 -> die (badVersion version location)-        Nothing                       -> die (noVersion location)+          | withinRange version range ->+            return $! Right (configuredProg, version ,programDb')+          | otherwise                 ->+            return $! Left (badVersion version location)+        Nothing                       ->+          return $! Left (noVersion location) -  where notFound       = "The program "-                      ++ programName prog ++ versionRequirement+  where notFound       = "The program '"+                      ++ programName prog ++ "'" ++ versionRequirement                       ++ " is required but it could not be found."-        badVersion v l = "The program "-                      ++ programName prog ++ versionRequirement+        badVersion v l = "The program '"+                      ++ programName prog ++ "'" ++ versionRequirement                       ++ " is required but the version found at "                       ++ locationPath l ++ " is version " ++ display v-        noVersion l    = "The program "-                      ++ programName prog ++ versionRequirement+        noVersion l    = "The program '"+                      ++ programName prog ++ "'" ++ versionRequirement                       ++ " is required but the version of "                       ++ locationPath l ++ " could not be determined."         versionRequirement           | isAnyVersion range = ""           | otherwise          = " version " ++ display range++-- | Like 'lookupProgramVersion', but raises an exception in case of error+-- instead of returning 'Left errMsg'.+--+requireProgramVersion :: Verbosity -> Program -> VersionRange+                      -> ProgramDb+                      -> IO (ConfiguredProgram, Version, ProgramDb)+requireProgramVersion verbosity prog range programDb =+  join $ either die return <$>+  lookupProgramVersion verbosity prog range programDb

cabal/Cabal/Distribution/Simple/Program/Find.hs view

@@ -89,6 +89,7 @@         -- .bat; .cmd".         extensions = case buildOS of                        Windows -> ["", "exe"]+                       Ghcjs   -> ["", "exe"]                        _       -> [""]      tryPathElem ProgramSearchPathDefault = do

cabal/Cabal/Distribution/Simple/Program/GHC.hs view

@@ -1,8 +1,10 @@+{-# LANGUAGE CPP #-} module Distribution.Simple.Program.GHC (     GhcOptions(..),     GhcMode(..),     GhcOptimisation(..),     GhcDynLinkMode(..),+    GhcProfAuto(..),      ghcInvocation,     renderGhcOptions,@@ -11,20 +13,25 @@    ) where +import Distribution.Simple.GHC.ImplInfo ( getImplInfo, GhcImplInfo(..) ) import Distribution.Package+import Distribution.PackageDescription hiding (Flag) import Distribution.ModuleName import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.Setup    ( Flag(..), flagToMaybe, fromFlagOrDefault,                                       flagToList )---import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program.Types import Distribution.Simple.Program.Run import Distribution.Text import Distribution.Verbosity-import Distribution.Version+import Distribution.Utils.NubList   ( NubListR, fromNubListR ) import Language.Haskell.Extension   ( Language(..), Extension(..) ) +import qualified Data.Map as M+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid+#endif+import Data.List ( intercalate )  -- | A structured set of GHC options/flags --@@ -35,20 +42,20 @@    -- | Any extra options to pass directly to ghc. These go at the end and hence   -- override other stuff.-  ghcOptExtra         :: [String],+  ghcOptExtra         :: NubListR String,    -- | Extra default flags to pass directly to ghc. These go at the beginning   -- and so can be overridden by other stuff.-  ghcOptExtraDefault  :: [String],+  ghcOptExtraDefault  :: NubListR String,    -----------------------   -- Inputs and outputs    -- | The main input files; could be .hs, .hi, .c, .o, depending on mode.-  ghcOptInputFiles    :: [FilePath],+  ghcOptInputFiles    :: NubListR FilePath,    -- | The names of input Haskell modules, mainly for @--make@ mode.-  ghcOptInputModules  :: [ModuleName],+  ghcOptInputModules  :: NubListR ModuleName,    -- | Location for output file; the @ghc -o@ flag.   ghcOptOutputFile    :: Flag FilePath,@@ -62,66 +69,73 @@   ghcOptSourcePathClear :: Flag Bool,    -- | Search path for Haskell source files; the @ghc -i@ flag.-  ghcOptSourcePath    :: [FilePath],+  ghcOptSourcePath    :: NubListR FilePath,    -------------   -- Packages -  -- | The package name the modules will belong to; the @ghc -package-name@ flag-  ghcOptPackageName   :: Flag PackageId,+  -- | The package key the modules will belong to; the @ghc -this-package-key@+  -- flag.+  ghcOptPackageKey   :: Flag PackageKey, -  -- | GHC package databases to use, the @ghc -package-conf@ flag+  -- | GHC package databases to use, the @ghc -package-conf@ flag.   ghcOptPackageDBs    :: PackageDBStack,    -- | The GHC packages to use. For compatability with old and new ghc, this   -- requires both the short and long form of the package id;   -- the @ghc -package@ or @ghc -package-id@ flags.-  ghcOptPackages      :: [(InstalledPackageId, PackageId)],+  ghcOptPackages      ::+    NubListR (InstalledPackageId, PackageId, ModuleRenaming),    -- | Start with a clean package set; the @ghc -hide-all-packages@ flag   ghcOptHideAllPackages :: Flag Bool, -  -- | Don't automatically link in Haskell98 etc; the @ghc -no-auto-link-packages@ flag.+  -- | Don't automatically link in Haskell98 etc; the @ghc+  -- -no-auto-link-packages@ flag.   ghcOptNoAutoLinkPackages :: Flag Bool, +  -- | What packages are implementing the signatures+  ghcOptSigOf :: [(ModuleName, (PackageKey, ModuleName))],+   -----------------   -- Linker stuff    -- | Names of libraries to link in; the @ghc -l@ flag.-  ghcOptLinkLibs      :: [FilePath],+  ghcOptLinkLibs      :: NubListR FilePath,    -- | Search path for libraries to link in; the @ghc -L@ flag.-  ghcOptLinkLibPath  :: [FilePath],+  ghcOptLinkLibPath  :: NubListR FilePath,    -- | Options to pass through to the linker; the @ghc -optl@ flag.-  ghcOptLinkOptions   :: [String],+  ghcOptLinkOptions   :: NubListR String,    -- | OSX only: frameworks to link in; the @ghc -framework@ flag.-  ghcOptLinkFrameworks :: [String],+  ghcOptLinkFrameworks :: NubListR String,    -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag.   ghcOptNoLink :: Flag Bool, -  -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ flag.+  -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@+  -- flag.   ghcOptLinkNoHsMain :: Flag Bool,    --------------------   -- C and CPP stuff    -- | Options to pass through to the C compiler; the @ghc -optc@ flag.-  ghcOptCcOptions     :: [String],+  ghcOptCcOptions     :: NubListR String,    -- | Options to pass through to CPP; the @ghc -optP@ flag.-  ghcOptCppOptions    :: [String],+  ghcOptCppOptions    :: NubListR String,    -- | Search path for CPP includes like header files; the @ghc -I@ flag.-  ghcOptCppIncludePath :: [FilePath],+  ghcOptCppIncludePath :: NubListR FilePath,    -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag.-  ghcOptCppIncludes    :: [FilePath],+  ghcOptCppIncludes    :: NubListR FilePath,    -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag.-  ghcOptFfiIncludes    :: [FilePath],+  ghcOptFfiIncludes    :: NubListR FilePath,    ----------------------------   -- Language and extensions@@ -130,11 +144,11 @@   ghcOptLanguage      :: Flag Language,    -- | The language extensions; the @ghc -X@ flag.-  ghcOptExtensions    :: [Extension],+  ghcOptExtensions    :: NubListR Extension,    -- | A GHC version-dependent mapping of extensions to flags. This must be   -- set to be able to make use of the 'ghcOptExtensions'.-  ghcOptExtensionMap    :: [(Extension, String)],+  ghcOptExtensionMap    :: M.Map Extension String,    ----------------   -- Compilation@@ -142,20 +156,29 @@   -- | What optimisation level to use; the @ghc -O@ flag.   ghcOptOptimisation  :: Flag GhcOptimisation, +    -- | Emit debug info; the @ghc -g@ flag.+  ghcOptDebugInfo  :: Flag Bool,+   -- | Compile in profiling mode; the @ghc -prof@ flag.   ghcOptProfilingMode :: Flag Bool, +  -- | Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags.+  ghcOptProfilingAuto :: Flag GhcProfAuto,+   -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag.   ghcOptSplitObjs     :: Flag Bool,    -- | Run N jobs simultaneously (if possible).-  ghcOptNumJobs       :: Flag Int,+  ghcOptNumJobs       :: Flag (Maybe Int), +  -- | Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags.+  ghcOptHPCDir        :: Flag FilePath,+   ----------------   -- GHCi    -- | Extra GHCi startup scripts; the @-ghci-script@ flag-  ghcOptGHCiScripts    :: [FilePath],+  ghcOptGHCiScripts    :: NubListR FilePath,    ------------------------   -- Redirecting outputs@@ -176,6 +199,7 @@   ghcOptShared        :: Flag Bool,   ghcOptFPic          :: Flag Bool,   ghcOptDylibName     :: Flag String,+  ghcOptRPaths        :: NubListR FilePath,    ---------------   -- Misc flags@@ -210,6 +234,10 @@                     | GhcStaticAndDynamic -- ^ @-static -dynamic-too@  deriving (Show, Eq) +data GhcProfAuto = GhcProfAutoAll       -- ^ @-fprof-auto@+                 | GhcProfAutoToplevel  -- ^ @-fprof-auto-top@+                 | GhcProfAutoExported  -- ^ @-fprof-auto-exported@+ deriving (Show, Eq)  runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> GhcOptions -> IO () runGHC verbosity ghcProg comp opts = do@@ -220,12 +248,11 @@ ghcInvocation prog comp opts =     programInvocation prog (renderGhcOptions comp opts) - renderGhcOptions :: Compiler -> GhcOptions -> [String] renderGhcOptions comp opts-  | compilerFlavor comp /= GHC =+  | compilerFlavor comp `notElem` [GHC, GHCJS] =     error $ "Distribution.Simple.Program.GHC.renderGhcOptions: "-    ++ "compiler flavor must be 'GHC'!"+    ++ "compiler flavor must be 'GHC' or 'GHCJS'!"   | otherwise =   concat   [ case flagToMaybe (ghcOptMode opts) of@@ -247,7 +274,8 @@    , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts)) -  , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal, ver >= [6,11] ]+  , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal+                                 , flagBuildingCabalPkg implInfo ]    ----------------   -- Compilation@@ -259,15 +287,34 @@       Just GhcMaximumOptimisation     -> ["-O2"]       Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph +  , [ "-g" | flagDebugInfo implInfo && flagBool ghcOptDebugInfo ]+   , [ "-prof" | flagBool ghcOptProfilingMode ] +  , case flagToMaybe (ghcOptProfilingAuto opts) of+      _ | not (flagBool ghcOptProfilingMode)+                                -> []+      Nothing                   -> []+      Just GhcProfAutoAll+        | flagProfAuto implInfo -> ["-fprof-auto"]+        | otherwise             -> ["-auto-all"] -- not the same, but close+      Just GhcProfAutoToplevel+        | flagProfAuto implInfo -> ["-fprof-auto-top"]+        | otherwise             -> ["-auto-all"]+      Just GhcProfAutoExported+        | flagProfAuto implInfo -> ["-fprof-auto-exported"]+        | otherwise             -> ["-auto"]+   , [ "-split-objs" | flagBool ghcOptSplitObjs ] +  , case flagToMaybe (ghcOptHPCDir opts) of+      Nothing -> []+      Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir]    , if parmakeSupported comp-    then-      let numJobs = fromFlagOrDefault 1 (ghcOptNumJobs opts)-      in if numJobs > 1 then ["-j" ++ show numJobs] else []+    then case ghcOptNumJobs opts of+      NoFlag  -> []+      Flag n  -> ["-j" ++ maybe "" show n]     else []    --------------------@@ -290,10 +337,12 @@   , concat [ ["-hisuf",   suf] | suf <- flag ghcOptHiSuffix  ]   , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ]   , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix  ]-  , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir, ver >= [6,10] ]+  , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir+                                 , flagOutputDir implInfo ]   , concat [ ["-odir",    dir] | dir <- flag ghcOptObjDir ]   , concat [ ["-hidir",   dir] | dir <- flag ghcOptHiDir  ]-  , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir, ver >= [6,8] ]+  , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir+                               , flagStubdir implInfo ]    -----------------------   -- Source search path@@ -306,8 +355,10 @@    , [ "-I"    ++ dir | dir <- flags ghcOptCppIncludePath ]   , [ "-optP" ++ opt | opt <- flags ghcOptCppOptions ]-  , concat [ [ "-optP-include", "-optP" ++ inc] | inc <- flags ghcOptCppIncludes ]-  , [ "-#include \"" ++ inc ++ "\"" | inc <- flags ghcOptFfiIncludes, ver < [6,11] ]+  , concat [ [ "-optP-include", "-optP" ++ inc]+           | inc <- flags ghcOptCppIncludes ]+  , [ "-#include \"" ++ inc ++ "\""+    | inc <- flags ghcOptFfiIncludes, flagFfiIncludes implInfo ]   , [ "-optc" ++ opt | opt <- flags ghcOptCcOptions ]    -----------------@@ -318,45 +369,64 @@   , ["-L" ++ dir     | dir <- flags ghcOptLinkLibPath ]   , concat [ ["-framework", fmwk] | fmwk <- flags ghcOptLinkFrameworks ]   , [ "-no-hs-main"  | flagBool ghcOptLinkNoHsMain ]+  , [ "-dynload deploy" | not (null (flags ghcOptRPaths)) ]+  , concat [ [ "-optl-Wl,-rpath," ++ dir]+           | dir <- flags ghcOptRPaths ]    -------------   -- Packages -  , concat [ ["-package-name", display pkgid] | pkgid <- flag ghcOptPackageName ]+  , concat [ [if packageKeySupported comp+                then "-this-package-key"+                else "-package-name", display pkgid]+             | pkgid <- flag ghcOptPackageKey ]    , [ "-hide-all-packages"     | flagBool ghcOptHideAllPackages ]   , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ] -  , packageDbArgs version (flags ghcOptPackageDBs)+  , packageDbArgs implInfo (ghcOptPackageDBs opts) -  , concat $ if ver >= [6,11]-      then [ ["-package-id", display ipkgid] | (ipkgid,_) <- flags ghcOptPackages ]-      else [ ["-package",    display  pkgid] | (_,pkgid)  <- flags ghcOptPackages ]+  , if null (ghcOptSigOf opts)+        then []+        else "-sig-of"+             : intercalate "," (map (\(n,(p,m)) -> display n ++ " is "+                                                ++ display p ++ ":"+                                                ++ display m)+                                    (ghcOptSigOf opts))+             : [] +  , concat $ if flagPackageId implInfo+      then let space "" = ""+               space xs = ' ' : xs+           in [ ["-package-id", display ipkgid ++ space (display rns)]+              | (ipkgid,_,rns) <- flags ghcOptPackages ]+      else [ ["-package",    display  pkgid]+           | (_,pkgid,_)  <- flags ghcOptPackages ]+   ----------------------------   -- Language and extensions -  , if ver >= [7]+  , if supportsHaskell2010 implInfo     then [ "-X" ++ display lang | lang <- flag ghcOptLanguage ]     else [] -  , [ case lookup ext (ghcOptExtensionMap opts) of+  , [ case M.lookup ext (ghcOptExtensionMap opts) of         Just arg -> arg         Nothing  -> error $ "Distribution.Simple.Program.GHC.renderGhcOptions: "                           ++ display ext ++ " not present in ghcOptExtensionMap."-    | ext <- ghcOptExtensions opts ]+    | ext <- flags ghcOptExtensions ]    ----------------   -- GHCi    , concat [ [ "-ghci-script", script ] | script <- flags  ghcOptGHCiScripts-                                        , ver >= [7,2] ]+                                        , flagGhciScript implInfo ]    ---------------   -- Inputs    , [ display modu | modu <- flags ghcOptInputModules ]-  , ghcOptInputFiles opts+  , flags ghcOptInputFiles    , concat [ [ "-o",    out] | out <- flag ghcOptOutputFile ]   , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ]@@ -364,18 +434,17 @@   ---------------   -- Extra -  , ghcOptExtra opts+  , flags ghcOptExtra    ]     where+    implInfo     = getImplInfo comp     flag     flg = flagToList (flg opts)-    flags    flg = flg opts+    flags    flg = fromNubListR . flg $ opts     flagBool flg = fromFlagOrDefault False (flg opts) -    version@(Version ver _) = compilerVersion comp- verbosityOpts :: Verbosity -> [String] verbosityOpts verbosity   | verbosity >= deafening = ["-v"]@@ -383,24 +452,42 @@   | otherwise              = ["-w", "-v0"]  -packageDbArgs :: Version -> PackageDBStack -> [String]-packageDbArgs (Version ver _) dbstack = case dbstack of+-- | GHC <7.6 uses '-package-conf' instead of '-package-db'.+packageDbArgsConf :: PackageDBStack -> [String]+packageDbArgsConf dbstack = case dbstack of   (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs-  (GlobalPackageDB:dbs)               -> ("-no-user-" ++ packageDbFlag)+  (GlobalPackageDB:dbs)               -> ("-no-user-package-conf")                                        : concatMap specific dbs   _ -> ierror   where-    specific (SpecificPackageDB db) = [ '-':packageDbFlag , db ]-    specific _ = ierror-    ierror     = error $ "internal error: unexpected package db stack: "-                      ++ show dbstack+    specific (SpecificPackageDB db) = [ "-package-conf", db ]+    specific _                      = ierror+    ierror = error $ "internal error: unexpected package db stack: "+                  ++ show dbstack -    packageDbFlag-      | ver < [7,5]-      = "package-conf"-      | otherwise-      = "package-db"+-- | GHC >= 7.6 uses the '-package-db' flag. See+-- https://ghc.haskell.org/trac/ghc/ticket/5977.+packageDbArgsDb :: PackageDBStack -> [String]+-- special cases to make arguments prettier in common scenarios+packageDbArgsDb dbstack = case dbstack of+  (GlobalPackageDB:UserPackageDB:dbs)+    | all isSpecific dbs              -> concatMap single dbs+  (GlobalPackageDB:dbs)+    | all isSpecific dbs              -> "-no-user-package-db"+                                       : concatMap single dbs+  dbs                                 -> "-clear-package-db"+                                       : concatMap single dbs+ where+   single (SpecificPackageDB db) = [ "-package-db", db ]+   single GlobalPackageDB        = [ "-global-package-db" ]+   single UserPackageDB          = [ "-user-package-db" ]+   isSpecific (SpecificPackageDB _) = True+   isSpecific _                     = False +packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String]+packageDbArgs implInfo+  | flagPackageConf implInfo = packageDbArgsConf+  | otherwise                = packageDbArgsDb  -- ----------------------------------------------------------------------------- -- Boilerplate Monoid instance for GhcOptions@@ -416,11 +503,12 @@     ghcOptOutputDynFile      = mempty,     ghcOptSourcePathClear    = mempty,     ghcOptSourcePath         = mempty,-    ghcOptPackageName        = mempty,+    ghcOptPackageKey         = mempty,     ghcOptPackageDBs         = mempty,     ghcOptPackages           = mempty,     ghcOptHideAllPackages    = mempty,     ghcOptNoAutoLinkPackages = mempty,+    ghcOptSigOf              = mempty,     ghcOptLinkLibs           = mempty,     ghcOptLinkLibPath        = mempty,     ghcOptLinkOptions        = mempty,@@ -436,9 +524,12 @@     ghcOptExtensions         = mempty,     ghcOptExtensionMap       = mempty,     ghcOptOptimisation       = mempty,+    ghcOptDebugInfo          = mempty,     ghcOptProfilingMode      = mempty,+    ghcOptProfilingAuto      = mempty,     ghcOptSplitObjs          = mempty,     ghcOptNumJobs            = mempty,+    ghcOptHPCDir             = mempty,     ghcOptGHCiScripts        = mempty,     ghcOptHiSuffix           = mempty,     ghcOptObjSuffix          = mempty,@@ -452,6 +543,7 @@     ghcOptShared             = mempty,     ghcOptFPic               = mempty,     ghcOptDylibName          = mempty,+    ghcOptRPaths             = mempty,     ghcOptVerbosity          = mempty,     ghcOptCabal              = mempty   }@@ -465,11 +557,12 @@     ghcOptOutputDynFile      = combine ghcOptOutputDynFile,     ghcOptSourcePathClear    = combine ghcOptSourcePathClear,     ghcOptSourcePath         = combine ghcOptSourcePath,-    ghcOptPackageName        = combine ghcOptPackageName,+    ghcOptPackageKey         = combine ghcOptPackageKey,     ghcOptPackageDBs         = combine ghcOptPackageDBs,     ghcOptPackages           = combine ghcOptPackages,     ghcOptHideAllPackages    = combine ghcOptHideAllPackages,     ghcOptNoAutoLinkPackages = combine ghcOptNoAutoLinkPackages,+    ghcOptSigOf              = combine ghcOptSigOf,     ghcOptLinkLibs           = combine ghcOptLinkLibs,     ghcOptLinkLibPath        = combine ghcOptLinkLibPath,     ghcOptLinkOptions        = combine ghcOptLinkOptions,@@ -485,9 +578,12 @@     ghcOptExtensions         = combine ghcOptExtensions,     ghcOptExtensionMap       = combine ghcOptExtensionMap,     ghcOptOptimisation       = combine ghcOptOptimisation,+    ghcOptDebugInfo          = combine ghcOptDebugInfo,     ghcOptProfilingMode      = combine ghcOptProfilingMode,+    ghcOptProfilingAuto      = combine ghcOptProfilingAuto,     ghcOptSplitObjs          = combine ghcOptSplitObjs,     ghcOptNumJobs            = combine ghcOptNumJobs,+    ghcOptHPCDir             = combine ghcOptHPCDir,     ghcOptGHCiScripts        = combine ghcOptGHCiScripts,     ghcOptHiSuffix           = combine ghcOptHiSuffix,     ghcOptObjSuffix          = combine ghcOptObjSuffix,@@ -501,6 +597,7 @@     ghcOptShared             = combine ghcOptShared,     ghcOptFPic               = combine ghcOptFPic,     ghcOptDylibName          = combine ghcOptDylibName,+    ghcOptRPaths             = combine ghcOptRPaths,     ghcOptVerbosity          = combine ghcOptVerbosity,     ghcOptCabal              = combine ghcOptCabal   }

cabal/Cabal/Distribution/Simple/Program/HcPkg.hs view

@@ -7,9 +7,11 @@ -- Portability :  portable -- -- This module provides an library interface to the @hc-pkg@ program.--- Currently only GHC and LHC have hc-pkg programs.+-- Currently only GHC, GHCJS and LHC have hc-pkg programs.  module Distribution.Simple.Program.HcPkg (+    HcPkgInfo(..),+     init,     invoke,     register,@@ -35,19 +37,17 @@ import Distribution.Package          ( PackageId, InstalledPackageId(..) ) import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo, InstalledPackageInfo_(..)+         ( InstalledPackageInfo, InstalledPackageInfo(..)          , showInstalledPackageInfo          , emptyInstalledPackageInfo, fieldsInstalledPackageInfo ) import Distribution.ParseUtils import Distribution.Simple.Compiler          ( PackageDB(..), PackageDBStack ) import Distribution.Simple.Program.Types-         ( ConfiguredProgram(programId, programVersion) )+         ( ConfiguredProgram(programId) ) import Distribution.Simple.Program.Run          ( ProgramInvocation(..), IOEncoding(..), programInvocation          , runProgramInvocation, getProgramInvocationOutput )-import Distribution.Version-         ( Version(..) ) import Distribution.Text          ( display, simpleParse ) import Distribution.Simple.Utils@@ -59,127 +59,123 @@  import Data.Char          ( isSpace )-import Data.Maybe-         ( fromMaybe ) import Data.List          ( stripPrefix ) import System.FilePath as FilePath          ( (</>), splitPath, splitDirectories, joinPath, isPathSeparator ) import qualified System.FilePath.Posix as FilePath.Posix +-- | Information about the features and capabilities of an @hc-pkg@+--   program.+--+data HcPkgInfo = HcPkgInfo+  { hcPkgProgram    :: ConfiguredProgram+  , noPkgDbStack    :: Bool -- ^ no package DB stack supported+  , noVerboseFlag   :: Bool -- ^ hc-pkg does not support verbosity flags+  , flagPackageConf :: Bool -- ^ use package-conf option instead of package-db+  , useSingleFileDb :: Bool -- ^ requires single file package database+  }  -- | Call @hc-pkg@ to initialise a package database at the location {path}. -- -- > hc-pkg init {path} ---init :: Verbosity -> ConfiguredProgram -> FilePath -> IO ()-init verbosity hcPkg path =-  runProgramInvocation verbosity-    (initInvocation hcPkg verbosity path)+init :: HcPkgInfo -> Verbosity -> FilePath -> IO ()+init hpi verbosity path =+  runProgramInvocation verbosity (initInvocation hpi verbosity path)  -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it.-invoke :: Verbosity -> ConfiguredProgram -> PackageDBStack -> [String] -> IO ()-invoke verbosity hcPkg dbStack extraArgs =+invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO ()+invoke hpi verbosity dbStack extraArgs =   runProgramInvocation verbosity invocation   where-    args       = packageDbStackOpts hcPkg dbStack ++ extraArgs-    invocation = programInvocation hcPkg args+    args       = packageDbStackOpts hpi dbStack ++ extraArgs+    invocation = programInvocation (hcPkgProgram hpi) args  -- | Call @hc-pkg@ to register a package. -- -- > hc-pkg register {filename | -} [--user | --global | --package-db] ---register :: Verbosity -> ConfiguredProgram -> PackageDBStack+register :: HcPkgInfo -> Verbosity -> PackageDBStack          -> Either FilePath                    InstalledPackageInfo          -> IO ()-register verbosity hcPkg packagedb pkgFile =+register hpi verbosity packagedb pkgFile =   runProgramInvocation verbosity-    (registerInvocation hcPkg verbosity packagedb pkgFile)+    (registerInvocation hpi verbosity packagedb pkgFile)   -- | Call @hc-pkg@ to re-register a package. -- -- > hc-pkg register {filename | -} [--user | --global | --package-db] ---reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack+reregister :: HcPkgInfo -> Verbosity -> PackageDBStack            -> Either FilePath                      InstalledPackageInfo            -> IO ()-reregister verbosity hcPkg packagedb pkgFile =+reregister hpi verbosity packagedb pkgFile =   runProgramInvocation verbosity-    (reregisterInvocation hcPkg verbosity packagedb pkgFile)+    (reregisterInvocation hpi verbosity packagedb pkgFile)   -- | Call @hc-pkg@ to unregister a package -- -- > hc-pkg unregister [pkgid] [--user | --global | --package-db] ---unregister :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()-unregister verbosity hcPkg packagedb pkgid =+unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()+unregister hpi verbosity packagedb pkgid =   runProgramInvocation verbosity-    (unregisterInvocation hcPkg verbosity packagedb pkgid)+    (unregisterInvocation hpi verbosity packagedb pkgid)   -- | Call @hc-pkg@ to expose a package. -- -- > hc-pkg expose [pkgid] [--user | --global | --package-db] ---expose :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()-expose verbosity hcPkg packagedb pkgid =+expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()+expose hpi verbosity packagedb pkgid =   runProgramInvocation verbosity-    (exposeInvocation hcPkg verbosity packagedb pkgid)+    (exposeInvocation hpi verbosity packagedb pkgid)  --- | Call @hc-pkg@ to expose a package.+-- | Call @hc-pkg@ to hide a package. ----- > hc-pkg expose [pkgid] [--user | --global | --package-db]+-- > hc-pkg hide [pkgid] [--user | --global | --package-db] ---hide :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()-hide verbosity hcPkg packagedb pkgid =+hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()+hide hpi verbosity packagedb pkgid =   runProgramInvocation verbosity-    (hideInvocation hcPkg verbosity packagedb pkgid)+    (hideInvocation hpi verbosity packagedb pkgid)   -- | Call @hc-pkg@ to get all the details of all the packages in the given -- package database. ---dump :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [InstalledPackageInfo]-dump verbosity hcPkg packagedb = do+dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo]+dump hpi verbosity packagedb = do    output <- getProgramInvocationOutput verbosity-              (dumpInvocation hcPkg verbosity packagedb)-    `catchExit` \_ -> die $ programId hcPkg ++ " dump failed"+              (dumpInvocation hpi verbosity packagedb)+    `catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed"    case parsePackages output of     Left ok -> return ok     _       -> die $ "failed to parse output of '"-                  ++ programId hcPkg ++ " dump'"+                  ++ programId (hcPkgProgram hpi) ++ " dump'"    where     parsePackages str =       let parsed = map parseInstalledPackageInfo' (splitPkgs str)        in case [ msg | ParseFailed msg <- parsed ] of             []   -> Left [   setInstalledPackageId-                           . maybe id mungePackagePaths pkgroot+                           . maybe id mungePackagePaths (pkgRoot pkg)                            $ pkg-                         | ParseOk _ (pkgroot, pkg) <- parsed ]+                         | ParseOk _ pkg <- parsed ]             msgs -> Right msgs      parseInstalledPackageInfo' =-        parseFieldsFlat fields (Nothing, emptyInstalledPackageInfo)-      where-        fields =     liftFieldFst pkgrootField-               : map liftFieldSnd fieldsInstalledPackageInfo--        pkgrootField =-          simpleField "pkgroot"-            showFilePath    parseFilePathQ-            (fromMaybe "")  (\x _ -> Just x)--        liftFieldFst = liftField fst (\x (_x,y) -> (x,y))-        liftFieldSnd = liftField snd (\y (x,_y) -> (x,y))+      parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo      --TODO: this could be a lot faster. We're doing normaliseLineEndings twice     -- and converting back and forth with lines/unlines.@@ -256,162 +252,145 @@ -- Note in particular that it does not include the 'InstalledPackageId', just -- the source 'PackageId' which is not necessarily unique in any package db. ---list :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [PackageId]-list verbosity hcPkg packagedb = do+list :: HcPkgInfo -> Verbosity -> PackageDB+     -> IO [PackageId]+list hpi verbosity packagedb = do    output <- getProgramInvocationOutput verbosity-              (listInvocation hcPkg verbosity packagedb)-    `catchExit` \_ -> die $ programId hcPkg ++ " list failed"+              (listInvocation hpi verbosity packagedb)+    `catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed"    case parsePackageIds output of     Just ok -> return ok     _       -> die $ "failed to parse output of '"-                  ++ programId hcPkg ++ " list'"+                  ++ programId (hcPkgProgram hpi) ++ " list'"    where-    parsePackageIds str =-      let parsed = map simpleParse (words str)-       in case [ () | Nothing <- parsed ] of-            [] -> Just [ pkgid | Just pkgid <- parsed ]-            _  -> Nothing-+    parsePackageIds = sequence . map simpleParse . words  -------------------------- -- The program invocations -- -initInvocation :: ConfiguredProgram-               -> Verbosity -> FilePath -> ProgramInvocation-initInvocation hcPkg verbosity path =-    programInvocation hcPkg args+initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation+initInvocation hpi verbosity path =+    programInvocation (hcPkgProgram hpi) args   where     args = ["init", path]-        ++ verbosityOpts hcPkg verbosity+        ++ verbosityOpts hpi verbosity  registerInvocation, reregisterInvocation-  :: ConfiguredProgram -> Verbosity -> PackageDBStack+  :: HcPkgInfo -> Verbosity -> PackageDBStack   -> Either FilePath InstalledPackageInfo   -> ProgramInvocation registerInvocation   = registerInvocation' "register" reregisterInvocation = registerInvocation' "update"  -registerInvocation' :: String-                    -> ConfiguredProgram -> Verbosity -> PackageDBStack+registerInvocation' :: String -> HcPkgInfo -> Verbosity -> PackageDBStack                     -> Either FilePath InstalledPackageInfo                     -> ProgramInvocation-registerInvocation' cmdname hcPkg verbosity packagedbs (Left pkgFile) =-    programInvocation hcPkg args+registerInvocation' cmdname hpi verbosity packagedbs (Left pkgFile) =+    programInvocation (hcPkgProgram hpi) args   where     args = [cmdname, pkgFile]-        ++ (if legacyVersion hcPkg-              then [packageDbOpts hcPkg (last packagedbs)]-              else packageDbStackOpts hcPkg packagedbs)-        ++ verbosityOpts hcPkg verbosity+        ++ (if noPkgDbStack hpi+              then [packageDbOpts hpi (last packagedbs)]+              else packageDbStackOpts hpi packagedbs)+        ++ verbosityOpts hpi verbosity -registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) =-    (programInvocation hcPkg args) {+registerInvocation' cmdname hpi verbosity packagedbs (Right pkgInfo) =+    (programInvocation (hcPkgProgram hpi) args) {       progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),       progInvokeInputEncoding = IOEncodingUTF8     }   where     args = [cmdname, "-"]-        ++ (if legacyVersion hcPkg-              then [packageDbOpts hcPkg (last packagedbs)]-              else packageDbStackOpts hcPkg packagedbs)-        ++ verbosityOpts hcPkg verbosity+        ++ (if noPkgDbStack hpi+              then [packageDbOpts hpi (last packagedbs)]+              else packageDbStackOpts hpi packagedbs)+        ++ verbosityOpts hpi verbosity  -unregisterInvocation :: ConfiguredProgram-                     -> Verbosity -> PackageDB -> PackageId+unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId                      -> ProgramInvocation-unregisterInvocation hcPkg verbosity packagedb pkgid =-  programInvocation hcPkg $-       ["unregister", packageDbOpts hcPkg packagedb, display pkgid]-    ++ verbosityOpts hcPkg verbosity+unregisterInvocation hpi verbosity packagedb pkgid =+  programInvocation (hcPkgProgram hpi) $+       ["unregister", packageDbOpts hpi packagedb, display pkgid]+    ++ verbosityOpts hpi verbosity  -exposeInvocation :: ConfiguredProgram-                 -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation-exposeInvocation hcPkg verbosity packagedb pkgid =-  programInvocation hcPkg $-       ["expose", packageDbOpts hcPkg packagedb, display pkgid]-    ++ verbosityOpts hcPkg verbosity+exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId+                 -> ProgramInvocation+exposeInvocation hpi verbosity packagedb pkgid =+  programInvocation (hcPkgProgram hpi) $+       ["expose", packageDbOpts hpi packagedb, display pkgid]+    ++ verbosityOpts hpi verbosity  -hideInvocation :: ConfiguredProgram-               -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation-hideInvocation hcPkg verbosity packagedb pkgid =-  programInvocation hcPkg $-       ["hide", packageDbOpts hcPkg packagedb, display pkgid]-    ++ verbosityOpts hcPkg verbosity+hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId+               -> ProgramInvocation+hideInvocation hpi verbosity packagedb pkgid =+  programInvocation (hcPkgProgram hpi) $+       ["hide", packageDbOpts hpi packagedb, display pkgid]+    ++ verbosityOpts hpi verbosity  -dumpInvocation :: ConfiguredProgram-               -> Verbosity -> PackageDB -> ProgramInvocation-dumpInvocation hcPkg _verbosity packagedb =-    (programInvocation hcPkg args) {+dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation+dumpInvocation hpi _verbosity packagedb =+    (programInvocation (hcPkgProgram hpi) args) {       progInvokeOutputEncoding = IOEncodingUTF8     }   where-    args = ["dump", packageDbOpts hcPkg packagedb]-        ++ verbosityOpts hcPkg silent+    args = ["dump", packageDbOpts hpi packagedb]+        ++ verbosityOpts hpi silent            -- We use verbosity level 'silent' because it is important that we            -- do not contaminate the output with info/debug messages. -listInvocation :: ConfiguredProgram-               -> Verbosity -> PackageDB -> ProgramInvocation-listInvocation hcPkg _verbosity packagedb =-    (programInvocation hcPkg args) {+listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation+listInvocation hpi _verbosity packagedb =+    (programInvocation (hcPkgProgram hpi) args) {       progInvokeOutputEncoding = IOEncodingUTF8     }   where-    args = ["list", "--simple-output", packageDbOpts hcPkg packagedb]-        ++ verbosityOpts hcPkg silent+    args = ["list", "--simple-output", packageDbOpts hpi packagedb]+        ++ verbosityOpts hpi silent            -- We use verbosity level 'silent' because it is important that we            -- do not contaminate the output with info/debug messages.  -packageDbStackOpts :: ConfiguredProgram -> PackageDBStack -> [String]-packageDbStackOpts hcPkg dbstack = case dbstack of+packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String]+packageDbStackOpts hpi dbstack = case dbstack of   (GlobalPackageDB:UserPackageDB:dbs) -> "--global"                                        : "--user"                                        : map specific dbs   (GlobalPackageDB:dbs)               -> "--global"-                                       : ("--no-user-" ++ packageDbFlag hcPkg)+                                       : ("--no-user-" ++ packageDbFlag hpi)                                        : map specific dbs   _                                   -> ierror   where-    specific (SpecificPackageDB db) = "--" ++ packageDbFlag hcPkg ++ "=" ++ db+    specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db     specific _ = ierror     ierror :: a     ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack) -packageDbFlag :: ConfiguredProgram -> String-packageDbFlag hcPkg-  | programVersion hcPkg < Just (Version [7,5] [])+packageDbFlag :: HcPkgInfo -> String+packageDbFlag hpi+  | flagPackageConf hpi   = "package-conf"   | otherwise   = "package-db" -packageDbOpts :: ConfiguredProgram -> PackageDB -> String+packageDbOpts :: HcPkgInfo -> PackageDB -> String packageDbOpts _ GlobalPackageDB        = "--global" packageDbOpts _ UserPackageDB          = "--user"-packageDbOpts hcPkg (SpecificPackageDB db) = "--" ++ packageDbFlag hcPkg ++ "=" ++ db--verbosityOpts :: ConfiguredProgram -> Verbosity -> [String]-verbosityOpts hcPkg v+packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db -  -- ghc-pkg < 6.11 does not support -v-  | programId hcPkg == "ghc-pkg"- && programVersion hcPkg < Just (Version [6,11] [])+verbosityOpts :: HcPkgInfo -> Verbosity -> [String]+verbosityOpts hpi v+  | noVerboseFlag hpi                    = []-   | v >= deafening = ["-v2"]   | v == silent    = ["-v0"]   | otherwise      = [] --- Handle quirks in ghc-pkg 6.8 and older-legacyVersion :: ConfiguredProgram -> Bool-legacyVersion hcPkg = programId hcPkg == "ghc-pkg"-                   && programVersion hcPkg < Just (Version [6,9] [])

cabal/Cabal/Distribution/Simple/Program/Hpc.hs view

@@ -55,7 +55,7 @@     runProgramInvocation verbosity       (markupInvocation hpc tixFile hpcDirs' destDir excluded)   where-    version07 = Version { versionBranch = [0, 7], versionTags = [] }+    version07 = Version [0, 7] []     (passedDirs, droppedDirs) = splitAt 1 hpcDirs  markupInvocation :: ConfiguredProgram

+ cabal/Cabal/Distribution/Simple/Program/Internal.hs view

@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Program.Internal+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Internal utilities used by Distribution.Simple.Program.*.++module Distribution.Simple.Program.Internal (+    stripExtractVersion,+  ) where++import Data.Char (isDigit)+import Data.List (isPrefixOf, isSuffixOf)++-- | Extract the version number from the output of 'strip --version'.+--+-- Invoking "strip --version" gives very inconsistent results. We ignore+-- everything in parentheses (see #2497), look for the first word that starts+-- with a number, and try parsing out the first two components of it. Non-GNU+-- 'strip' doesn't appear to have a version flag.+stripExtractVersion :: String -> String+stripExtractVersion str =+  let numeric ""    = False+      numeric (x:_) = isDigit x++      -- Filter out everything in parentheses.+      filterPar' :: Int -> [String] -> [String]+      filterPar' _ []                   = []+      filterPar' n (x:xs)+        | n >= 0 && "(" `isPrefixOf` x = filterPar' (n+1) ((tail x):xs)+        | n >  0 && ")" `isSuffixOf` x = filterPar' (n-1) xs+        | n >  0                       = filterPar' n xs+        | otherwise                    = x:filterPar' n xs++      filterPar = filterPar' 0++  in case dropWhile (not . numeric) (filterPar . words $ str) of+    (ver:_) ->+      -- take the first two version components+      let isDot         = (== '.')+          (major, rest) = break isDot ver+          minor         = takeWhile isDigit (dropWhile isDot rest)+      in major ++ "." ++ minor+    _ -> ""

cabal/Cabal/Distribution/Simple/Program/Run.hs view

@@ -133,7 +133,7 @@                                     mcwd menv                                     (Just input) True     when (exitCode /= ExitSuccess) $-      die errors+      die $ "'" ++ path ++ "' exited with an error:\n" ++ errors   where     input = case encoding of               IOEncodingText -> (inputStr, False)@@ -160,7 +160,7 @@                                     mcwd menv                                     input utf8     when (exitCode /= ExitSuccess) $-      die errors+      die $ "'" ++ path ++ "' exited with an error:\n" ++ errors     return (decode output)   where     input =

cabal/Cabal/Distribution/Simple/Program/Strip.hs view

@@ -11,12 +11,15 @@        where  import Distribution.Simple.Program (ProgramConfiguration, lookupProgram-                                   ,rawSystemProgram, stripProgram)+                                   , programVersion, rawSystemProgram+                                   , stripProgram) import Distribution.Simple.Utils   (warn)-import Distribution.System         (OS (..), buildOS)+import Distribution.System         (Arch(..), Platform(..), OS (..), buildOS) import Distribution.Verbosity      (Verbosity)+import Distribution.Version        (orLaterVersion, withinRange)  import Control.Monad               (unless)+import Data.Version                (Version(..)) import System.FilePath             (takeBaseName)  runStrip :: Verbosity -> ProgramConfiguration -> FilePath -> [String] -> IO ()@@ -30,19 +33,40 @@                                    ++ (takeBaseName path)                                    ++ "' (missing the 'strip' program)" -stripExe :: Verbosity -> ProgramConfiguration -> FilePath -> IO ()-stripExe verbosity conf path =+stripExe :: Verbosity -> Platform -> ProgramConfiguration -> FilePath -> IO ()+stripExe verbosity (Platform _arch os) conf path =   runStrip verbosity conf path args   where-    args = case buildOS of+    args = case os of        OSX -> ["-x"] -- By default, stripping the ghc binary on at least                      -- some OS X installations causes:                      --     HSbase-3.0.o: unknown symbol `_environ'"                      -- The -x flag fixes that.        _   -> [] -stripLib :: Verbosity -> ProgramConfiguration -> FilePath -> IO ()-stripLib verbosity conf path = do-  runStrip verbosity conf path args+stripLib :: Verbosity -> Platform -> ProgramConfiguration -> FilePath -> IO ()+stripLib verbosity (Platform arch os) conf path = do+  case os of+    OSX -> -- '--strip-unneeded' is not supported on OS X, iOS or+           -- Solaris. See #1630.+           return ()+    IOS -> return ()+    Solaris -> return ()+    Windows -> -- Stripping triggers a bug in 'strip.exe' for+               -- libraries with lots identically named modules. See+               -- #1784.+               return()+    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+          Just v | withinRange v okVersion ->+            runStrip verbosity conf 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   where     args = ["--strip-unneeded"]

cabal/Cabal/Distribution/Simple/Program/Types.hs view

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Program.Types@@ -38,6 +40,10 @@ import Distribution.Verbosity          ( Verbosity ) +import Distribution.Compat.Binary (Binary)+import qualified Data.Map as Map+import GHC.Generics (Generic)+ -- | Represents a program which can be configured. -- -- Note: rather than constructing this directly, start with 'simpleProgram' and@@ -57,7 +63,7 @@                               -> IO (Maybe FilePath),         -- | Try to find the version of the program. For many programs this is-       -- not possible or is not necessary so it's ok to return Nothing.+       -- not possible or is not necessary so it's OK to return Nothing.        programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version),         -- | A function to do any additional configuration after we have@@ -96,11 +102,18 @@        -- the current to form the environment for the new process.        programOverrideEnv :: [(String, Maybe String)], +       -- | A key-value map listing various properties of the program, useful+       -- for feature detection. Populated during the configuration step, key+       -- names depend on the specific program.+       programProperties :: Map.Map String String,+        -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@        programLocation :: ProgramLocation-     } deriving (Read, Show, Eq)+     } deriving (Eq, Generic, Read, Show) --- | Where a program was found. Also tells us whether it's specifed by user or+instance Binary ConfiguredProgram++-- | Where a program was found. Also tells us whether it's specified by user or -- not.  This includes not just the path, but the program as well. data ProgramLocation     = UserSpecified { locationPath :: FilePath }@@ -108,8 +121,10 @@       -- eg. --ghc-path=\/usr\/bin\/ghc-6.6     | FoundOnSystem { locationPath :: FilePath }       -- ^The program was found automatically.-      deriving (Read, Show, Eq)+      deriving (Eq, Generic, Read, Show) +instance Binary ProgramLocation+ -- | The full path of a configured program. programPath :: ConfiguredProgram -> FilePath programPath = locationPath . programLocation@@ -144,5 +159,6 @@      programDefaultArgs  = [],      programOverrideArgs = [],      programOverrideEnv  = [],+     programProperties   = Map.empty,      programLocation     = loc   }

cabal/Cabal/Distribution/Simple/Register.hs view

@@ -2,6 +2,7 @@ -- | -- Module      :  Distribution.Simple.Register -- Copyright   :  Isaac Jones 2003-2004+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -14,7 +15,7 @@ -- popular so we also provide a way to simply generate the package registration -- file which then must be manually passed to @ghc-pkg@. It is possible to -- generate registration information for where the package is to be installed,--- or alternatively to register the package inplace in the build tree. The+-- or alternatively to register the package in place in the build tree. The -- latter is occasionally handy, and will become more important when we try to -- build multi-package systems. --@@ -22,37 +23,6 @@ -- mixes it all in in this module, which is rather unsatisfactory. The script -- generation and the unregister feature are not well used or tested. -{- Copyright (c) 2003-2004, Isaac Jones-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. -}- module Distribution.Simple.Register (     register,     unregister,@@ -69,38 +39,40 @@ import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)          , ComponentName(..), getComponentLocalBuildInfo-         , LibraryName(..)          , InstallDirs(..), absoluteInstallDirs ) import Distribution.Simple.BuildPaths (haddockName)-import qualified Distribution.Simple.GHC  as GHC-import qualified Distribution.Simple.LHC  as LHC-import qualified Distribution.Simple.Hugs as Hugs-import qualified Distribution.Simple.UHC  as UHC++import qualified Distribution.Simple.GHC   as GHC+import qualified Distribution.Simple.GHCJS as GHCJS+import qualified Distribution.Simple.LHC   as LHC+import qualified Distribution.Simple.UHC   as UHC import qualified Distribution.Simple.HaskellSuite as HaskellSuite+ import Distribution.Simple.Compiler          ( compilerVersion, Compiler, CompilerFlavor(..), compilerFlavor-         , PackageDBStack, registrationPackageDB )+         , PackageDB, PackageDBStack, absolutePackageDBPaths+         , registrationPackageDB ) import Distribution.Simple.Program-         ( ProgramConfiguration, ConfiguredProgram-         , runProgramInvocation, requireProgram, lookupProgram-         , ghcPkgProgram, lhcPkgProgram )+         ( ProgramConfiguration, runProgramInvocation ) import Distribution.Simple.Program.Script          ( invocationAsSystemScript )+import           Distribution.Simple.Program.HcPkg (HcPkgInfo) import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Setup          ( RegisterFlags(..), CopyDest(..)          , fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.PackageDescription-         ( PackageDescription(..), Library(..), BuildInfo(..), hcOptions )+         ( PackageDescription(..), Library(..), BuildInfo(..), libModules ) import Distribution.Package-         ( Package(..), packageName, InstalledPackageId(..) )+         ( Package(..), packageName, InstalledPackageId(..)+         , getHSLibraryName ) import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo, InstalledPackageInfo_(InstalledPackageInfo)+         ( InstalledPackageInfo, InstalledPackageInfo(InstalledPackageInfo)          , showInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Simple.Utils          ( writeUTF8File, writeFileAtomic, setFileExecutable-         , die, notice, setupMessage )+         , die, notice, setupMessage, shortRelativePath ) import Distribution.System          ( OS(..), buildOS ) import Distribution.Text@@ -108,13 +80,12 @@ import Distribution.Version ( Version(..) ) import Distribution.Verbosity as Verbosity          ( Verbosity, normal )-import Distribution.Compat.Exception-         ( tryIO )  import System.FilePath ((</>), (<.>), isAbsolute) import System.Directory-         ( getCurrentDirectory, removeDirectoryRecursive )+         ( getCurrentDirectory ) +import Control.Monad (when) import Data.Maybe          ( isJust, fromMaybe, maybeToList ) import Data.List@@ -130,9 +101,15 @@ register pkg@PackageDescription { library       = Just lib  } lbi regFlags   = do     let clbi = getComponentLocalBuildInfo lbi CLibName++    absPackageDBs    <- absolutePackageDBPaths packageDbs     installedPkgInfo <- generateRegistrationInfo-                           verbosity pkg lib lbi clbi inplace distPref+                           verbosity pkg lib lbi clbi inplace reloc distPref+                           (registrationPackageDB absPackageDBs) +    when (fromFlag (regPrintId regFlags)) $ do+      putStrLn (display (IPI.installedPackageId installedPkgInfo))+      -- Three different modes:     case () of      _ | modeGenerateRegFile   -> writeRegistrationFile installedPkgInfo@@ -148,6 +125,7 @@     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.@@ -162,15 +140,12 @@      writeRegisterScript installedPkgInfo =       case compilerFlavor (compiler lbi) of-        GHC  -> do (ghcPkg, _) <- requireProgram verbosity ghcPkgProgram (withPrograms lbi)-                   writeHcPkgRegisterScript verbosity installedPkgInfo ghcPkg packageDbs-        LHC  -> do (lhcPkg, _) <- requireProgram verbosity lhcPkgProgram (withPrograms lbi)-                   writeHcPkgRegisterScript verbosity installedPkgInfo lhcPkg packageDbs-        Hugs -> notice verbosity "Registration scripts not needed for hugs"-        JHC  -> notice verbosity "Registration scripts not needed for jhc"-        NHC  -> notice verbosity "Registration scripts not needed for nhc98"-        UHC  -> notice verbosity "Registration scripts not needed for uhc"-        _    -> die "Registration scripts are not implemented for this compiler"+        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)  register _ _ regFlags = notice verbosity "No package to register"   where@@ -183,9 +158,11 @@                          -> LocalBuildInfo                          -> ComponentLocalBuildInfo                          -> Bool+                         -> Bool                          -> FilePath+                         -> PackageDB                          -> IO InstalledPackageInfo-generateRegistrationInfo verbosity pkg lib lbi clbi inplace distPref = do+generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packageDb = do   --TODO: eliminate pwd!   pwd <- getCurrentDirectory @@ -197,38 +174,69 @@      GHC | compilerVersion comp >= Version [6,11] [] -> do             s <- GHC.libAbiHash verbosity pkg lbi lib clbi             return (InstalledPackageId (display (packageId pkg) ++ '-':s))+     GHCJS -> do+            s <- GHCJS.libAbiHash verbosity pkg lbi lib clbi+            return (InstalledPackageId (display (packageId pkg) ++ '-':s))      _other -> do             return (InstalledPackageId (display (packageId pkg))) -  let installedPkgInfo-        | inplace   = inplaceInstalledPackageInfo pwd distPref-                        pkg lib lbi clbi-        | otherwise = absoluteInstalledPackageInfo-                        pkg lib lbi clbi+  installedPkgInfo <-+    if inplace+      then return (inplaceInstalledPackageInfo pwd distPref+                     pkg ipid lib lbi clbi)+    else if reloc+      then relocRegistrationInfo verbosity+                     pkg lib lbi clbi ipid packageDb+      else return (absoluteInstalledPackageInfo+                     pkg ipid lib lbi clbi) +   return installedPkgInfo{ IPI.installedPackageId = ipid } +relocRegistrationInfo :: Verbosity+                      -> PackageDescription+                      -> Library+                      -> LocalBuildInfo+                      -> ComponentLocalBuildInfo+                      -> InstalledPackageId+                      -> PackageDB+                      -> IO InstalledPackageInfo+relocRegistrationInfo verbosity pkg lib lbi clbi ipid packageDb =+  case (compilerFlavor (compiler lbi)) of+    GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb+              return (relocatableInstalledPackageInfo+                        pkg ipid lib lbi clbi fs)+    _   -> die "Distribution.Simple.Register.relocRegistrationInfo: \+               \not implemented for this compiler"  -- | Create an empty package DB at the specified location. initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath                  -> IO () initPackageDB verbosity comp conf dbPath =-  case (compilerFlavor comp) of-    GHC -> GHC.initPackageDB verbosity conf dbPath+  case compilerFlavor comp of     HaskellSuite {} -> HaskellSuite.initPackageDB verbosity conf dbPath-    _   -> die "Distribution.Simple.Register.initPackageDB: \-               \not implemented for this compiler"+    _               -> withHcPkg "Distribution.Simple.Register.initPackageDB: \+                                 \not implemented for this compiler" comp conf+                                 (\hpi -> HcPkg.init hpi verbosity dbPath)  -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. invokeHcPkg :: Verbosity -> Compiler -> ProgramConfiguration -> PackageDBStack                 -> [String] -> IO () invokeHcPkg verbosity comp conf dbStack extraArgs =-    case (compilerFlavor comp) of-      GHC -> GHC.invokeHcPkg verbosity conf dbStack extraArgs-      _   -> die "Distribution.Simple.Register.invokeHcPkg: \-                 \not implemented for this compiler"+  withHcPkg "invokeHcPkg" comp conf+    (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs) +withHcPkg :: String -> Compiler -> ProgramConfiguration+          -> (HcPkgInfo -> IO a) -> IO a+withHcPkg name comp conf f =+  case compilerFlavor comp of+    GHC   -> f (GHC.hcPkgInfo conf)+    GHCJS -> f (GHCJS.hcPkgInfo conf)+    LHC   -> f (LHC.hcPkgInfo conf)+    _     -> die ("Distribution.Simple.Register." ++ name ++ ":\+                  \not implemented for this compiler")+ registerPackage :: Verbosity                 -> InstalledPackageInfo                 -> PackageDescription@@ -242,26 +250,24 @@             else "Registering"   setupMessage verbosity msg (packageId pkg)   case compilerFlavor (compiler lbi) of-    GHC  -> GHC.registerPackage  verbosity installedPkgInfo pkg lbi inplace packageDbs-    LHC  -> LHC.registerPackage  verbosity installedPkgInfo pkg lbi inplace packageDbs-    Hugs -> Hugs.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs-    UHC  -> UHC.registerPackage  verbosity installedPkgInfo pkg lbi inplace packageDbs-    JHC  -> notice verbosity "Registering for jhc (nothing to do)"-    NHC  -> notice verbosity "Registering for nhc98 (nothing to do)"+    GHC   -> GHC.registerPackage   verbosity installedPkgInfo pkg lbi inplace packageDbs+    GHCJS -> GHCJS.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs+    LHC   -> LHC.registerPackage   verbosity installedPkgInfo pkg lbi inplace packageDbs+    UHC   -> UHC.registerPackage   verbosity installedPkgInfo pkg lbi inplace packageDbs+    JHC   -> notice verbosity "Registering for jhc (nothing to do)"     HaskellSuite {} ->       HaskellSuite.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs     _    -> die "Registering is not implemented for this compiler" - writeHcPkgRegisterScript :: Verbosity                          -> InstalledPackageInfo-                         -> ConfiguredProgram                          -> PackageDBStack+                         -> HcPkgInfo                          -> IO ()-writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDbs = do-  let invocation  = HcPkg.reregisterInvocation hcPkg Verbosity.normal+writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs hpi = do+  let invocation  = HcPkg.reregisterInvocation hpi Verbosity.normal                       packageDbs (Right installedPkgInfo)-      regScript   = invocationAsSystemScript buildOS   invocation+      regScript   = invocationAsSystemScript buildOS invocation    notice verbosity ("Creating package registration script: " ++ regScriptFileName)   writeUTF8File regScriptFileName regScript@@ -283,15 +289,17 @@   :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to                                 -- absolute paths.   -> PackageDescription+  -> InstalledPackageId   -> Library+  -> LocalBuildInfo   -> ComponentLocalBuildInfo   -> InstallDirs FilePath   -> InstalledPackageInfo-generalInstalledPackageInfo adjustRelIncDirs pkg lib clbi installDirs =+generalInstalledPackageInfo adjustRelIncDirs pkg ipid lib lbi clbi installDirs =   InstalledPackageInfo {-    --TODO: do not open-code this conversion from PackageId to InstalledPackageId-    IPI.installedPackageId = InstalledPackageId (display (packageId pkg)),+    IPI.installedPackageId = ipid,     IPI.sourcePackageId    = packageId   pkg,+    IPI.packageKey         = componentPackageKey clbi,     IPI.license            = license     pkg,     IPI.copyright          = copyright   pkg,     IPI.maintainer         = maintainer  pkg,@@ -303,22 +311,27 @@     IPI.description        = description pkg,     IPI.category           = category    pkg,     IPI.exposed            = libExposed  lib,-    IPI.exposedModules     = exposedModules lib,+    IPI.exposedModules     = map fixupSelf (componentExposedModules clbi),     IPI.hiddenModules      = otherModules bi,+    IPI.instantiatedWith   = map (\(k,(p,n)) ->+                                   (k,IPI.OriginalModule (IPI.installedPackageId p) n))+                                 (instantiatedWith lbi),     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.hsLibraries        = [ libname-                             | LibraryName libname <- componentLibraries clbi-                             , hasLibrary ],+    IPI.dataDir            = datadir installDirs,+    IPI.hsLibraries        = if hasLibrary+                               then [getHSLibraryName (componentLibraryName clbi)]+                               else [],     IPI.extraLibraries     = extraLibs bi,-    IPI.extraGHCiLibraries = [],+    IPI.extraGHCiLibraries = extraGHCiLibs bi,     IPI.includeDirs        = absinc ++ adjustRelIncDirs relinc,     IPI.includes           = includes bi,     IPI.depends            = map fst (componentPackageDeps clbi),-    IPI.hugsOptions        = hcOptions Hugs bi,     IPI.ccOptions          = [], -- Note. NOT ccOptions bi!                                  -- We don't want cc-options to be propagated                                  -- to C compilations in other packages.@@ -326,38 +339,51 @@     IPI.frameworkDirs      = [],     IPI.frameworks         = frameworks bi,     IPI.haddockInterfaces  = [haddockdir installDirs </> haddockName pkg],-    IPI.haddockHTMLs       = [htmldir installDirs]+    IPI.haddockHTMLs       = [htmldir installDirs],+    IPI.pkgRoot            = Nothing   }   where     bi = libBuildInfo lib     (absinc, relinc) = partition isAbsolute (includeDirs bi)-    hasModules = not $ null (exposedModules lib)-                    && null (otherModules bi)+    hasModules = not $ null (libModules lib)     hasLibrary = hasModules || not (null (cSources bi))+                            || (not (null (jsSources bi)) &&+                                compilerFlavor (compiler lbi) == GHCJS) +    -- Since we currently don't decide the InstalledPackageId of our package+    -- until just before we register, we didn't have one for the re-exports+    -- of modules defined within this package, so we used an empty one that+    -- we fill in here now that we know what it is. It's a bit of a hack,+    -- we ought really to decide the InstalledPackageId ahead of time.+    fixupSelf (IPI.ExposedModule n o o') =+        IPI.ExposedModule n (fmap fixupOriginalModule o)+                            (fmap fixupOriginalModule o')+    fixupOriginalModule (IPI.OriginalModule i m) = IPI.OriginalModule (fixupIpid i) m+    fixupIpid (InstalledPackageId []) = ipid+    fixupIpid x = x --- | Construct 'InstalledPackageInfo' for a library that is inplace in the+-- | Construct 'InstalledPackageInfo' for a library that is in place in the -- build tree. ----- This function knows about the layout of inplace packages.+-- This function knows about the layout of in place packages. -- inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree                             -> FilePath -- ^ location of the dist tree                             -> PackageDescription+                            -> InstalledPackageId                             -> Library                             -> LocalBuildInfo                             -> ComponentLocalBuildInfo                             -> InstalledPackageInfo-inplaceInstalledPackageInfo inplaceDir distPref pkg lib lbi clbi =-    generalInstalledPackageInfo adjustRelativeIncludeDirs pkg lib clbi-    installDirs+inplaceInstalledPackageInfo inplaceDir distPref pkg ipid lib lbi clbi =+    generalInstalledPackageInfo adjustRelativeIncludeDirs+                                pkg ipid lib lbi clbi installDirs   where     adjustRelativeIncludeDirs = map (inplaceDir </>)     installDirs =       (absoluteInstallDirs pkg lbi NoCopyDest) {         libdir     = inplaceDir </> buildDir lbi,-        datadir    = inplaceDir,-        datasubdir = distPref,+        datadir    = inplaceDir </> dataDir pkg,         docdir     = inplaceDocdir,         htmldir    = inplaceHtmldir,         haddockdir = inplaceHtmldir@@ -372,12 +398,14 @@ -- This function knows about the layout of installed packages. -- absoluteInstalledPackageInfo :: PackageDescription+                             -> InstalledPackageId                              -> Library                              -> LocalBuildInfo                              -> ComponentLocalBuildInfo                              -> InstalledPackageInfo-absoluteInstalledPackageInfo pkg lib lbi clbi =-    generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib clbi installDirs+absoluteInstalledPackageInfo pkg ipid lib lbi clbi =+    generalInstalledPackageInfo adjustReativeIncludeDirs+                                pkg ipid lib lbi clbi installDirs   where     -- For installed packages we install all include files into one dir,     -- whereas in the build tree they may live in multiple local dirs.@@ -387,6 +415,28 @@     bi = libBuildInfo lib     installDirs = absoluteInstallDirs pkg lbi NoCopyDest ++relocatableInstalledPackageInfo :: PackageDescription+                                -> InstalledPackageId+                                -> Library+                                -> LocalBuildInfo+                                -> ComponentLocalBuildInfo+                                -> FilePath+                                -> InstalledPackageInfo+relocatableInstalledPackageInfo pkg ipid lib lbi clbi pkgroot =+    generalInstalledPackageInfo adjustReativeIncludeDirs+                                pkg ipid lib lbi clbi installDirs+  where+    -- For installed packages we install all include files into one dir,+    -- whereas in the build tree they may live in multiple local dirs.+    adjustReativeIncludeDirs _+      | null (installIncludes bi) = []+      | otherwise                 = [includedir installDirs]+    bi = libBuildInfo lib++    installDirs = fmap (("${pkgroot}" </>) . shortRelativePath pkgroot)+                $ absoluteInstallDirs pkg lbi NoCopyDest+ -- ----------------------------------------------------------------------------- -- Unregistration @@ -397,25 +447,16 @@       verbosity = fromFlag (regVerbosity regFlags)       packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi))                                     (regPackageDB regFlags)-      installDirs = absoluteInstallDirs pkg lbi NoCopyDest+      unreg hpi =+        let invocation = HcPkg.unregisterInvocation+                           hpi Verbosity.normal packageDb pkgid+        in if genScript+             then writeFileAtomic unregScriptFileName+                    (BS.Char8.pack $ invocationAsSystemScript buildOS invocation)+             else runProgramInvocation verbosity invocation   setupMessage verbosity "Unregistering" pkgid-  case compilerFlavor (compiler lbi) of-    GHC ->-      let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)-          invocation = HcPkg.unregisterInvocation ghcPkg Verbosity.normal-                         packageDb pkgid-      in if genScript-           then writeFileAtomic unregScriptFileName-                  (BS.Char8.pack $ invocationAsSystemScript buildOS invocation)-            else runProgramInvocation verbosity invocation-    Hugs -> do-        _ <- tryIO $ removeDirectoryRecursive (libdir installDirs)-        return ()-    NHC -> do-        _ <- tryIO $ removeDirectoryRecursive (libdir installDirs)-        return ()-    _ ->-        die ("only unregistering with GHC and Hugs is implemented")+  withHcPkg "unregistering is only implemented for GHC and GHCJS"+    (compiler lbi) (withPrograms lbi) unreg  unregScriptFileName :: FilePath unregScriptFileName = case buildOS of

cabal/Cabal/Distribution/Simple/Setup.hs view

@@ -1,8 +1,12 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Setup -- Copyright   :  Isaac Jones 2003-2004 --                Duncan Coutts 2007+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -26,36 +30,6 @@ -- read and written from files. This would allow us to save configure flags in -- config files. -{- 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. -}- {-# LANGUAGE CPP #-}  module Distribution.Simple.Setup (@@ -80,10 +54,10 @@   defaultBenchmarkFlags, benchmarkCommand,   CopyDest(..),   configureArgs, configureOptions, configureCCompiler, configureLinker,-  buildOptions, installDirsOptions,+  buildOptions, haddockOptions, installDirsOptions,   programConfigurationOptions, programConfigurationPaths', -  defaultDistPref,+  defaultDistPref, optionDistPref,    Flag(..),   toFlag,@@ -99,6 +73,7 @@          ( Text(..), display ) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp+import Distribution.ModuleName import Distribution.Package ( Dependency(..)                             , PackageName                             , InstalledPackageId )@@ -108,10 +83,12 @@ import qualified Distribution.Simple.Command as Command import Distribution.Simple.Compiler          ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..)+         , DebugInfoLevel(..), flagToDebugInfoLevel          , OptimisationLevel(..), flagToOptimisationLevel+         , ProfDetailLevel(..), flagToProfDetailLevel          , absolutePackageDBPath ) import Distribution.Simple.Utils-         ( wrapLine, lowercase, intercalate )+         ( wrapText, wrapLine, lowercase, intercalate ) import Distribution.Simple.Program (Program(..), ProgramConfiguration,                              requireProgram,                              programInvocation, progInvokePath, progInvokeArgs,@@ -122,11 +99,16 @@          ( InstallDirs(..), CopyDest(..),            PathTemplate, toPathTemplate, fromPathTemplate ) import Distribution.Verbosity+import Distribution.Utils.NubList  import Control.Monad (liftM)+import Distribution.Compat.Binary (Binary) import Data.List   ( sort ) import Data.Char   ( isSpace, isAlpha )+#if __GLASGOW_HASKELL__ < 710 import Data.Monoid ( Monoid(..) )+#endif+import GHC.Generics (Generic)  -- FIXME Not sure where this should live defaultDistPref :: FilePath@@ -153,8 +135,10 @@ -- Its monoid instance gives us the behaviour where it starts out as -- 'NoFlag' and later flags override earlier ones. ---data Flag a = Flag a | NoFlag deriving (Show, Read, Eq)+data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read) +instance Binary a => Binary (Flag a)+ instance Functor Flag where   fmap f (Flag x) = Flag (f x)   fmap _ NoFlag  = NoFlag@@ -200,7 +184,9 @@ flagToList NoFlag   = []  allFlags :: [Flag Bool] -> Flag Bool-allFlags flags = toFlag $ all (\f -> fromFlagOrDefault False f) flags+allFlags flags = if all (\f -> fromFlagOrDefault False f) flags+                 then Flag True+                 else NoFlag  -- ------------------------------------------------------------ -- * Global flags@@ -224,21 +210,34 @@     globalNumericVersion = Flag False   } -globalCommand :: CommandUI GlobalFlags-globalCommand = CommandUI {-    commandName         = "",-    commandSynopsis     = "",-    commandUsage        = \_ ->+globalCommand :: [Command action] -> CommandUI GlobalFlags+globalCommand commands = CommandUI+  { commandName         = ""+  , commandSynopsis     = ""+  , commandUsage        = \pname ->          "This Setup program uses the Haskell Cabal Infrastructure.\n"-      ++ "See http://www.haskell.org/cabal/ for more information.\n",-    commandDescription  = Just $ \pname ->-         "For more information about a command use\n"+      ++ "See http://www.haskell.org/cabal/ for more information.\n"+      ++ "\n"+      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n"+  , 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 ++ "    " ++ description+                 | (name, description) <- cmdDescs ]+      ++ "\n"+      ++ "For more information about a command use\n"       ++ "  " ++ pname ++ " COMMAND --help\n\n"       ++ "Typical steps for installing Cabal packages:\n"       ++ concat [ "  " ++ pname ++ " " ++ x ++ "\n"-                | x <- ["configure", "build", "install"]],-    commandDefaultFlags = defaultGlobalFlags,-    commandOptions      = \_ ->+                | x <- ["configure", "build", "install"]]+  , commandNotes        = Nothing+  , commandDefaultFlags = defaultGlobalFlags+  , commandOptions      = \_ ->       [option ['V'] ["version"]          "Print version information"          globalVersion (\v flags -> flags { globalVersion = v })@@ -268,7 +267,10 @@ -- * Config flags -- ------------------------------------------------------------ --- | Flags to @configure@ command+-- | Flags to @configure@ command.+--+-- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags'+-- should be updated. data ConfigFlags = ConfigFlags {     --FIXME: the configPrograms is only here to pass info through to configure     -- because the type of configure is constrained by the UserHooks.@@ -277,12 +279,12 @@     configPrograms      :: ProgramConfiguration, -- ^All programs that cabal may                                                  -- run -    configProgramPaths  :: [(String, FilePath)], -- ^user specifed programs paths-    configProgramArgs   :: [(String, [String])], -- ^user specifed programs args-    configProgramPathExtra :: [FilePath],        -- ^Extend the $PATH+    configProgramPaths  :: [(String, FilePath)], -- ^user specified programs paths+    configProgramArgs   :: [(String, [String])], -- ^user specified programs args+    configProgramPathExtra :: NubList FilePath,  -- ^Extend the $PATH     configHcFlavor      :: Flag CompilerFlavor, -- ^The \"flavor\" of the-                                                -- compiler, sugh as GHC or-                                                -- Hugs.+                                                -- compiler, such as GHC or+                                                -- JHC.     configHcPath        :: Flag FilePath, -- ^given compiler location     configHcPkg         :: Flag FilePath, -- ^given hc-pkg location     configVanillaLib    :: Flag Bool,     -- ^Enable vanilla library@@ -292,6 +294,12 @@                                           -- executables.     configProfExe       :: Flag Bool,     -- ^Enable profiling in the                                           -- executables.+    configProf          :: Flag Bool,     -- ^Enable profiling in the library+                                          -- and executables.+    configProfDetail    :: Flag ProfDetailLevel, -- ^Profiling detail level+                                          --  in the library and executables.+    configProfLibDetail :: Flag ProfDetailLevel, -- ^Profiling  detail level+                                                 -- in the library     configConfigureArgs :: [String],      -- ^Extra arguments to @configure@     configOptimization  :: Flag OptimisationLevel,  -- ^Enable optimization.     configProgPrefix    :: Flag PathTemplate, -- ^Installed executable prefix.@@ -313,18 +321,25 @@     configConstraints :: [Dependency], -- ^Additional constraints for                                        -- dependencies.     configDependencies :: [(PackageName, InstalledPackageId)],+    configInstantiateWith :: [(ModuleName, (InstalledPackageId, ModuleName))],       -- ^The packages depended on.     configConfigurationsFlags :: FlagAssignment,     configTests               :: Flag Bool, -- ^Enable test suite compilation     configBenchmarks          :: Flag Bool, -- ^Enable benchmark compilation-    configLibCoverage         :: Flag Bool,-      -- ^Enable test suite program coverage.-    configExactConfiguration  :: Flag Bool+    configCoverage :: Flag Bool, -- ^Enable program coverage+    configLibCoverage :: Flag Bool, -- ^Enable program coverage (deprecated)+    configExactConfiguration  :: Flag Bool,       -- ^All direct dependencies and flags are provided on the command line by       -- the user via the '--dependency' and '--flags' options.+    configFlagError :: Flag String,+      -- ^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.   }-  deriving (Read,Show)+  deriving (Generic, Read, Show) +instance Binary ConfigFlags+ configAbsolutePaths :: ConfigFlags -> IO ConfigFlags configAbsolutePaths f =   (\v -> f { configPackageDBs = v })@@ -336,40 +351,53 @@     configPrograms     = progConf,     configHcFlavor     = maybe NoFlag Flag defaultCompilerFlavor,     configVanillaLib   = Flag True,-    configProfLib      = Flag False,+    configProfLib      = NoFlag,     configSharedLib    = NoFlag,     configDynExe       = Flag False,-    configProfExe      = Flag False,+    configProfExe      = NoFlag,+    configProf         = NoFlag,+    configProfDetail   = NoFlag,+    configProfLibDetail= NoFlag,     configOptimization = Flag NormalOptimisation,     configProgPrefix   = Flag (toPathTemplate ""),     configProgSuffix   = Flag (toPathTemplate ""),-    configDistPref     = Flag defaultDistPref,+    configDistPref     = NoFlag,     configVerbosity    = Flag normal,     configUserInstall  = Flag False,           --TODO: reverse this #if defined(mingw32_HOST_OS)     -- See #1589.     configGHCiLib      = Flag True, #else-    configGHCiLib      = Flag False,+    configGHCiLib      = NoFlag, #endif     configSplitObjs    = Flag False, -- takes longer, so turn off by default     configStripExes    = Flag True,     configStripLibs    = Flag True,     configTests        = Flag False,     configBenchmarks   = Flag False,-    configLibCoverage  = Flag False,-    configExactConfiguration = Flag False+    configCoverage     = Flag False,+    configLibCoverage  = NoFlag,+    configExactConfiguration = Flag False,+    configFlagError    = NoFlag,+    configRelocatable  = Flag False,+    configDebugInfo    = Flag NoDebugInfo   }  configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags-configureCommand progConf = makeCommand name shortDesc-                            longDesc defaultFlags options-  where-    name       = "configure"-    shortDesc  = "Prepare to build the package."-    longDesc   = Just (\_ -> programFlagsDescription progConf)-    defaultFlags = defaultConfigFlags progConf-    options showOrParseArgs =+configureCommand progConf = CommandUI+  { commandName         = "configure"+  , commandSynopsis     = "Prepare to build the package."+  , commandDescription  = Just $ \_ -> wrapText $+         "Configure how the package is built by setting "+      ++ "package (and other) flags.\n"+      ++ "\n"+      ++ "The configuration affects several other commands, "+      ++ "including build, test, bench, run, repl.\n"+  , commandNotes        = Just $ \_pname -> programFlagsDescription progConf+  , commandUsage        = \pname ->+      "Usage: " ++ pname ++ " configure [FLAGS]\n"+  , commandDefaultFlags = defaultConfigFlags progConf+  , commandOptions      = \showOrParseArgs ->          configureOptions showOrParseArgs       ++ programConfigurationPaths   progConf showOrParseArgs            configProgramPaths (\v fs -> fs { configProgramPaths = v })@@ -377,6 +405,7 @@            configProgramArgs (\v fs -> fs { configProgramArgs = v })       ++ programConfigurationOptions progConf showOrParseArgs            configProgramArgs (\v fs -> fs { configProgramArgs = v })+  }  configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] configureOptions showOrParseArgs =@@ -388,13 +417,11 @@        ,option [] ["compiler"] "compiler"          configHcFlavor (\v flags -> flags { configHcFlavor = v })-         (choiceOpt [ (Flag GHC, ("g", ["ghc"]), "compile with GHC")-                    , (Flag NHC, ([] , ["nhc98"]), "compile with NHC")-                    , (Flag JHC, ([] , ["jhc"]), "compile with JHC")-                    , (Flag LHC, ([] , ["lhc"]), "compile with LHC")-                    , (Flag Hugs,([] , ["hugs"]), "compile with Hugs")-                    , (Flag UHC, ([] , ["uhc"]), "compile with UHC")-+         (choiceOpt [ (Flag GHC,   ("g", ["ghc"]),   "compile with GHC")+                    , (Flag GHCJS, ([] , ["ghcjs"]), "compile with GHCJS")+                    , (Flag JHC,   ([] , ["jhc"]),   "compile with JHC")+                    , (Flag LHC,   ([] , ["lhc"]),   "compile with LHC")+                    , (Flag UHC,   ([] , ["uhc"]),   "compile with UHC")                     -- "haskell-suite" compiler id string will be replaced                     -- by a more specific one during the configure stage                     , (Flag (HaskellSuite "haskell-suite"), ([] , ["haskell-suite"]),@@ -411,13 +438,7 @@          (reqArgFlag "PATH")       ]    ++ map liftInstallDirs installDirsOptions-   ++ [option "b" ["scratchdir"]-         "directory to receive the built package (hugs-only)"-         configScratchDir (\v flags -> flags { configScratchDir = v })-         (reqArgFlag "DIR")-      --TODO: eliminate scratchdir flag--      ,option "" ["program-prefix"]+   ++ [option "" ["program-prefix"]           "prefix to be applied to installed executables"           configProgPrefix           (\v flags -> flags { configProgPrefix = v })@@ -448,11 +469,29 @@          configDynExe (\v flags -> flags { configDynExe = v })          (boolOpt [] []) +      ,option "" ["profiling"]+         "Executable and library profiling"+         configProf (\v flags -> flags { configProf = v })+         (boolOpt [] [])+       ,option "" ["executable-profiling"]-         "Executable profiling"+         "Executable profiling (DEPRECATED)"          configProfExe (\v flags -> flags { configProfExe = v })          (boolOpt [] []) +      ,option "" ["profiling-detail"]+         ("Profiling detail level for executable and library (default, " +++          "none, exported-functions, toplevel-functions,  all-functions).")+         configProfDetail (\v flags -> flags { configProfDetail = v })+         (reqArg' "level" (Flag . flagToProfDetailLevel)+                          showProfDetailLevelFlag)++      ,option "" ["library-profiling-detail"]+         "Profiling detail level for libraries only."+         configProfLibDetail (\v flags -> flags { configProfLibDetail = v })+         (reqArg' "level" (Flag . flagToProfDetailLevel)+                          showProfDetailLevelFlag)+       ,multiOption "optimization"          configOptimization (\v flags -> flags { configOptimization = v })          [optArg' "n" (Flag . flagToOptimisationLevel)@@ -468,6 +507,22 @@                 "Build without optimization"          ] +      ,multiOption "debug-info"+         configDebugInfo (\v flags -> flags { configDebugInfo = v })+         [optArg' "n" (Flag . flagToDebugInfoLevel)+                     (\f -> case f of+                              Flag NoDebugInfo      -> []+                              Flag MinimalDebugInfo -> [Just "1"]+                              Flag NormalDebugInfo  -> [Nothing]+                              Flag MaximalDebugInfo -> [Just "3"]+                              _                     -> [])+                 "" ["enable-debug-info"]+                 "Emit debug info (n is 0--3, default is 0)",+          noArg (Flag NoDebugInfo) []+                ["disable-debug-info"]+                "Don't emit debug info"+         ]+       ,option "" ["library-for-ghci"]          "compile library for use with GHCi"          configGHCiLib (\v flags -> flags { configGHCiLib = v })@@ -499,7 +554,12 @@          (boolOpt' ([],["user"]) ([], ["global"]))        ,option "" ["package-db"]-         "Use a given package database (to satisfy dependencies and register in). May be a specific file, 'global', 'user' or 'clear'."+         (   "Append the given package database to the list of package"+          ++ " databases used (to satisfy dependencies and register into)."+          ++ " May be a specific file, 'global' or 'user'. The initial list"+          ++ " is ['global'], ['global', 'user'], or ['global', $sandbox],"+          ++ " depending on context. Use 'clear' to reset the list to empty."+          ++ " See the user guide for details.")          configPackageDBs (\v flags -> flags { configPackageDBs = v })          (reqArg' "DB" readPackageDbList showPackageDbList) @@ -521,7 +581,7 @@       ,option "" ["extra-prog-path"]          "A list of directories to search for required programs (in addition to the normal search locations)"          configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v})-         (reqArg' "PATH" (\x -> [x]) id)+         (reqArg' "PATH" (\x -> toNubList [x]) fromNubList)        ,option "" ["constraint"]          "A list of additional constraints on the dependencies."@@ -537,13 +597,25 @@                  (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. E.g., --instantiate-with=\"Map=Data.Map.Strict@containers-0.5.5.1-inplace\""+         configInstantiateWith (\v flags -> flags { configInstantiateWith = v })+         (reqArg "NAME=PKG:MOD"+                 (readP_to_E (const "signature mapping expected") ((\x -> [x]) `fmap` parseHoleMapEntry))+                 (map (\(n,(p,m)) -> display n ++ "=" ++ display m ++ "@" ++ display p)))+       ,option "" ["tests"]          "dependency checking and compilation for test suites listed in the package description file."          configTests (\v flags -> flags { configTests = v })          (boolOpt [] []) +      ,option "" ["coverage"]+         "build package with Haskell Program Coverage. (GHC only)"+         configCoverage (\v flags -> flags { configCoverage = v })+         (boolOpt [] [])+       ,option "" ["library-coverage"]-         "build library and test suites with Haskell Program Coverage enabled. (GHC only)"+         "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)"          configLibCoverage (\v flags -> flags { configLibCoverage = v })          (boolOpt [] []) @@ -557,6 +629,11 @@          "dependency checking and compilation for benchmarks listed in the package description file."          configBenchmarks (\v flags -> flags { configBenchmarks = v })          (boolOpt [] [])++      ,option "" ["relocatable"]+         "building a package that is relocatable. (GHC only)"+         configRelocatable (\v flags -> flags { configRelocatable = v})+         (boolOpt [] [])       ]   where     readFlagList :: String -> FlagAssignment@@ -589,7 +666,18 @@     showPackageDb (Just UserPackageDB)          = "user"     showPackageDb (Just (SpecificPackageDB db)) = db +showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String]+showProfDetailLevelFlag dl =+  case dl of+    NoFlag                           -> []+    Flag ProfDetailNone              -> ["none"]+    Flag ProfDetailDefault           -> ["default"]+    Flag ProfDetailExportedFunctions -> ["exported-functions"]+    Flag ProfDetailToplevelFunctions -> ["toplevel-functions"]+    Flag ProfDetailAllFunctions      -> ["all-functions"]+    Flag (ProfDetailOther other)     -> [other] + parseDependency :: Parse.ReadP r (PackageName, InstalledPackageId) parseDependency = do   x <- parse@@ -597,6 +685,15 @@   y <- parse   return (x, y) +parseHoleMapEntry :: Parse.ReadP r (ModuleName, (InstalledPackageId, ModuleName))+parseHoleMapEntry = do+  x <- parse+  _ <- Parse.char '='+  y <- parse+  _ <- Parse.char '@'+  z <- parse+  return (x, (z, y))+ installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] installDirsOptions =   [ option "" ["prefix"]@@ -676,6 +773,9 @@     configSharedLib     = mempty,     configDynExe        = mempty,     configProfExe       = mempty,+    configProf          = mempty,+    configProfDetail    = mempty,+    configProfLibDetail = mempty,     configConfigureArgs = mempty,     configOptimization  = mempty,     configProgPrefix    = mempty,@@ -693,12 +793,17 @@     configExtraLibDirs  = mempty,     configConstraints   = mempty,     configDependencies  = mempty,+    configInstantiateWith     = mempty,     configExtraIncludeDirs    = mempty,     configConfigurationsFlags = mempty,     configTests               = mempty,-    configLibCoverage         = mempty,+    configCoverage         = mempty,+    configLibCoverage   = mempty,     configExactConfiguration  = mempty,-    configBenchmarks          = mempty+    configBenchmarks          = mempty,+    configFlagError     = mempty,+    configRelocatable   = mempty,+    configDebugInfo     = mempty   }   mappend a b =  ConfigFlags {     configPrograms      = configPrograms b,@@ -713,6 +818,9 @@     configSharedLib     = combine configSharedLib,     configDynExe        = combine configDynExe,     configProfExe       = combine configProfExe,+    configProf          = combine configProf,+    configProfDetail    = combine configProfDetail,+    configProfLibDetail = combine configProfLibDetail,     configConfigureArgs = combine configConfigureArgs,     configOptimization  = combine configOptimization,     configProgPrefix    = combine configProgPrefix,@@ -730,12 +838,17 @@     configExtraLibDirs  = combine configExtraLibDirs,     configConstraints   = combine configConstraints,     configDependencies  = combine configDependencies,+    configInstantiateWith     = combine configInstantiateWith,     configExtraIncludeDirs    = combine configExtraIncludeDirs,     configConfigurationsFlags = combine configConfigurationsFlags,     configTests               = combine configTests,+    configCoverage         = combine configCoverage,     configLibCoverage         = combine configLibCoverage,     configExactConfiguration  = combine configExactConfiguration,-    configBenchmarks          = combine configBenchmarks+    configBenchmarks          = combine configBenchmarks,+    configFlagError     = combine configFlagError,+    configRelocatable   = combine configRelocatable,+    configDebugInfo     = combine configDebugInfo   }     where combine field = field a `mappend` field b @@ -754,19 +867,22 @@ defaultCopyFlags :: CopyFlags defaultCopyFlags  = CopyFlags {     copyDest      = Flag NoCopyDest,-    copyDistPref  = Flag defaultDistPref,+    copyDistPref  = NoFlag,     copyVerbosity = Flag normal   }  copyCommand :: CommandUI CopyFlags-copyCommand = makeCommand name shortDesc longDesc defaultCopyFlags options-  where-    name       = "copy"-    shortDesc  = "Copy the files into the install locations."-    longDesc   = Just $ \_ ->-          "Does not call register, and allows a prefix at install time\n"+copyCommand = CommandUI+  { commandName         = "copy"+  , commandSynopsis     = "Copy the files into the install locations."+  , commandDescription  = Just $ \_ -> wrapText $+          "Does not call register, and allows a prefix at install time. "        ++ "Without the --destdir flag, configure determines location.\n"-    options showOrParseArgs =+  , commandNotes        = Nothing+  , commandUsage        = \pname ->+      "Usage: " ++ pname ++ " copy [FLAGS]\n"+  , commandDefaultFlags = defaultCopyFlags+  , commandOptions      = \showOrParseArgs ->       [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v })        ,optionDistPref@@ -779,6 +895,7 @@          (reqArg "DIR" (succeedReadE (Flag . CopyTo))                        (\f -> case f of Flag (CopyTo p) -> [p]; _ -> []))       ]+  }  emptyCopyFlags :: CopyFlags emptyCopyFlags = mempty@@ -813,22 +930,26 @@ defaultInstallFlags :: InstallFlags defaultInstallFlags  = InstallFlags {     installPackageDB = NoFlag,-    installDistPref  = Flag defaultDistPref,+    installDistPref  = NoFlag,     installUseWrapper = Flag False,     installInPlace    = Flag False,     installVerbosity = Flag normal   }  installCommand :: CommandUI InstallFlags-installCommand = makeCommand name shortDesc longDesc defaultInstallFlags options-  where-    name       = "install"-    shortDesc  = "Copy the files into the install locations. Run register."-    longDesc   = Just $ \_ ->-         "Unlike the copy command, install calls the register command.\n"-      ++ "If you want to install into a location that is not what was\n"+installCommand = CommandUI+  { commandName         = "install"+  , commandSynopsis     =+      "Copy the files into the install locations. Run register."+  , commandDescription  = Just $ \_ -> wrapText $+         "Unlike the copy command, install calls the register command."+      ++ "If you want to install into a location that is not what was"       ++ "specified in the configure step, use the copy command.\n"-    options showOrParseArgs =+  , commandNotes        = Nothing+  , commandUsage        = \pname ->+      "Usage: " ++ pname ++ " install [FLAGS]\n"+  , commandDefaultFlags = defaultInstallFlags+  , commandOptions      = \showOrParseArgs ->       [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v })       ,optionDistPref          installDistPref (\d flags -> flags { installDistPref = d })@@ -851,6 +972,7 @@                     , (Flag GlobalPackageDB, ([],["global"]),                       "(default) upon configuration register this package in the system-wide package database")])       ]+  }  emptyInstallFlags :: InstallFlags emptyInstallFlags = mempty@@ -890,24 +1012,28 @@ defaultSDistFlags = SDistFlags {     sDistSnapshot    = Flag False,     sDistDirectory   = mempty,-    sDistDistPref    = Flag defaultDistPref,+    sDistDistPref    = NoFlag,     sDistListSources = mempty,     sDistVerbosity   = Flag normal   }  sdistCommand :: CommandUI SDistFlags-sdistCommand = makeCommand name shortDesc longDesc defaultSDistFlags options-  where-    name       = "sdist"-    shortDesc  = "Generate a source distribution file (.tar.gz)."-    longDesc   = Nothing-    options showOrParseArgs =+sdistCommand = CommandUI+  { commandName         = "sdist"+  , commandSynopsis     =+      "Generate a source distribution file (.tar.gz)."+  , commandDescription  = Nothing+  , commandNotes        = Nothing+  , commandUsage        = \pname ->+      "Usage: " ++ pname ++ " sdist [FLAGS]\n"+  , commandDefaultFlags = defaultSDistFlags+  , commandOptions      = \showOrParseArgs ->       [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v })       ,optionDistPref          sDistDistPref (\d flags -> flags { sDistDistPref = d })          showOrParseArgs -     ,option "" ["list-sources"]+      ,option "" ["list-sources"]          "Just write a list of the package's sources to a file"          sDistListSources (\v flags -> flags { sDistListSources = v })          (reqArgFlag "FILE")@@ -923,6 +1049,7 @@          sDistDirectory (\v flags -> flags { sDistDirectory = v })          (reqArgFlag "DIR")       ]+  }  emptySDistFlags :: SDistFlags emptySDistFlags = mempty@@ -956,6 +1083,7 @@     regGenPkgConf  :: Flag (Maybe FilePath),     regInPlace     :: Flag Bool,     regDistPref    :: Flag FilePath,+    regPrintId     :: Flag Bool,     regVerbosity   :: Flag Verbosity   }   deriving Show@@ -966,18 +1094,22 @@     regGenScript   = Flag False,     regGenPkgConf  = NoFlag,     regInPlace     = Flag False,-    regDistPref    = Flag defaultDistPref,+    regDistPref    = NoFlag,+    regPrintId     = Flag False,     regVerbosity   = Flag normal   }  registerCommand :: CommandUI RegisterFlags-registerCommand = makeCommand name shortDesc longDesc-                  defaultRegisterFlags options-  where-    name       = "register"-    shortDesc  = "Register this package with the compiler."-    longDesc   = Nothing-    options showOrParseArgs =+registerCommand = CommandUI+  { commandName         = "register"+  , commandSynopsis     =+      "Register this package with the compiler."+  , commandDescription  = Nothing+  , commandNotes        = Nothing+  , commandUsage        = \pname ->+      "Usage: " ++ pname ++ " register [FLAGS]\n"+  , commandDefaultFlags = defaultRegisterFlags+  , commandOptions      = \showOrParseArgs ->       [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v })       ,optionDistPref          regDistPref (\d flags -> flags { regDistPref = d })@@ -1004,16 +1136,25 @@          "instead of registering, generate a package registration file"          regGenPkgConf (\v flags -> flags { regGenPkgConf  = v })          (optArg' "PKG" Flag flagToList)++      ,option "" ["print-ipid"]+         "print the installed package ID calculated for this package"+         regPrintId (\v flags -> flags { regPrintId = v })+         trueArg       ]+  }  unregisterCommand :: CommandUI RegisterFlags-unregisterCommand = makeCommand name shortDesc-                    longDesc defaultRegisterFlags options-  where-    name       = "unregister"-    shortDesc  = "Unregister this package with the compiler."-    longDesc   = Nothing-    options showOrParseArgs =+unregisterCommand = CommandUI+  { commandName         = "unregister"+  , commandSynopsis     =+      "Unregister this package with the compiler."+  , commandDescription  = Nothing+  , commandNotes        = Nothing+  , commandUsage        = \pname ->+      "Usage: " ++ pname ++ " unregister [FLAGS]\n"+  , commandDefaultFlags = defaultRegisterFlags+  , commandOptions      = \showOrParseArgs ->       [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v })       ,optionDistPref          regDistPref (\d flags -> flags { regDistPref = d })@@ -1031,6 +1172,7 @@          regGenScript (\v flags -> flags { regGenScript = v })          trueArg       ]+  }  emptyRegisterFlags :: RegisterFlags emptyRegisterFlags = mempty@@ -1041,6 +1183,7 @@     regGenScript   = mempty,     regGenPkgConf  = mempty,     regInPlace     = mempty,+    regPrintId     = mempty,     regDistPref    = mempty,     regVerbosity   = mempty   }@@ -1049,6 +1192,7 @@     regGenScript   = combine regGenScript,     regGenPkgConf  = combine regGenPkgConf,     regInPlace     = combine regInPlace,+    regPrintId     = combine regPrintId,     regDistPref    = combine regDistPref,     regVerbosity   = combine regVerbosity   }@@ -1077,7 +1221,7 @@     hscolourExecutables = Flag False,     hscolourTestSuites  = Flag False,     hscolourBenchmarks  = Flag False,-    hscolourDistPref    = Flag defaultDistPref,+    hscolourDistPref    = NoFlag,     hscolourVerbosity   = Flag normal   } @@ -1101,13 +1245,16 @@     where combine field = field a `mappend` field b  hscolourCommand :: CommandUI HscolourFlags-hscolourCommand = makeCommand name shortDesc longDesc-                  defaultHscolourFlags options-  where-    name       = "hscolour"-    shortDesc  = "Generate HsColour colourised code, in HTML format."-    longDesc   = Just (\_ -> "Requires hscolour.\n")-    options showOrParseArgs =+hscolourCommand = CommandUI+  { commandName         = "hscolour"+  , commandSynopsis     =+      "Generate HsColour colourised code, in HTML format."+  , commandDescription  = Just (\_ -> "Requires the hscolour program.\n")+  , commandNotes        = Nothing+  , commandUsage        = \pname ->+      "Usage: " ++ pname ++ " hscolour [FLAGS]\n"+  , commandDefaultFlags = defaultHscolourFlags+  , commandOptions      = \showOrParseArgs ->       [optionVerbosity hscolourVerbosity        (\v flags -> flags { hscolourVerbosity = v })       ,optionDistPref@@ -1144,6 +1291,7 @@          hscolourCSS (\v flags -> flags { hscolourCSS = v })          (reqArgFlag "PATH")       ]+  }  -- ------------------------------------------------------------ -- * Haddock flags@@ -1184,105 +1332,115 @@     haddockHscolour     = Flag False,     haddockHscolourCss  = NoFlag,     haddockContents     = NoFlag,-    haddockDistPref     = Flag defaultDistPref,+    haddockDistPref     = NoFlag,     haddockKeepTempFiles= Flag False,     haddockVerbosity    = Flag normal   }  haddockCommand :: CommandUI HaddockFlags-haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options+haddockCommand = CommandUI+  { commandName         = "haddock"+  , commandSynopsis     = "Generate Haddock HTML documentation."+  , commandDescription  = Just $ \_ ->+      "Requires the program haddock, version 2.x.\n"+  , commandNotes        = Nothing+  , commandUsage        = \pname ->+      "Usage: " ++ pname ++ " haddock [FLAGS]\n"+  , commandDefaultFlags = defaultHaddockFlags+  , commandOptions      = \showOrParseArgs ->+         haddockOptions showOrParseArgs+      ++ programConfigurationPaths   progConf ParseArgs+             haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v})+      ++ programConfigurationOption  progConf showOrParseArgs+             haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v })+      ++ programConfigurationOptions progConf ParseArgs+             haddockProgramArgs  (\v flags -> flags { haddockProgramArgs = v})+  }   where-    name       = "haddock"-    shortDesc  = "Generate Haddock HTML documentation."-    longDesc   = Just $ \_ -> "Requires the program haddock, either version 0.x or 2.x.\n"-    options showOrParseArgs =-      [optionVerbosity haddockVerbosity-       (\v flags -> flags { haddockVerbosity = v })-      ,optionDistPref-         haddockDistPref (\d flags -> flags { haddockDistPref = d })-         showOrParseArgs+    progConf = addKnownProgram haddockProgram+             $ addKnownProgram ghcProgram+             $ emptyProgramConfiguration -      ,option "" ["keep-temp-files"]-         "Keep temporary files"-         haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b })-         trueArg+haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags]+haddockOptions showOrParseArgs =+  [optionVerbosity haddockVerbosity+   (\v flags -> flags { haddockVerbosity = v })+  ,optionDistPref+   haddockDistPref (\d flags -> flags { haddockDistPref = d })+   showOrParseArgs -      ,option "" ["hoogle"]-         "Generate a hoogle database"-         haddockHoogle (\v flags -> flags { haddockHoogle = v })-         trueArg+  ,option "" ["keep-temp-files"]+   "Keep temporary files"+   haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b })+   trueArg -      ,option "" ["html"]-         "Generate HTML documentation (the default)"-         haddockHtml (\v flags -> flags { haddockHtml = v })-         trueArg+  ,option "" ["hoogle"]+   "Generate a hoogle database"+   haddockHoogle (\v flags -> flags { haddockHoogle = v })+   trueArg -      ,option "" ["html-location"]-         "Location of HTML documentation for pre-requisite packages"-         haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v })-         (reqArgFlag "URL")+  ,option "" ["html"]+   "Generate HTML documentation (the default)"+   haddockHtml (\v flags -> flags { haddockHtml = v })+   trueArg -      ,option "" ["executables"]-         "Run haddock for Executables targets"-         haddockExecutables (\v flags -> flags { haddockExecutables = v })-         trueArg+  ,option "" ["html-location"]+   "Location of HTML documentation for pre-requisite packages"+   haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v })+   (reqArgFlag "URL") -      ,option "" ["tests"]-         "Run haddock for Test Suite targets"-         haddockTestSuites (\v flags -> flags { haddockTestSuites = v })-         trueArg+  ,option "" ["executables"]+   "Run haddock for Executables targets"+   haddockExecutables (\v flags -> flags { haddockExecutables = v })+   trueArg -      ,option "" ["benchmarks"]-         "Run haddock for Benchmark targets"-         haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v })-         trueArg+  ,option "" ["tests"]+   "Run haddock for Test Suite targets"+   haddockTestSuites (\v flags -> flags { haddockTestSuites = v })+   trueArg -      ,option "" ["all"]-         "Run haddock for all targets"-         (\f -> allFlags [ haddockExecutables f-                         , haddockTestSuites  f-                         , haddockBenchmarks  f])+  ,option "" ["benchmarks"]+   "Run haddock for Benchmark targets"+   haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v })+   trueArg++  ,option "" ["all"]+   "Run haddock for all targets"+   (\f -> allFlags [ haddockExecutables f+                   , haddockTestSuites  f+                   , haddockBenchmarks  f])          (\v flags -> flags { haddockExecutables = v                             , haddockTestSuites  = v                             , haddockBenchmarks  = v })          trueArg -      ,option "" ["internal"]-         "Run haddock for internal modules and include all symbols"-         haddockInternal (\v flags -> flags { haddockInternal = v })-         trueArg+  ,option "" ["internal"]+   "Run haddock for internal modules and include all symbols"+   haddockInternal (\v flags -> flags { haddockInternal = v })+   trueArg -      ,option "" ["css"]-         "Use PATH as the haddock stylesheet"-         haddockCss (\v flags -> flags { haddockCss = v })-         (reqArgFlag "PATH")+  ,option "" ["css"]+   "Use PATH as the haddock stylesheet"+   haddockCss (\v flags -> flags { haddockCss = v })+   (reqArgFlag "PATH") -      ,option "" ["hyperlink-source","hyperlink-sources"]-         "Hyperlink the documentation to the source code (using HsColour)"-         haddockHscolour (\v flags -> flags { haddockHscolour = v })-         trueArg+  ,option "" ["hyperlink-source","hyperlink-sources"]+   "Hyperlink the documentation to the source code (using HsColour)"+   haddockHscolour (\v flags -> flags { haddockHscolour = v })+   trueArg -      ,option "" ["hscolour-css"]-         "Use PATH as the HsColour stylesheet"-         haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v })-         (reqArgFlag "PATH")+  ,option "" ["hscolour-css"]+   "Use PATH as the HsColour stylesheet"+   haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v })+   (reqArgFlag "PATH") -      ,option "" ["contents-location"]-         "Bake URL in as the location for the contents page"-         haddockContents (\v flags -> flags { haddockContents = v })-         (reqArg' "URL"-                (toFlag . toPathTemplate)-                (flagToList . fmap fromPathTemplate))-      ]-      ++ programConfigurationPaths   progConf ParseArgs-             haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v})-      ++ programConfigurationOption  progConf showOrParseArgs-             haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v })-      ++ programConfigurationOptions progConf ParseArgs-             haddockProgramArgs  (\v flags -> flags { haddockProgramArgs = v})-    progConf = addKnownProgram haddockProgram-             $ addKnownProgram ghcProgram-             $ emptyProgramConfiguration+  ,option "" ["contents-location"]+   "Bake URL in as the location for the contents page"+   haddockContents (\v flags -> flags { haddockContents = v })+   (reqArg' "URL"+    (toFlag . toPathTemplate)+    (flagToList . fmap fromPathTemplate))+  ]  emptyHaddockFlags :: HaddockFlags emptyHaddockFlags = mempty@@ -1310,7 +1468,7 @@     haddockProgramPaths = combine haddockProgramPaths,     haddockProgramArgs  = combine haddockProgramArgs,     haddockHoogle       = combine haddockHoogle,-    haddockHtml         = combine haddockHoogle,+    haddockHtml         = combine haddockHtml,     haddockHtmlLocation = combine haddockHtmlLocation,     haddockExecutables  = combine haddockExecutables,     haddockTestSuites   = combine haddockTestSuites,@@ -1340,17 +1498,21 @@ defaultCleanFlags :: CleanFlags defaultCleanFlags  = CleanFlags {     cleanSaveConf  = Flag False,-    cleanDistPref  = Flag defaultDistPref,+    cleanDistPref  = NoFlag,     cleanVerbosity = Flag normal   }  cleanCommand :: CommandUI CleanFlags-cleanCommand = makeCommand name shortDesc longDesc defaultCleanFlags options-  where-    name       = "clean"-    shortDesc  = "Clean up after a build."-    longDesc   = Just (\_ -> "Removes .hi, .o, preprocessed sources, etc.\n")-    options showOrParseArgs =+cleanCommand = CommandUI+  { commandName         = "clean"+  , commandSynopsis     = "Clean up after a build."+  , commandDescription  = Just $ \_ ->+      "Removes .hi, .o, preprocessed sources, etc.\n"+  , commandNotes        = Nothing+  , commandUsage        = \pname ->+      "Usage: " ++ pname ++ " clean [FLAGS]\n"+  , commandDefaultFlags = defaultCleanFlags+  , commandOptions      = \showOrParseArgs ->       [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v })       ,optionDistPref          cleanDistPref (\d flags -> flags { cleanDistPref = d })@@ -1361,6 +1523,7 @@          cleanSaveConf (\v flags -> flags { cleanSaveConf = v })          trueArg       ]+  }  emptyCleanFlags :: CleanFlags emptyCleanFlags = mempty@@ -1402,44 +1565,55 @@ defaultBuildFlags  = BuildFlags {     buildProgramPaths = mempty,     buildProgramArgs = [],-    buildDistPref    = Flag defaultDistPref,+    buildDistPref    = mempty,     buildVerbosity   = Flag normal,     buildNumJobs     = mempty,     buildArgs        = []   }  buildCommand :: ProgramConfiguration -> CommandUI BuildFlags-buildCommand progConf = makeCommand name shortDesc longDesc-                        defaultBuildFlags (buildOptions progConf)-  where-    name       = "build"-    shortDesc  = "Compile all targets or specific targets."-    longDesc   = Just $ \pname ->+buildCommand progConf = CommandUI+  { commandName         = "build"+  , commandSynopsis     = "Compile all/specific components."+  , commandDescription  = Just $ \_ -> wrapText $+         "Components encompass executables, tests, and benchmarks.\n"+      ++ "\n"+      ++ "Affected by configuration options, see `configure`.\n"+  , commandNotes        = Just $ \pname ->        "Examples:\n"         ++ "  " ++ pname ++ " build           "         ++ "    All the components in the package\n"         ++ "  " ++ pname ++ " build foo       "-        ++ "    A component (i.e. lib, exe, test suite)\n"+        ++ "    A component (i.e. lib, exe, test suite)\n\n"+        ++ programFlagsDescription progConf --TODO: re-enable once we have support for module/file targets --        ++ "  " ++ pname ++ " build Foo.Bar   " --        ++ "    A module\n" --        ++ "  " ++ pname ++ " build Foo/Bar.hs" --        ++ "    A file\n\n"---        ++ "If a target is ambigious it can be qualified with the component "+--        ++ "If a target is ambiguous it can be qualified with the component " --        ++ "name, e.g.\n" --        ++ "  " ++ pname ++ " build foo:Foo.Bar\n" --        ++ "  " ++ pname ++ " build testsuite1:Foo/Bar.hs\n"+  , commandUsage        = usageAlternatives "build" $+      [ "[FLAGS]"+      , "COMPONENTS [FLAGS]"+      ]+  , commandDefaultFlags = defaultBuildFlags+  , commandOptions      = \showOrParseArgs ->+      [ optionVerbosity+        buildVerbosity (\v flags -> flags { buildVerbosity = v }) +      , optionDistPref+        buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs+      ]+      ++ buildOptions progConf showOrParseArgs+  }+ buildOptions :: ProgramConfiguration -> ShowOrParseArgs                 -> [OptionField BuildFlags] buildOptions progConf showOrParseArgs =-  [ optionVerbosity-      buildVerbosity (\v flags -> flags { buildVerbosity = v })--  , optionDistPref-      buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs--  , optionNumJobs+  [ optionNumJobs       buildNumJobs (\v flags -> flags { buildNumJobs = v })   ] @@ -1475,7 +1649,7 @@     where combine field = field a `mappend` field b  -- --------------------------------------------------------------- * Repl Flags+-- * REPL Flags -- ------------------------------------------------------------  data ReplFlags = ReplFlags {@@ -1491,7 +1665,7 @@ defaultReplFlags  = ReplFlags {     replProgramPaths = mempty,     replProgramArgs = [],-    replDistPref    = Flag defaultDistPref,+    replDistPref    = NoFlag,     replVerbosity   = Flag normal,     replReload      = Flag False   }@@ -1514,28 +1688,49 @@     where combine field = field a `mappend` field b  replCommand :: ProgramConfiguration -> CommandUI ReplFlags-replCommand progConf = CommandUI {-    commandName         = "repl",-    commandSynopsis     = "Open an interpreter session for the given target.",-    commandDescription  = Just $ \pname ->-       "Examples:\n"-        ++ "  " ++ pname ++ " repl           "-        ++ "    The first component in the package\n"-        ++ "  " ++ pname ++ " repl foo       "-        ++ "    A named component (i.e. lib, exe, test suite)\n",+replCommand progConf = CommandUI+  { commandName         = "repl"+  , commandSynopsis     =+      "Open an interpreter session for the given component."+  , commandDescription  = Just $ \pname -> wrapText $+         "If the current directory contains no package, ignores COMPONENT "+      ++ "parameters and opens an interactive interpreter session; if a "+      ++ "sandbox is present, its package database will be used.\n"+      ++ "\n"+      ++ "Otherwise, (re)configures with the given or default flags, and "+      ++ "loads the interpreter with the relevant modules. For executables, "+      ++ "tests and benchmarks, loads the main module (and its "+      ++ "dependencies); for libraries all exposed/other modules.\n"+      ++ "\n"+      ++ "The default component is the library itself, or the executable "+      ++ "if that is the only component.\n"+      ++ "\n"+      ++ "Support for loading specific modules is planned but not "+      ++ "implemented yet. For certain scenarios, `" ++ pname+      ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will "+      ++ "not (re)configure and you will have to specify the location of "+      ++ "other modules, if required.\n"++  , commandNotes        = Just $ \pname ->+         "Examples:\n"+      ++ "  " ++ pname ++ " repl           "+      ++ "    The first component in the package\n"+      ++ "  " ++ pname ++ " repl foo       "+      ++ "    A named component (i.e. lib, exe, test suite)\n"+      ++ "  " ++ pname ++ " repl --ghc-options=\"-lstdc++\""+      ++ "  Specifying flags for interpreter\n" --TODO: re-enable once we have support for module/file targets --        ++ "  " ++ pname ++ " repl Foo.Bar   " --        ++ "    A module\n" --        ++ "  " ++ pname ++ " repl Foo/Bar.hs" --        ++ "    A file\n\n"---        ++ "If a target is ambigious it can be qualified with the component "+--        ++ "If a target is ambiguous it can be qualified with the component " --        ++ "name, e.g.\n" --        ++ "  " ++ pname ++ " repl foo:Foo.Bar\n" --        ++ "  " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n"--    commandUsage =  \pname -> "Usage: " ++ pname ++ " repl [FILENAME] [FLAGS]\n",-    commandDefaultFlags = defaultReplFlags,-    commandOptions = \showOrParseArgs ->+  , commandUsage =  \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n"+  , commandDefaultFlags = defaultReplFlags+  , commandOptions = \showOrParseArgs ->       optionVerbosity replVerbosity (\v flags -> flags { replVerbosity = v })       : optionDistPref           replDistPref (\d flags -> flags { replDistPref = d })@@ -1558,13 +1753,13 @@               trueArg             ]           _ -> []-    }+  }  -- ------------------------------------------------------------ -- * Test flags -- ------------------------------------------------------------ -data TestShowDetails = Never | Failures | Always+data TestShowDetails = Never | Failures | Always | Streaming     deriving (Eq, Ord, Enum, Bounded, Show)  knownTestShowDetails :: [TestShowDetails]@@ -1593,32 +1788,43 @@     testMachineLog  :: Flag PathTemplate,     testShowDetails :: Flag TestShowDetails,     testKeepTix     :: Flag Bool,-    --TODO: eliminate the test list and pass it directly as positional args to-    --the testHook-    testList        :: Flag [String],     -- TODO: think about if/how options are passed to test exes     testOptions     :: [PathTemplate]   }  defaultTestFlags :: TestFlags defaultTestFlags  = TestFlags {-    testDistPref    = Flag defaultDistPref,+    testDistPref    = NoFlag,     testVerbosity   = Flag normal,     testHumanLog    = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log",     testMachineLog  = toFlag $ toPathTemplate $ "$pkgid.log",     testShowDetails = toFlag Failures,     testKeepTix     = toFlag False,-    testList        = Flag [],     testOptions     = []   }  testCommand :: CommandUI TestFlags-testCommand = makeCommand name shortDesc longDesc defaultTestFlags options-  where-    name       = "test"-    shortDesc  = "Run the test suite, if any (configure with UserHooks)."-    longDesc   = Nothing-    options showOrParseArgs =+testCommand = CommandUI+  { commandName         = "test"+  , commandSynopsis     =+      "Run all/specific tests in the test suite."+  , commandDescription  = Just $ \pname -> wrapText $+         "If necessary (re)configures with `--enable-tests` flag and builds"+      ++ " the test suite.\n"+      ++ "\n"+      ++ "Remember that the tests' dependencies must be installed if there"+      ++ " are additional ones; e.g. with `" ++ pname+      ++ " install --only-dependencies --enable-tests`.\n"+      ++ "\n"+      ++ "By defining UserHooks in a custom Setup.hs, the package can"+      ++ " define actions to be executed before and after running tests.\n"+  , commandNotes        = Nothing+  , commandUsage        = usageAlternatives "test"+      [ "[FLAGS]"+      , "TESTCOMPONENTS [FLAGS]"+      ]+  , commandDefaultFlags = defaultTestFlags+  , commandOptions = \showOrParseArgs ->       [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v })       , optionDistPref             testDistPref (\d flags -> flags { testDistPref = d })@@ -1640,7 +1846,8 @@       , option [] ["show-details"]             ("'always': always show results of individual test cases. "              ++ "'never': never show results of individual test cases. "-             ++ "'failures': show results of failing test cases.")+             ++ "'failures': show results of failing test cases. "+             ++ "'streaming': show results of test cases in real time.")             testShowDetails (\v flags -> flags { testShowDetails = v })             (reqArg "FILTER"                 (readP_to_E (\_ -> "--show-details flag expects one of "@@ -1668,6 +1875,7 @@             (reqArg' "TEMPLATE" (\x -> [toPathTemplate x])                 (map fromPathTemplate))       ]+  }  emptyTestFlags :: TestFlags emptyTestFlags  = mempty@@ -1680,7 +1888,6 @@     testMachineLog  = mempty,     testShowDetails = mempty,     testKeepTix     = mempty,-    testList        = mempty,     testOptions     = mempty   }   mappend a b = TestFlags {@@ -1690,7 +1897,6 @@     testMachineLog  = combine testMachineLog,     testShowDetails = combine testShowDetails,     testKeepTix     = combine testKeepTix,-    testList        = combine testList,     testOptions     = combine testOptions   }     where combine field = field a `mappend` field b@@ -1707,19 +1913,34 @@  defaultBenchmarkFlags :: BenchmarkFlags defaultBenchmarkFlags  = BenchmarkFlags {-    benchmarkDistPref  = Flag defaultDistPref,+    benchmarkDistPref  = NoFlag,     benchmarkVerbosity = Flag normal,     benchmarkOptions   = []   }  benchmarkCommand :: CommandUI BenchmarkFlags-benchmarkCommand = makeCommand name shortDesc-                   longDesc defaultBenchmarkFlags options-  where-    name       = "bench"-    shortDesc  = "Run the benchmark, if any (configure with UserHooks)."-    longDesc   = Nothing-    options showOrParseArgs =+benchmarkCommand = CommandUI+  { commandName         = "bench"+  , commandSynopsis     =+      "Run all/specific benchmarks."+  , commandDescription  = Just $ \pname -> wrapText $+         "If necessary (re)configures with `--enable-benchmarks` flag and"+      ++ " builds the benchmarks.\n"+      ++ "\n"+      ++ "Remember that the benchmarks' dependencies must be installed if"+      ++ " there are additional ones; e.g. with `" ++ pname+      ++ " install --only-dependencies --enable-benchmarks`.\n"+      ++ "\n"+      ++ "By defining UserHooks in a custom Setup.hs, the package can"+      ++ " define actions to be executed before and after running"+      ++ " benchmarks.\n"+  , commandNotes        = Nothing+  , commandUsage        = usageAlternatives "bench"+      [ "[FLAGS]"+      , "BENCHCOMPONENTS [FLAGS]"+      ]+  , commandDefaultFlags = defaultBenchmarkFlags+  , commandOptions = \showOrParseArgs ->       [ optionVerbosity benchmarkVerbosity         (\v flags -> flags { benchmarkVerbosity = v })       , optionDistPref@@ -1741,6 +1962,7 @@             (reqArg' "TEMPLATE" (\x -> [toPathTemplate x])                 (map fromPathTemplate))       ]+  }  emptyBenchmarkFlags :: BenchmarkFlags emptyBenchmarkFlags = mempty@@ -1860,10 +2082,9 @@             -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a boolOpt' = Command.boolOpt' flagToMaybe Flag -trueArg, falseArg :: SFlags -> LFlags -> Description -> (b -> Flag Bool) ->-                     (Flag Bool -> (b -> b)) -> OptDescr b-trueArg  = noArg (Flag True)-falseArg = noArg (Flag False)+trueArg, falseArg :: MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a+trueArg  sfT lfT = boolOpt' (sfT, lfT) ([], [])   sfT lfT+falseArg sfF lfF = boolOpt' ([],  [])  (sfF, lfF) sfF lfF  reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->               (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b

cabal/Cabal/Distribution/Simple/SrcDist.hs view

@@ -2,6 +2,7 @@ -- | -- Module      :  Distribution.Simple.SrcDist -- Copyright   :  Simon Marlow 2004+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -16,37 +17,6 @@ -- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows. -- The 'sdist' action now also does some distribution QA checks. -{- Copyright (c) 2003-2004, Simon Marlow-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. -}- -- NOTE: FIX: we don't have a great way of testing this module, since -- we can't easily look inside a tarball once its created. @@ -59,7 +29,7 @@   prepareTree,   createArchive, -  -- ** Snaphots+  -- ** Snapshots   prepareSnapshotTree,   snapshotPackage,   snapshotVersion,@@ -85,9 +55,9 @@ import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File          , installOrdinaryFiles, installMaybeExecutableFiles-         , findFile, findFileWithExtension, matchFileGlob+         , findFile, findFileWithExtension, findAllFilesWithExtension, matchFileGlob          , withTempDirectory, defaultPackageDesc-         , die, warn, notice, setupMessage )+         , die, warn, notice, info, setupMessage ) import Distribution.Simple.Setup ( Flag(..), SDistFlags(..)                                  , fromFlag, flagToMaybe) import Distribution.Simple.PreProcess ( PPSuffixHandler, ppSuffixes@@ -96,13 +66,14 @@          ( LocalBuildInfo(..), withAllComponentsInBuildOrder ) import Distribution.Simple.BuildPaths ( autogenModuleName ) import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram,-                              rawSystemProgram, tarProgram )+                                     runProgram, programProperties, tarProgram ) import Distribution.Text          ( display )  import Control.Monad(when, unless, forM) import Data.Char (toLower) import Data.List (partition, isPrefixOf)+import qualified Data.Map as Map import Data.Maybe (isNothing, catMaybes) import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay) import System.Directory ( doesFileExist )@@ -142,7 +113,7 @@       case flagToMaybe (sDistDirectory flags) of         Just targetDir -> do           generateSourceDir targetDir pkg'-          notice verbosity $ "Source directory created: " ++ targetDir+          info verbosity $ "Source directory created: " ++ targetDir          Nothing -> do           createDirectoryIfMissingVerbose verbosity True tmpTargetDir@@ -254,10 +225,8 @@     . forM (extraDocFiles pkg_descr) $ \ filename ->       matchFileGlob filename -    -- License file.-  , return $ case [licenseFile pkg_descr]-             of [[]] -> []-                l    -> l+    -- License file(s).+  , return (licenseFiles pkg_descr)      -- Install-include files.   , withLib $ \ l -> do@@ -289,7 +258,7 @@             -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)             -> IO () prepareTree verbosity pkg_descr0 mb_lbi targetDir pps = do-  -- If the package was configured then we can run platform independent+  -- If the package was configured then we can run platform-independent   -- pre-processors and include those generated files.   case mb_lbi of     Just lbi | not (null pps) -> do@@ -443,13 +412,17 @@    (tarProg, _) <- requireProgram verbosity tarProgram                     (maybe defaultProgramConfiguration withPrograms mb_lbi)--   -- Hmm: I could well be skating on thinner ice here by using the -C option-   -- (=> GNU tar-specific?)  [The prev. solution used pipes and sub-command-   -- sequences to set up the paths correctly, which is problematic in a Windows-   -- setting.]-  rawSystemProgram verbosity tarProg-           ["-C", tmpDir, "-czf", tarBallFilePath, tarBallName pkg_descr]+  let formatOptSupported = maybe False (== "YES") $+                           Map.lookup "Supports --format"+                           (programProperties tarProg)+  runProgram verbosity tarProg $+    -- Hmm: I could well be skating on thinner ice here by using the -C option+    -- (=> seems to be supported at least by GNU and *BSD tar) [The+    -- prev. solution used pipes and sub-command sequences to set up the paths+    -- correctly, which is problematic in a Windows setting.]+    ["-czf", tarBallFilePath, "-C", tmpDir]+    ++ (if formatOptSupported then ["--format", "ustar"] else [])+    ++ [tarBallName pkg_descr]   return tarBallFilePath  -- | Given a buildinfo, return the names of all source files.@@ -459,10 +432,10 @@                        -> IO [FilePath] allSourcesBuildInfo bi pps modules = do   let searchDirs = hsSourceDirs bi-  sources <- sequence+  sources <- fmap concat $ sequence $     [ let file = ModuleName.toFilePath module_-      in findFileWithExtension suffixes searchDirs file-         >>= maybe (notFound module_) return+      in findAllFilesWithExtension suffixes searchDirs file+         >>= nonEmpty (notFound module_) return     | module_ <- modules ++ otherModules bi ]   bootFiles <- sequence     [ let file = ModuleName.toFilePath module_@@ -470,9 +443,11 @@       in findFileWithExtension fileExts (hsSourceDirs bi) file     | module_ <- modules ++ otherModules bi ] -  return $ sources ++ catMaybes bootFiles ++ cSources bi+  return $ sources ++ catMaybes bootFiles ++ cSources bi ++ jsSources bi    where+    nonEmpty x _ [] = x+    nonEmpty _ f xs = f xs     suffixes = ppSuffixes pps ++ ["hs", "lhs"]     notFound m = die $ "Error: Could not find module: " ++ display m                  ++ " with any suffix: " ++ show suffixes@@ -482,8 +457,9 @@ printPackageProblems verbosity pkg_descr = do   ioChecks      <- checkPackageFiles pkg_descr "."   let pureChecks = checkConfiguredPackage pkg_descr-      isDistError (PackageDistSuspicious _) = False-      isDistError _                         = True+      isDistError (PackageDistSuspicious     _) = False+      isDistError (PackageDistSuspiciousWarn _) = False+      isDistError _                             = True       (errors, warnings) = partition isDistError (pureChecks ++ ioChecks)   unless (null errors) $       notice verbosity $ "Distribution quality errors:\n"

cabal/Cabal/Distribution/Simple/Test.hs view

@@ -2,6 +2,7 @@ -- | -- Module      :  Distribution.Simple.Test -- Copyright   :  Thomas Tuegel 2010+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -10,329 +11,74 @@ -- \"@.\/setup test@\" action. It runs test suites designated in the package -- description and reports on the results. -{- 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. -}- module Distribution.Simple.Test     ( test-    , stubMain-    , writeSimpleTestStub-    , stubFilePath-    , stubName-    , PackageLog(..)-    , TestSuiteLog(..)-    , TestLogs(..)-    , suitePassed, suiteFailed, suiteError     ) where -import Distribution.Compat.TempFile ( openTempFile )-import Distribution.ModuleName ( ModuleName )-import Distribution.Package-    ( PackageId ) import qualified Distribution.PackageDescription as PD          ( PackageDescription(..), BuildInfo(buildable)          , TestSuite(..)          , TestSuiteInterface(..), testType, hasTests )-import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )-import Distribution.Simple.BuildPaths ( exeExtension )-import Distribution.Simple.Compiler ( Compiler(..), CompilerId )-import Distribution.Simple.Hpc-    ( markupPackage, markupTest, tixDir, tixFilePath )+import Distribution.Simple.Compiler ( compilerInfo )+import Distribution.Simple.Hpc ( markupPackage ) import Distribution.Simple.InstallDirs-    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)-    , substPathTemplate , toPathTemplate, PathTemplate )+    ( fromPathTemplate, initialPathTemplateEnv, substPathTemplate+    , PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI-    ( LocalBuildInfo(..) )-import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag )-import Distribution.Simple.Utils ( die, notice, rawSystemIOWithEnv )-import Distribution.TestSuite-    ( OptionDescr(..), Options, Progress(..), Result(..), TestInstance(..)-    , Test(..) )+    ( LocalBuildInfo(..), localLibraryName )+import Distribution.Simple.Setup ( TestFlags(..), fromFlag, configCoverage )+import Distribution.Simple.UserHooks ( Args )+import qualified Distribution.Simple.Test.ExeV10 as ExeV10+import qualified Distribution.Simple.Test.LibV09 as LibV09+import Distribution.Simple.Test.Log+import Distribution.Simple.Utils ( die, notice )+import Distribution.TestSuite ( Result(..) ) import Distribution.Text-import Distribution.Verbosity ( normal, Verbosity )-import Distribution.System ( Platform ) -import Control.Exception ( bracket ) import Control.Monad ( when, unless, filterM )-import Data.Char ( toUpper )-import Data.Maybe ( mapMaybe ) import System.Directory-    ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist-    , getCurrentDirectory, getDirectoryContents, removeDirectoryRecursive-    , removeFile, setCurrentDirectory )-import Distribution.Compat.Environment ( getEnvironment )+    ( createDirectoryIfMissing, doesFileExist, getDirectoryContents+    , removeFile ) import System.Exit ( ExitCode(..), exitFailure, exitWith )-import System.FilePath ( (</>), (<.>) )-import System.IO ( hClose, IOMode(..), openFile )---- | Logs all test results for a package, broken down first by test suite and--- then by test case.-data PackageLog = PackageLog-    { package :: PackageId-    , compiler :: CompilerId-    , platform :: Platform-    , testSuites :: [TestSuiteLog]-    }-    deriving (Read, Show, Eq)---- | A 'PackageLog' with package and platform information specified.-localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog-localPackageLog pkg_descr lbi = PackageLog-    { package = PD.package pkg_descr-    , compiler = compilerId $ LBI.compiler lbi-    , platform = LBI.hostPlatform lbi-    , testSuites = []-    }---- | Logs test suite results, itemized by test case.-data TestSuiteLog = TestSuiteLog-    { testSuiteName :: String-    , testLogs :: TestLogs-    , logFile :: FilePath    -- path to human-readable log file-    }-    deriving (Read, Show, Eq)--data TestLogs-    = TestLog-        { testName              :: String-        , testOptionsReturned   :: Options-        , testResult            :: Result-        }-    | GroupLogs String [TestLogs]-    deriving (Read, Show, Eq)---- | Count the number of pass, fail, and error test results in a 'TestLogs'--- tree.-countTestResults :: TestLogs-                 -> (Int, Int, Int) -- ^ Passes, fails, and errors,-                                    -- respectively.-countTestResults = go (0, 0, 0)-  where-    go (p, f, e) (TestLog { testResult = r }) =-        case r of-            Pass -> (p + 1, f, e)-            Fail _ -> (p, f + 1, e)-            Error _ -> (p, f, e + 1)-    go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts---- | From a 'TestSuiteLog', determine if the test suite passed.-suitePassed :: TestSuiteLog -> Bool-suitePassed l =-    case countTestResults (testLogs l) of-        (_, 0, 0) -> True-        _ -> False---- | From a 'TestSuiteLog', determine if the test suite failed.-suiteFailed :: TestSuiteLog -> Bool-suiteFailed l =-    case countTestResults (testLogs l) of-        (_, 0, _) -> False-        _ -> True---- | From a 'TestSuiteLog', determine if the test suite encountered errors.-suiteError :: TestSuiteLog -> Bool-suiteError l =-    case countTestResults (testLogs l) of-        (_, _, 0) -> False-        _ -> True---- | Run a test executable, logging the output and generating the appropriate--- summary messages.-testController :: TestFlags-               -- ^ flags Cabal was invoked with-               -> PD.PackageDescription-               -- ^ description of package the test suite belongs to-               -> LBI.LocalBuildInfo-               -- ^ information from the configure step-               -> PD.TestSuite-               -- ^ TestSuite being tested-               -> (FilePath -> String)-               -- ^ prepare standard input for test executable-               -> FilePath -- ^ executable name-               -> (ExitCode -> String -> TestSuiteLog)-               -- ^ generator for the TestSuiteLog-               -> (TestSuiteLog -> FilePath)-               -- ^ generator for final human-readable log filename-               -> IO TestSuiteLog-testController flags pkg_descr lbi suite preTest cmd postTest logNamer = do-    let distPref = fromFlag $ testDistPref flags-        verbosity = fromFlag $ testVerbosity flags-        testLogDir = distPref </> "test"-        opts = map (testOption pkg_descr lbi suite) $ testOptions flags--    pwd <- getCurrentDirectory-    existingEnv <- getEnvironment-    let dataDirPath = pwd </> PD.dataDir pkg_descr-        shellEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)-                   : ("HPCTIXFILE", (</>) pwd-                       $ tixFilePath distPref $ PD.testName suite)-                   : existingEnv--    bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog ->-        bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do--            -- Check that the test executable exists.-            exists <- doesFileExist cmd-            unless exists $ die $ "Error: Could not find test program \"" ++ cmd-                                  ++ "\". Did you build the package first?"--            -- Remove old .tix files if appropriate.-            unless (fromFlag $ testKeepTix flags) $ do-                let tDir = tixDir distPref $ PD.testName suite-                exists' <- doesDirectoryExist tDir-                when exists' $ removeDirectoryRecursive tDir--            -- Create directory for HPC files.-            createDirectoryIfMissing True $ tixDir distPref $ PD.testName suite--            -- Write summary notices indicating start of test suite-            notice verbosity $ summarizeSuiteStart $ PD.testName suite--            -- Prepare standard input for test executable-            appendFile tempInput $ preTest tempInput--            -- Run test executable-            exit <- do-              hLog <- openFile tempLog AppendMode-              hIn  <- openFile tempInput ReadMode-              -- these handles get closed by rawSystemIOWithEnv-              rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv)-                                 (Just hIn) (Just hLog) (Just hLog)--            -- Generate TestSuiteLog from executable exit code and a machine--            -- readable test log-            suiteLog <- fmap (postTest exit $!) $ readFile tempInput--            -- Generate final log file name-            let finalLogName = testLogDir </> logNamer suiteLog-                suiteLog' = suiteLog { logFile = finalLogName }--            -- Write summary notice to log file indicating start of test suite-            appendFile (logFile suiteLog') $ summarizeSuiteStart $ PD.testName suite--            -- Append contents of temporary log file to the final human--            -- readable log file-            readFile tempLog >>= appendFile (logFile suiteLog')--            -- Write end-of-suite summary notice to log file-            appendFile (logFile suiteLog') $ summarizeSuiteFinish suiteLog'--            -- Show the contents of the human-readable log file on the terminal-            -- if there is a failure and/or detailed output is requested-            let details = fromFlag $ testShowDetails flags-                whenPrinting = when $ (details > Never)-                    && (not (suitePassed suiteLog) || details == Always)-                    && verbosity >= normal-            whenPrinting $ readFile tempLog >>=-                putStr . unlines . lines--            -- Write summary notice to terminal indicating end of test suite-            notice verbosity $ summarizeSuiteFinish suiteLog'--            markupTest verbosity lbi distPref-                (display $ PD.package pkg_descr) suite--            return suiteLog'-    where-        deleteIfExists file = do-            exists <- doesFileExist file-            when exists $ removeFile file--        openCabalTemp testLogDir = do-            (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log"-            hClose h >> return f-+import System.FilePath ( (</>) )  -- |Perform the \"@.\/setup test@\" action.-test :: PD.PackageDescription   -- ^information from the .cabal file+test :: Args                    -- ^positional command-line arguments+     -> PD.PackageDescription   -- ^information from the .cabal file      -> LBI.LocalBuildInfo      -- ^information from the configure step      -> TestFlags               -- ^flags sent to test      -> IO ()-test pkg_descr lbi flags = do+test args pkg_descr lbi flags = do     let verbosity = fromFlag $ testVerbosity flags-        humanTemplate = fromFlag $ testHumanLog flags         machineTemplate = fromFlag $ testMachineLog flags         distPref = fromFlag $ testDistPref flags         testLogDir = distPref </> "test"-        testNames = fromFlag $ testList flags+        testNames = args         pkgTests = PD.testSuites pkg_descr         enabledTests = [ t | t <- pkgTests                            , PD.testEnabled t                            , PD.buildable (PD.testBuildInfo t) ]          doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog-        doTest (suite, _) = do-            let testLogPath = testSuiteLogPath humanTemplate pkg_descr lbi-                go pre cmd post = testController flags pkg_descr lbi suite-                                                 pre cmd post testLogPath+        doTest (suite, _) =             case PD.testInterface suite of-              PD.TestSuiteExeV10 _ _ -> do-                    let cmd = LBI.buildDir lbi </> PD.testName suite-                            </> PD.testName suite <.> exeExtension-                        preTest _ = ""-                        postTest exit _ =-                            let r = case exit of-                                    ExitSuccess -> Pass-                                    ExitFailure c -> Fail-                                        $ "exit code: " ++ show c-                            in TestSuiteLog-                                { testSuiteName = PD.testName suite-                                , testLogs = TestLog-                                    { testName = PD.testName suite-                                    , testOptionsReturned = []-                                    , testResult = r-                                    }-                                , logFile = ""-                                }-                    go preTest cmd postTest+              PD.TestSuiteExeV10 _ _ ->+                  ExeV10.runTest pkg_descr lbi flags suite -              PD.TestSuiteLibV09 _ _ -> do-                    let cmd = LBI.buildDir lbi </> stubName suite-                            </> stubName suite <.> exeExtension-                        preTest f = show ( f-                                         , PD.testName suite-                                         )-                        postTest _ = read-                    go preTest cmd postTest+              PD.TestSuiteLibV09 _ _ ->+                  LibV09.runTest pkg_descr lbi flags suite                _ -> return TestSuiteLog-                            { testSuiteName = PD.testName suite-                            , testLogs = TestLog-                                { testName = PD.testName suite-                                , testOptionsReturned = []-                                , testResult = Error $-                                    "No support for running test suite type: "-                                    ++ show (disp $ PD.testType suite)-                                }-                            , logFile = ""-                            }+                  { testSuiteName = PD.testName suite+                  , testLogs = TestLog+                      { testName = PD.testName suite+                      , testOptionsReturned = []+                      , testResult =+                          Error $ "No support for running test suite type: "+                                  ++ show (disp $ PD.testType suite)+                      }+                  , logFile = ""+                  }      when (not $ PD.hasTests pkg_descr) $ do         notice verbosity "Package has no test suites."@@ -371,86 +117,13 @@     allOk <- summarizePackage verbosity packageLog     writeFile packageLogFile $ show packageLog -    markupPackage verbosity lbi distPref (display $ PD.package pkg_descr)-        $ map fst testsToRun+    let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi+    when isCoverageEnabled $+        markupPackage verbosity lbi distPref (display $ PD.package pkg_descr) $+            map fst testsToRun      unless allOk exitFailure --- | Print a summary to the console after all test suites have been run--- indicating the number of successful test suites and cases.  Returns 'True' if--- all test suites passed and 'False' otherwise.-summarizePackage :: Verbosity -> PackageLog -> IO Bool-summarizePackage verbosity packageLog = do-    let counts = map (countTestResults . testLogs) $ testSuites packageLog-        (passed, failed, errors) = foldl1 addTriple counts-        totalCases = passed + failed + errors-        passedSuites = length $ filter suitePassed $ testSuites packageLog-        totalSuites = length $ testSuites packageLog-    notice verbosity $ show passedSuites ++ " of " ++ show totalSuites-        ++ " test suites (" ++ show passed ++ " of "-        ++ show totalCases ++ " test cases) passed."-    return $! passedSuites == totalSuites-  where-    addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2)---- | Print a summary of a single test case's result to the console, supressing--- output for certain verbosity or test filter levels.-summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO ()-summarizeTest _ _ (GroupLogs {}) = return ()-summarizeTest verbosity details t =-    when shouldPrint $ notice verbosity $ "Test case " ++ testName t-        ++ ": " ++ show (testResult t)-    where shouldPrint = (details > Never) && (notPassed || details == Always)-          notPassed = testResult t /= Pass---- | Print a summary of the test suite's results on the console, suppressing--- output for certain verbosity or test filter levels.-summarizeSuiteFinish :: TestSuiteLog -> String-summarizeSuiteFinish testLog = unlines-    [ "Test suite " ++ testSuiteName testLog ++ ": " ++ resStr-    , "Test suite logged to: " ++ logFile testLog-    ]-    where resStr = map toUpper (resultString testLog)--summarizeSuiteStart :: String -> String-summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n"--resultString :: TestSuiteLog -> String-resultString l | suiteError l = "error"-               | suiteFailed l = "fail"-               | otherwise = "pass"--testSuiteLogPath :: PathTemplate-                 -> PD.PackageDescription-                 -> LBI.LocalBuildInfo-                 -> TestSuiteLog-                 -> FilePath-testSuiteLogPath template pkg_descr lbi testLog =-    fromPathTemplate $ substPathTemplate env template-    where-        env = initialPathTemplateEnv-                (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)-                (LBI.hostPlatform lbi)-                ++  [ (TestSuiteNameVar, toPathTemplate $ testSuiteName testLog)-                    , (TestSuiteResultVar, result)-                    ]-        result = toPathTemplate $ resultString testLog---- TODO: This is abusing the notion of a 'PathTemplate'.  The result--- isn't neccesarily a path.-testOption :: PD.PackageDescription-           -> LBI.LocalBuildInfo-           -> PD.TestSuite-           -> PathTemplate-           -> String-testOption pkg_descr lbi suite template =-    fromPathTemplate $ substPathTemplate env template-  where-    env = initialPathTemplateEnv-          (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)-          (LBI.hostPlatform lbi) ++-          [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]- packageLogPath :: PathTemplate                -> PD.PackageDescription                -> LBI.LocalBuildInfo@@ -459,89 +132,5 @@     fromPathTemplate $ substPathTemplate env template     where         env = initialPathTemplateEnv-                (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)-                (LBI.hostPlatform lbi)---- | The filename of the source file for the stub executable associated with a--- library 'TestSuite'.-stubFilePath :: PD.TestSuite -> FilePath-stubFilePath t = stubName t <.> "hs"---- | The name of the stub executable associated with a library 'TestSuite'.-stubName :: PD.TestSuite -> FilePath-stubName t = PD.testName t ++ "Stub"---- | Write the source file for a library 'TestSuite' stub executable.-writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub-                                    -- is being created-                    -> FilePath     -- ^ path to directory where stub source-                                    -- should be located-                    -> IO ()-writeSimpleTestStub t dir = do-    createDirectoryIfMissing True dir-    let filename = dir </> stubFilePath t-        PD.TestSuiteLibV09 _ m = PD.testInterface t-    writeFile filename $ simpleTestStub m---- | Source code for library test suite stub executable-simpleTestStub :: ModuleName -> String-simpleTestStub m = unlines-    [ "module Main ( main ) where"-    , "import Distribution.Simple.Test ( stubMain )"-    , "import " ++ show (disp m) ++ " ( tests )"-    , "main :: IO ()"-    , "main = stubMain tests"-    ]---- | Main function for test stubs. Once, it was written directly into the stub,--- but minimizing the amount of code actually in the stub maximizes the number--- of detectable errors when Cabal is compiled.-stubMain :: IO [Test] -> IO ()-stubMain tests = do-    (f, n) <- fmap read getContents-    dir <- getCurrentDirectory-    results <- tests >>= stubRunTests-    setCurrentDirectory dir-    stubWriteLog f n results---- | 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--- the child of a Cabal process during @.\/setup test@.  A 'TestSuiteLog',--- provided by Cabal, is read from the standard input; it supplies the name of--- the test suite and the location of the machine-readable test suite log file.--- Human-readable log information is written to the standard output for capture--- by the calling Cabal process.-stubRunTests :: [Test] -> IO TestLogs-stubRunTests tests = do-    logs <- mapM stubRunTests' tests-    return $ GroupLogs "Default" logs-  where-    stubRunTests' (Test t) = do-        l <- run t >>= finish-        summarizeTest normal Always l-        return l-      where-        finish (Finished result) =-            return TestLog-                { testName = name t-                , testOptionsReturned = defaultOptions t-                , testResult = result-                }-        finish (Progress _ next) = next >>= finish-    stubRunTests' g@(Group {}) = do-        logs <- mapM stubRunTests' $ groupTests g-        return $ GroupLogs (groupName g) logs-    stubRunTests' (ExtraOptions _ t) = stubRunTests' t-    maybeDefaultOption opt =-        maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt-    defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst---- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling--- Cabal process to read.-stubWriteLog :: FilePath -> String -> TestLogs -> IO ()-stubWriteLog f n logs = do-    let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f }-    writeFile (logFile testLog) $ show testLog-    when (suiteError testLog) $ exitWith $ ExitFailure 2-    when (suiteFailed testLog) $ exitWith $ ExitFailure 1-    exitWith ExitSuccess+                (PD.package pkg_descr) (LBI.localLibraryName lbi)+                (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi)

+ cabal/Cabal/Distribution/Simple/Test/ExeV10.hs view

@@ -0,0 +1,168 @@+module Distribution.Simple.Test.ExeV10+       ( runTest+       ) where++import Distribution.Compat.CreatePipe ( createPipe )+import Distribution.Compat.Environment ( getEnvironment )+import qualified Distribution.PackageDescription as PD+import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )+import Distribution.Simple.BuildPaths ( exeExtension )+import Distribution.Simple.Compiler ( compilerInfo )+import Distribution.Simple.Hpc ( guessWay, markupTest, tixDir, tixFilePath )+import Distribution.Simple.InstallDirs+    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)+    , substPathTemplate , toPathTemplate, PathTemplate )+import qualified Distribution.Simple.LocalBuildInfo as LBI+import Distribution.Simple.Setup+    ( TestFlags(..), TestShowDetails(..), fromFlag, configCoverage )+import Distribution.Simple.Test.Log+import Distribution.Simple.Utils+    ( die, notice, rawSystemIOWithEnv, addLibraryPath )+import Distribution.System ( Platform (..) )+import Distribution.TestSuite+import Distribution.Text+import Distribution.Verbosity ( normal )++import Control.Concurrent (forkIO)+import Control.Monad ( unless, void, when )+import System.Directory+    ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist+    , getCurrentDirectory, removeDirectoryRecursive )+import System.Exit ( ExitCode(..) )+import System.FilePath ( (</>), (<.>) )+import System.IO ( hGetContents, hPutStr, stdout )++runTest :: PD.PackageDescription+        -> LBI.LocalBuildInfo+        -> TestFlags+        -> PD.TestSuite+        -> IO TestSuiteLog+runTest pkg_descr lbi flags suite = do+    let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi+        way = guessWay lbi+        tixDir_ = tixDir distPref way $ PD.testName suite++    pwd <- getCurrentDirectory+    existingEnv <- getEnvironment++    let cmd = LBI.buildDir lbi </> PD.testName suite+                  </> PD.testName suite <.> exeExtension+    -- Check that the test executable exists.+    exists <- doesFileExist cmd+    unless exists $ die $ "Error: Could not find test program \"" ++ cmd+                          ++ "\". Did you build the package first?"++    -- Remove old .tix files if appropriate.+    unless (fromFlag $ testKeepTix flags) $ do+        exists' <- doesDirectoryExist tixDir_+        when exists' $ removeDirectoryRecursive tixDir_++    -- Create directory for HPC files.+    createDirectoryIfMissing True tixDir_++    -- Write summary notices indicating start of test suite+    notice verbosity $ summarizeSuiteStart $ PD.testName suite++    (rOut, wOut) <- createPipe++    -- Read test executable's output lazily (returns immediately)+    logText <- hGetContents rOut+    -- Force the IO manager to drain the test output pipe+    void $ forkIO $ length logText `seq` return ()++    -- '--show-details=streaming': print the log output in another thread+    when (details == Streaming) $ void $ forkIO $ hPutStr stdout logText++    -- Run the test executable+    let opts = map (testOption pkg_descr lbi suite)+                   (testOptions flags)+        dataDirPath = pwd </> PD.dataDir pkg_descr+        tixFile = pwd </> tixFilePath distPref way (PD.testName suite)+        pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)+                   : existingEnv+        shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv++    -- 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++    exit <- rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv')+                               -- these handles are automatically closed+                               Nothing (Just wOut) (Just wOut)++    -- Generate TestSuiteLog from executable exit code and a machine-+    -- readable test log.+    let suiteLog = buildLog exit++    -- Write summary notice to log file indicating start of test suite+    appendFile (logFile suiteLog) $ summarizeSuiteStart $ PD.testName suite++    -- Append contents of temporary log file to the final human-+    -- readable log file+    appendFile (logFile suiteLog) logText++    -- Write end-of-suite summary notice to log file+    appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog++    -- Show the contents of the human-readable log file on the terminal+    -- if there is a failure and/or detailed output is requested+    let whenPrinting = when $+            (details > Never)+            && (not (suitePassed $ testLogs suiteLog) || details == Always)+            -- verbosity overrides show-details+            && verbosity >= normal+            -- if streaming, we already printed the log+            && details /= Streaming+    whenPrinting $ putStr $ unlines $ lines logText++    -- Write summary notice to terminal indicating end of test suite+    notice verbosity $ summarizeSuiteFinish suiteLog++    when isCoverageEnabled $+        markupTest verbosity lbi distPref (display $ PD.package pkg_descr) suite++    return suiteLog+  where+    distPref = fromFlag $ testDistPref flags+    verbosity = fromFlag $ testVerbosity flags+    details = fromFlag $ testShowDetails flags+    testLogDir = distPref </> "test"++    buildLog exit =+        let r = case exit of+                    ExitSuccess -> Pass+                    ExitFailure c -> Fail $ "exit code: " ++ show c+            n = PD.testName suite+            l = TestLog+                { testName = n+                , testOptionsReturned = []+                , testResult = r+                }+        in TestSuiteLog+                { testSuiteName = n+                , testLogs = l+                , logFile =+                    testLogDir+                    </> testSuiteLogPath (fromFlag $ testHumanLog flags)+                                         pkg_descr lbi n l+                }++-- TODO: This is abusing the notion of a 'PathTemplate'.  The result isn't+-- necessarily a path.+testOption :: PD.PackageDescription+           -> LBI.LocalBuildInfo+           -> PD.TestSuite+           -> PathTemplate+           -> String+testOption pkg_descr lbi suite template =+    fromPathTemplate $ substPathTemplate env template+  where+    env = initialPathTemplateEnv+          (PD.package pkg_descr) (LBI.localLibraryName lbi)+          (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) +++          [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]

+ cabal/Cabal/Distribution/Simple/Test/LibV09.hs view

@@ -0,0 +1,262 @@+module Distribution.Simple.Test.LibV09+       ( runTest+         -- Test stub+       , simpleTestStub+       , stubFilePath, stubMain, stubName, stubWriteLog+       , writeSimpleTestStub+       ) where++import Distribution.Compat.CreatePipe ( createPipe )+import Distribution.Compat.Environment ( getEnvironment )+import Distribution.Compat.TempFile ( openTempFile )+import Distribution.ModuleName ( ModuleName )+import qualified Distribution.PackageDescription as PD+import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )+import Distribution.Simple.BuildPaths ( exeExtension )+import Distribution.Simple.Compiler ( compilerInfo )+import Distribution.Simple.Hpc ( guessWay, markupTest, tixDir, tixFilePath )+import Distribution.Simple.InstallDirs+    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)+    , substPathTemplate , toPathTemplate, PathTemplate )+import qualified Distribution.Simple.LocalBuildInfo as LBI+import Distribution.Simple.Setup+    ( TestFlags(..), TestShowDetails(..), fromFlag, configCoverage )+import Distribution.Simple.Test.Log+import Distribution.Simple.Utils+    ( die, notice, rawSystemIOWithEnv, addLibraryPath )+import Distribution.System ( Platform (..) )+import Distribution.TestSuite+import Distribution.Text+import Distribution.Verbosity ( normal )++import Control.Concurrent (forkIO)+import Control.Exception ( bracket )+import Control.Monad ( when, unless, void )+import Data.Maybe ( mapMaybe )+import System.Directory+    ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist+    , getCurrentDirectory, removeDirectoryRecursive, removeFile+    , setCurrentDirectory )+import System.Exit ( ExitCode(..), exitWith )+import System.FilePath ( (</>), (<.>) )+import System.IO ( hClose, hGetContents, hPutStr )++runTest :: PD.PackageDescription+        -> LBI.LocalBuildInfo+        -> TestFlags+        -> PD.TestSuite+        -> IO TestSuiteLog+runTest pkg_descr lbi flags suite = do+    let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi+        way = guessWay lbi++    pwd <- getCurrentDirectory+    existingEnv <- getEnvironment++    let cmd = LBI.buildDir lbi </> stubName suite+                  </> stubName suite <.> exeExtension+    -- Check that the test executable exists.+    exists <- doesFileExist cmd+    unless exists $ die $ "Error: Could not find test program \"" ++ cmd+                          ++ "\". Did you build the package first?"++    -- Remove old .tix files if appropriate.+    unless (fromFlag $ testKeepTix flags) $ do+        let tDir = tixDir distPref way $ PD.testName suite+        exists' <- doesDirectoryExist tDir+        when exists' $ removeDirectoryRecursive tDir++    -- Create directory for HPC files.+    createDirectoryIfMissing True $ tixDir distPref way $ PD.testName suite++    -- Write summary notices indicating start of test suite+    notice verbosity $ summarizeSuiteStart $ PD.testName suite++    suiteLog <- bracket openCabalTemp deleteIfExists $ \tempLog -> do++        (rIn, wIn) <- createPipe+        (rOut, wOut) <- createPipe++        -- Prepare standard input for test executable+        --appendFile tempInput $ show (tempInput, PD.testName suite)+        hPutStr wIn $ show (tempLog, PD.testName suite)+        hClose wIn++        -- Append contents of temporary log file to the final human-+        -- readable log file+        logText <- hGetContents rOut+        -- Force the IO manager to drain the test output pipe+        void $ forkIO $ length logText `seq` return ()++        -- Run test executable+        _ <- 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)+                    pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)+                               : existingEnv+                    shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled]+                             ++ pkgPathEnv+                -- 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+                rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv')+                                   -- these handles are closed automatically+                                   (Just rIn) (Just wOut) (Just wOut)++        -- Generate final log file name+        let finalLogName l = testLogDir+                             </> testSuiteLogPath+                                 (fromFlag $ testHumanLog flags) pkg_descr lbi+                                 (testSuiteName l) (testLogs l)+        -- Generate TestSuiteLog from executable exit code and a machine-+        -- readable test log+        suiteLog <- fmap ((\l -> l { logFile = finalLogName l }) . read)+                    $ readFile tempLog++        -- Write summary notice to log file indicating start of test suite+        appendFile (logFile suiteLog) $ summarizeSuiteStart $ PD.testName suite++        appendFile (logFile suiteLog) logText++        -- Write end-of-suite summary notice to log file+        appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog++        -- Show the contents of the human-readable log file on the terminal+        -- if there is a failure and/or detailed output is requested+        let details = fromFlag $ testShowDetails flags+            whenPrinting = when $ (details > Never)+                && (not (suitePassed $ testLogs suiteLog) || details == Always)+                && verbosity >= normal+        whenPrinting $ putStr $ unlines $ lines logText++        return suiteLog++    -- Write summary notice to terminal indicating end of test suite+    notice verbosity $ summarizeSuiteFinish suiteLog++    when isCoverageEnabled $+        markupTest verbosity lbi distPref (display $ PD.package pkg_descr) suite++    return suiteLog+  where+    deleteIfExists file = do+        exists <- doesFileExist file+        when exists $ removeFile file++    testLogDir = distPref </> "test"+    openCabalTemp = do+        (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log"+        hClose h >> return f++    distPref = fromFlag $ testDistPref flags+    verbosity = fromFlag $ testVerbosity flags++-- TODO: This is abusing the notion of a 'PathTemplate'.  The result isn't+-- necessarily a path.+testOption :: PD.PackageDescription+           -> LBI.LocalBuildInfo+           -> PD.TestSuite+           -> PathTemplate+           -> String+testOption pkg_descr lbi suite template =+    fromPathTemplate $ substPathTemplate env template+  where+    env = initialPathTemplateEnv+          (PD.package pkg_descr) (LBI.localLibraryName lbi)+          (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) +++          [(TestSuiteNameVar, toPathTemplate $ 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"++-- | The filename of the source file for the stub executable associated with a+-- library 'TestSuite'.+stubFilePath :: PD.TestSuite -> FilePath+stubFilePath t = stubName t <.> "hs"++-- | Write the source file for a library 'TestSuite' stub executable.+writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub+                                    -- is being created+                    -> FilePath     -- ^ path to directory where stub source+                                    -- should be located+                    -> IO ()+writeSimpleTestStub t dir = do+    createDirectoryIfMissing True dir+    let filename = dir </> stubFilePath t+        PD.TestSuiteLibV09 _ m = PD.testInterface t+    writeFile filename $ simpleTestStub m++-- | Source code for library test suite stub executable+simpleTestStub :: ModuleName -> String+simpleTestStub m = unlines+    [ "module Main ( main ) where"+    , "import Distribution.Simple.Test.LibV09 ( stubMain )"+    , "import " ++ show (disp m) ++ " ( tests )"+    , "main :: IO ()"+    , "main = stubMain tests"+    ]++-- | Main function for test stubs. Once, it was written directly into the stub,+-- but minimizing the amount of code actually in the stub maximizes the number+-- of detectable errors when Cabal is compiled.+stubMain :: IO [Test] -> IO ()+stubMain tests = do+    (f, n) <- fmap read getContents+    dir <- getCurrentDirectory+    results <- tests >>= stubRunTests+    setCurrentDirectory dir+    stubWriteLog f n results++-- | 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+-- the child of a Cabal process during @.\/setup test@.  A 'TestSuiteLog',+-- provided by Cabal, is read from the standard input; it supplies the name of+-- the test suite and the location of the machine-readable test suite log file.+-- Human-readable log information is written to the standard output for capture+-- by the calling Cabal process.+stubRunTests :: [Test] -> IO TestLogs+stubRunTests tests = do+    logs <- mapM stubRunTests' tests+    return $ GroupLogs "Default" logs+  where+    stubRunTests' (Test t) = do+        l <- run t >>= finish+        summarizeTest normal Always l+        return l+      where+        finish (Finished result) =+            return TestLog+                { testName = name t+                , testOptionsReturned = defaultOptions t+                , testResult = result+                }+        finish (Progress _ next) = next >>= finish+    stubRunTests' g@(Group {}) = do+        logs <- mapM stubRunTests' $ groupTests g+        return $ GroupLogs (groupName g) logs+    stubRunTests' (ExtraOptions _ t) = stubRunTests' t+    maybeDefaultOption opt =+        maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt+    defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst++-- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling+-- Cabal process to read.+stubWriteLog :: FilePath -> String -> TestLogs -> IO ()+stubWriteLog f n logs = do+    let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f }+    writeFile (logFile testLog) $ show testLog+    when (suiteError logs) $ exitWith $ ExitFailure 2+    when (suiteFailed logs) $ exitWith $ ExitFailure 1+    exitWith ExitSuccess

+ cabal/Cabal/Distribution/Simple/Test/Log.hs view

@@ -0,0 +1,161 @@+module Distribution.Simple.Test.Log+       ( PackageLog(..)+       , TestLogs(..)+       , TestSuiteLog(..)+       , countTestResults+       , localPackageLog+       , summarizePackage+       , summarizeSuiteFinish, summarizeSuiteStart+       , summarizeTest+       , suiteError, suiteFailed, suitePassed+       , testSuiteLogPath+       ) where++import Distribution.Package ( PackageId )+import qualified Distribution.PackageDescription as PD+import Distribution.Simple.Compiler ( Compiler(..), compilerInfo, CompilerId )+import Distribution.Simple.InstallDirs+    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)+    , substPathTemplate , toPathTemplate, PathTemplate )+import qualified Distribution.Simple.LocalBuildInfo as LBI+import Distribution.Simple.Setup ( TestShowDetails(..) )+import Distribution.Simple.Utils ( notice )+import Distribution.System ( Platform )+import Distribution.TestSuite ( Options, Result(..) )+import Distribution.Verbosity ( Verbosity )++import Control.Monad ( when )+import Data.Char ( toUpper )++-- | Logs all test results for a package, broken down first by test suite and+-- then by test case.+data PackageLog = PackageLog+    { package :: PackageId+    , compiler :: CompilerId+    , platform :: Platform+    , testSuites :: [TestSuiteLog]+    }+    deriving (Read, Show, Eq)++-- | A 'PackageLog' with package and platform information specified.+localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog+localPackageLog pkg_descr lbi = PackageLog+    { package = PD.package pkg_descr+    , compiler = compilerId $ LBI.compiler lbi+    , platform = LBI.hostPlatform lbi+    , testSuites = []+    }++-- | Logs test suite results, itemized by test case.+data TestSuiteLog = TestSuiteLog+    { testSuiteName :: String+    , testLogs :: TestLogs+    , logFile :: FilePath    -- path to human-readable log file+    }+    deriving (Read, Show, Eq)++data TestLogs+    = TestLog+        { testName              :: String+        , testOptionsReturned   :: Options+        , testResult            :: Result+        }+    | GroupLogs String [TestLogs]+    deriving (Read, Show, Eq)++-- | Count the number of pass, fail, and error test results in a 'TestLogs'+-- tree.+countTestResults :: TestLogs+                 -> (Int, Int, Int) -- ^ Passes, fails, and errors,+                                    -- respectively.+countTestResults = go (0, 0, 0)+  where+    go (p, f, e) (TestLog { testResult = r }) =+        case r of+            Pass -> (p + 1, f, e)+            Fail _ -> (p, f + 1, e)+            Error _ -> (p, f, e + 1)+    go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts++-- | From a 'TestSuiteLog', determine if the test suite passed.+suitePassed :: TestLogs -> Bool+suitePassed l =+    case countTestResults l of+        (_, 0, 0) -> True+        _ -> False++-- | From a 'TestSuiteLog', determine if the test suite failed.+suiteFailed :: TestLogs -> Bool+suiteFailed l =+    case countTestResults l of+        (_, 0, _) -> False+        _ -> True++-- | From a 'TestSuiteLog', determine if the test suite encountered errors.+suiteError :: TestLogs -> Bool+suiteError l =+    case countTestResults l of+        (_, _, 0) -> False+        _ -> True++resultString :: TestLogs -> String+resultString l | suiteError l = "error"+               | suiteFailed l = "fail"+               | otherwise = "pass"++testSuiteLogPath :: PathTemplate+                 -> PD.PackageDescription+                 -> LBI.LocalBuildInfo+                 -> String -- ^ test suite name+                 -> TestLogs -- ^ test suite results+                 -> FilePath+testSuiteLogPath template pkg_descr lbi name result =+    fromPathTemplate $ substPathTemplate env template+    where+        env = initialPathTemplateEnv+                (PD.package pkg_descr) (LBI.localLibraryName lbi)+                (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi)+                ++  [ (TestSuiteNameVar, toPathTemplate name)+                    , (TestSuiteResultVar, toPathTemplate $ resultString result)+                    ]++-- | Print a summary to the console after all test suites have been run+-- indicating the number of successful test suites and cases.  Returns 'True' if+-- all test suites passed and 'False' otherwise.+summarizePackage :: Verbosity -> PackageLog -> IO Bool+summarizePackage verbosity packageLog = do+    let counts = map (countTestResults . testLogs) $ testSuites packageLog+        (passed, failed, errors) = foldl1 addTriple counts+        totalCases = passed + failed + errors+        passedSuites = length+                       $ filter (suitePassed . testLogs)+                       $ testSuites packageLog+        totalSuites = length $ testSuites packageLog+    notice verbosity $ show passedSuites ++ " of " ++ show totalSuites+        ++ " test suites (" ++ show passed ++ " of "+        ++ show totalCases ++ " test cases) passed."+    return $! passedSuites == totalSuites+  where+    addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2)++-- | Print a summary of a single test case's result to the console, supressing+-- output for certain verbosity or test filter levels.+summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO ()+summarizeTest _ _ (GroupLogs {}) = return ()+summarizeTest verbosity details t =+    when shouldPrint $ notice verbosity $ "Test case " ++ testName t+        ++ ": " ++ show (testResult t)+    where shouldPrint = (details > Never) && (notPassed || details == Always)+          notPassed = testResult t /= Pass++-- | Print a summary of the test suite's results on the console, suppressing+-- output for certain verbosity or test filter levels.+summarizeSuiteFinish :: TestSuiteLog -> String+summarizeSuiteFinish testLog = unlines+    [ "Test suite " ++ testSuiteName testLog ++ ": " ++ resStr+    , "Test suite logged to: " ++ logFile testLog+    ]+    where resStr = map toUpper (resultString $ testLogs testLog)++summarizeSuiteStart :: String -> String+summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n"

cabal/Cabal/Distribution/Simple/UHC.hs view

@@ -2,6 +2,7 @@ -- | -- Module      :  Distribution.Simple.UHC -- Copyright   :  Andres Loeh 2009+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -13,39 +14,6 @@ -- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for -- inspiration on how to design this module. -{--Copyright (c) 2009, Andres Loeh-Copyright (c) 2003-2005, Isaac Jones-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. -}- module Distribution.Simple.UHC (     configure, getInstalledPackages,     buildLib, buildExe, installLib, registerPackage@@ -56,7 +24,7 @@ import qualified Data.Map as M ( empty ) import Distribution.Compat.ReadP import Distribution.InstalledPackageInfo-import Distribution.Package+import Distribution.Package hiding (installedPackageId) import Distribution.PackageDescription import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler as C@@ -86,6 +54,8 @@    let comp = Compiler {                compilerId         =  CompilerId UHC uhcVersion,+               compilerAbiTag     =  C.NoAbiTag,+               compilerCompat     =  [],                compilerLanguages  =  uhcLanguages,                compilerExtensions =  uhcLanguageExtensions,                compilerProperties =  M.empty@@ -118,7 +88,7 @@      (FlexibleInstances,            alwaysOn)]  getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration-                     -> IO PackageIndex+                     -> IO InstalledPackageIndex getInstalledPackages verbosity comp packagedbs conf = do   let compilerid = compilerId comp   systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram conf ["--meta-pkgdir-system"]@@ -150,7 +120,7 @@     UserPackageDB           ->  [ user ]     SpecificPackageDB path  ->  [ path ] --- | Hack to add version numbers to UHC-builtin packages. This should sooner or+-- | Hack to add version numbers to UHC-built-in packages. This should sooner or -- later be fixed on the UHC side. addBuiltinVersions :: String -> String {-@@ -247,6 +217,8 @@   ++ ["-i" ++ odir]   ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]   ++ ["-i" ++ autogenModulesDir lbi]+     -- cpp options+  ++ ["--optP=" ++ opt | opt <- cppOptions bi]      -- output path   ++ ["--odir=" ++ odir]      -- optimization@@ -270,7 +242,7 @@     -- putStrLn $ "built: " ++ builtDir     installDirectoryContents verbosity (builtDir </> display (packageId pkg)) targetDir --- currently hardcoded UHC code generator and variant to use+-- currently hard-coded UHC code generator and variant to use uhcTarget, uhcTargetVariant :: String uhcTarget        = "bc" uhcTargetVariant = "plain"

cabal/Cabal/Distribution/Simple/UserHooks.hs view

@@ -2,6 +2,7 @@ -- | -- Module      :  Distribution.Simple.UserHooks -- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -22,36 +23,6 @@ -- various phases because it would involve changing the types of the -- corresponding hook. At some point it will have to be replaced. -{- 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. -}- module Distribution.Simple.UserHooks (         UserHooks(..), Args,         emptyUserHooks,@@ -100,7 +71,7 @@     -- |Hook to run before build command.  Second arg indicates verbosity level.     preBuild  :: Args -> BuildFlags -> IO HookedBuildInfo, -    -- |Over-ride this hook to gbet different behavior during build.+    -- |Over-ride this hook to get different behavior during build.     buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (),     -- |Hook to run after build command.  Second arg indicates verbosity level.     postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (),@@ -173,7 +144,7 @@     -- |Hook to run before test command.     preTest :: Args -> TestFlags -> IO HookedBuildInfo,     -- |Over-ride this hook to get different behavior during test.-    testHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (),+    testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (),     -- |Hook to run after test command.     postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (), @@ -229,7 +200,7 @@       haddockHook  = ru,       postHaddock  = ru,       preTest  = rn',-      testHook = ru,+      testHook = \_ -> ru,       postTest = ru,       preBench = rn',       benchHook = \_ -> ru,

cabal/Cabal/Distribution/Simple/Utils.hs view

@@ -1,8 +1,9 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Utils -- Copyright   :  Isaac Jones, Simon Marlow 2003-2004+-- License     :  BSD3 --                portions Copyright (c) 2007, Galois Inc. -- -- Maintainer  :  cabal-devel@haskell.org@@ -14,36 +15,6 @@ -- has low level functions for running programs, a bunch of wrappers for -- various directory and file functions that do extra logging. -{- 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. -}- module Distribution.Simple.Utils (         cabalVersion, @@ -53,6 +24,7 @@         topHandler, topHandlerWith,         warn, notice, setupMessage, info, debug,         debugNoWrap, chattyTry,+        printRawCommandAndArgs, printRawCommandAndArgsAndEnv,          -- * running programs         rawSystemExit,@@ -82,6 +54,7 @@         installExecutableFiles,         installMaybeExecutableFiles,         installDirectoryContents,+        copyDirectoryRecursive,          -- * File permissions         doesExecutableExist,@@ -90,18 +63,21 @@          -- * file names         currentDir,+        shortRelativePath,          -- * finding files         findFile,         findFirstFile,         findFileWithExtension,         findFileWithExtension',+        findAllFilesWithExtension,         findModuleFile,         findModuleFiles,         getDirectoryContentsRecursive,          -- * environment variables         isInSearchPath,+        addLibraryPath,          -- * simple file globbing         matchFileGlob,@@ -138,12 +114,23 @@         writeUTF8File,         normaliseLineEndings, +        -- * BOM+        startsWithBOM,+        fileHasBOM,+        ignoreBOM,+         -- * generic utils+        dropWhileEndLE,+        takeWhileEndLE,         equating,         comparing,         isInfixOf,         intercalate,         lowercase,+        listUnion,+        listUnionRight,+        ordNub,+        ordNubRight,         wrapText,         wrapLine,   ) where@@ -152,14 +139,19 @@     ( join, when, unless, filterM ) import Control.Concurrent.MVar     ( newEmptyMVar, putMVar, takeMVar )-import Data.List-  ( nub, unfoldr, isPrefixOf, tails, intercalate )-import Data.Char as Char-    ( toLower, chr, ord ) import Data.Bits     ( Bits((.|.), (.&.), shiftL, shiftR) )+import Data.Char as Char+    ( isDigit, toLower, chr, ord )+import Data.Foldable+    ( traverse_ )+import Data.List+    ( nub, unfoldr, isPrefixOf, tails, intercalate )+import Data.Typeable+    ( cast ) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import qualified Data.Set as Set  import System.Directory     ( Permissions(executable), getDirectoryContents, getPermissions@@ -171,14 +163,15 @@     ( exitWith, ExitCode(..) ) import System.FilePath     ( normalise, (</>), (<.>)-    , getSearchPath, takeDirectory, splitFileName-    , splitExtension, splitExtensions, splitDirectories )+    , getSearchPath, joinPath, takeDirectory, splitFileName+    , splitExtension, splitExtensions, splitDirectories+    , searchPathSeparator ) import System.Directory     ( createDirectory, renameFile, removeDirectoryRecursive ) import System.IO-    ( Handle, openFile, openBinaryFile, openBinaryTempFile+    ( Handle, openFile, openBinaryFile, openBinaryTempFileWithDefaultPermissions     , IOMode(ReadMode), hSetBinaryMode-    , hGetContents, stdin, stderr, stdout, hPutStr, hFlush, hClose )+    , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) import System.IO.Error as IO.Error     ( isDoesNotExistError, isAlreadyExistsError     , ioeSetFileName, ioeGetFileName, ioeGetErrorString )@@ -194,27 +187,18 @@     ( PackageIdentifier ) import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName+import Distribution.System+    ( OS (..) ) import Distribution.Version     (Version(..))  import Control.Exception (IOException, evaluate, throwIO)-import System.Process (rawSystem)-import qualified System.Process as Process (CreateProcess(..))- import Control.Concurrent (forkIO)-import System.Process (runInteractiveProcess, waitForProcess, proc,-                       StdStream(..))-#if __GLASGOW_HASKELL__ >= 702-import System.Process (showCommandForUser)-#endif--#ifndef mingw32_HOST_OS-import System.Posix.Signals (installHandler, sigINT, sigQUIT, Handler(..))-import System.Process.Internals (defaultSignal, runGenProcess_)-#else-import System.Process (createProcess)-#endif-+import qualified System.Process as Process+         ( CreateProcess(..), StdStream(..), proc)+import System.Process+         ( createProcess, rawSystem, runInteractiveProcess+         , showCommandForUser, waitForProcess) import Distribution.Compat.CopyFile          ( copyFile, copyOrdinaryFile, copyExecutableFile          , setFileOrdinary, setFileExecutable, setDirOrdinary )@@ -253,24 +237,49 @@ die :: String -> IO a die msg = ioError (userError msg) -topHandlerWith :: (Exception.IOException -> IO a) -> IO a -> IO a-topHandlerWith cont prog = catchIO prog handle+topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a+topHandlerWith cont prog =+    Exception.catches prog [+        Exception.Handler rethrowAsyncExceptions+      , Exception.Handler rethrowExitStatus+      , Exception.Handler handle+      ]   where-    handle ioe = do+    -- Let async exceptions rise to the top for the default top-handler+    rethrowAsyncExceptions :: Exception.AsyncException -> IO a+    rethrowAsyncExceptions = throwIO++    -- ExitCode gets thrown asynchronously too, and we don't want to print it+    rethrowExitStatus :: ExitCode -> IO a+    rethrowExitStatus = throwIO++    -- Print all other exceptions+    handle :: Exception.SomeException -> IO a+    handle se = do       hFlush stdout       pname <- getProgName-      hPutStr stderr (mesage pname)-      cont ioe-      where-        mesage pname = wrapText (pname ++ ": " ++ file ++ detail)-        file         = case ioeGetFileName ioe of-                         Nothing   -> ""-                         Just path -> path ++ location ++ ": "-        location     = case ioeGetLocation ioe of-                         l@(n:_) | n >= '0' && n <= '9' -> ':' : l-                         _                              -> ""-        detail       = ioeGetErrorString ioe+      hPutStr stderr (message pname se)+      cont se +    message :: String -> Exception.SomeException -> String+    message pname (Exception.SomeException se) =+      case cast se :: Maybe Exception.IOException of+        Just ioe ->+          let file         = case ioeGetFileName ioe of+                               Nothing   -> ""+                               Just path -> path ++ location ++ ": "+              location     = case ioeGetLocation ioe of+                               l@(n:_) | Char.isDigit n -> ':' : l+                               _                        -> ""+              detail       = ioeGetErrorString ioe+          in wrapText (pname ++ ": " ++ file ++ detail)+        Nothing ->+#if __GLASGOW_HASKELL__ < 710+          show se+#else+          Exception.displayException se+#endif+ topHandler :: IO a -> IO a topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog @@ -372,62 +381,23 @@   unless (res == ExitSuccess) $ exitWith res  printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()-printRawCommandAndArgs verbosity path args- | verbosity >= deafening = print (path, args)- | verbosity >= verbose   =-#if __GLASGOW_HASKELL__ >= 702-                            putStrLn $ showCommandForUser path args-#else-                            putStrLn $ unwords (path : args)-#endif- | otherwise              = return ()+printRawCommandAndArgs verbosity path args =+    printRawCommandAndArgsAndEnv verbosity path args Nothing  printRawCommandAndArgsAndEnv :: Verbosity                              -> FilePath                              -> [String]-                             -> [(String, String)]+                             -> Maybe [(String, String)]                              -> IO ()-printRawCommandAndArgsAndEnv verbosity path args env- | verbosity >= deafening = do putStrLn ("Environment: " ++ show env)-                               print (path, args)- | verbosity >= verbose   = putStrLn $ unwords (path : args)+printRawCommandAndArgsAndEnv verbosity path args menv+ | verbosity >= deafening = do+       traverse_ (putStrLn . ("Environment: " ++) . show) menv+       print (path, args)+ | verbosity >= verbose   = putStrLn $ showCommandForUser path args  | otherwise              = return ()  --- This is taken directly from the process package.--- The reason we need it is that runProcess doesn't handle ^C in the same--- way that rawSystem handles it, but rawSystem doesn't allow us to pass--- an environment.-syncProcess :: String -> Process.CreateProcess -> IO ExitCode-#if mingw32_HOST_OS-syncProcess _fun c = do-  (_,_,_,p) <- createProcess c-  waitForProcess p-#else-syncProcess fun c = do-  -- The POSIX version of system needs to do some manipulation of signal-  -- handlers.  Since we're going to be synchronously waiting for the child,-  -- we want to ignore ^C in the parent, but handle it the default way-  -- in the child (using SIG_DFL isn't really correct, it should be the-  -- original signal handler, but the GHC RTS will have already set up-  -- its own handler and we don't want to use that).-  r <- Exception.bracket (installHandlers) (restoreHandlers) $-       (\_ -> do (_,_,_,p) <- runGenProcess_ fun c-                              (Just defaultSignal) (Just defaultSignal)-                 waitForProcess p)-  return r-    where-      installHandlers = do-        old_int  <- installHandler sigINT  Ignore Nothing-        old_quit <- installHandler sigQUIT Ignore Nothing-        return (old_int, old_quit)-      restoreHandlers (old_int, old_quit) = do-        _ <- installHandler sigINT  old_int Nothing-        _ <- installHandler sigQUIT old_quit Nothing-        return ()-#endif  /* mingw32_HOST_OS */---- Exit with the same exitcode if the subcommand fails+-- Exit with the same exit code if the subcommand fails rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () rawSystemExit verbosity path args = do   printRawCommandAndArgs verbosity path args@@ -452,10 +422,19 @@                      -> [(String, String)]                      -> IO () rawSystemExitWithEnv verbosity path args env = do-    printRawCommandAndArgsAndEnv verbosity path args env+    printRawCommandAndArgsAndEnv verbosity path args (Just env)     hFlush stdout-    exitcode <- syncProcess "rawSystemExitWithEnv" (proc path args)-                { Process.env = Just env }+    (_,_,_,ph) <- createProcess $+                  (Process.proc path args) { Process.env = (Just env)+#ifdef MIN_VERSION_process+#if MIN_VERSION_process(1,2,0)+-- delegate_ctlc has been added in process 1.2, and we still want to be able to+-- bootstrap GHC on systems not having that version+                                           , Process.delegate_ctlc = True+#endif+#endif+                                           }+    exitcode <- waitForProcess ph     unless (exitcode == ExitSuccess) $ do         debug verbosity $ path ++ " returned " ++ show exitcode         exitWith exitcode@@ -471,29 +450,29 @@                    -> Maybe Handle  -- ^ stderr                    -> IO ExitCode rawSystemIOWithEnv verbosity path args mcwd menv inp out err = do-    maybe (printRawCommandAndArgs       verbosity path args)-          (printRawCommandAndArgsAndEnv verbosity path args) menv+    printRawCommandAndArgsAndEnv verbosity path args menv     hFlush stdout-    exitcode <- syncProcess "rawSystemIOWithEnv" (proc path args)-                { Process.cwd     = mcwd-                , Process.env     = menv-                , Process.std_in  = mbToStd inp-                , Process.std_out = mbToStd out-                , Process.std_err = mbToStd err }-                `Exception.finally` (mapM_ maybeClose [inp, out, err])+    (_,_,_,ph) <- createProcess $+                  (Process.proc path args) { Process.cwd           = mcwd+                                           , Process.env           = menv+                                           , Process.std_in        = mbToStd inp+                                           , Process.std_out       = mbToStd out+                                           , Process.std_err       = mbToStd err+#ifdef MIN_VERSION_process+#if MIN_VERSION_process(1,2,0)+-- delegate_ctlc has been added in process 1.2, and we still want to be able to+-- bootstrap GHC on systems not having that version+                                           , Process.delegate_ctlc = True+#endif+#endif+                                           }+    exitcode <- waitForProcess ph     unless (exitcode == ExitSuccess) $ do       debug verbosity $ path ++ " returned " ++ show exitcode     return exitcode   where-  -- Also taken from System.Process-  maybeClose :: Maybe Handle -> IO ()-  maybeClose (Just  hdl)-    | hdl /= stdin && hdl /= stdout && hdl /= stderr = hClose hdl-  maybeClose _ = return ()--  mbToStd :: Maybe Handle -> StdStream-  mbToStd Nothing    = Inherit-  mbToStd (Just hdl) = UseHandle hdl+    mbToStd :: Maybe Handle -> Process.StdStream+    mbToStd = maybe Process.Inherit Process.UseHandle  -- | Run a command and return its output. --@@ -609,7 +588,7 @@   return version  --- | Like the unix xargs program. Useful for when we've got very long command+-- | Like the Unix xargs program. Useful for when we've got very long command -- lines that might overflow an OS limit on command line length and so you -- need to invoke a command multiple times to get all the args in. --@@ -666,6 +645,16 @@     | path <- nub searchPath     , ext <- nub extensions ] +findAllFilesWithExtension :: [String]+                          -> [FilePath]+                          -> FilePath+                          -> IO [FilePath]+findAllFilesWithExtension extensions searchPath basename =+  findAllFiles id+    [ path </> basename <.> ext+    | path <- nub searchPath+    , ext <- nub extensions ]+ -- | Like 'findFileWithExtension' but returns which element of the search path -- the file was found in, and the file path relative to that base directory. --@@ -687,6 +676,9 @@                                 then return (Just x)                                 else findFirst xs +findAllFiles :: (a -> FilePath) -> [a] -> IO [a]+findAllFiles file = filterM (doesFileExist . file)+ -- | Finds the files corresponding to a list of Haskell module names. -- -- As 'findModuleFile' but for a list of module names.@@ -755,6 +747,25 @@ isInSearchPath :: FilePath -> IO Bool isInSearchPath path = fmap (elem path) getSearchPath +addLibraryPath :: OS+               -> [FilePath]+               -> [(String,String)]+               -> [(String,String)]+addLibraryPath os paths = addEnv+  where+    pathsString = intercalate [searchPathSeparator] paths+    ldPath = case os of+               OSX -> "DYLD_LIBRARY_PATH"+               _   -> "LD_LIBRARY_PATH"++    addEnv [] = [(ldPath,pathsString)]+    addEnv ((key,value):xs)+      | key == ldPath =+          if null value+             then (key,pathsString):xs+             else (key,value ++ (searchPathSeparator:pathsString)):xs+      | otherwise     = (key,value):addEnv xs+ ---------------- -- File globbing @@ -854,7 +865,7 @@           -- createDirectory (and indeed POSIX mkdir) does not distinguish           -- between a dir already existing and a file already existing. So we           -- check for it here. Unfortunately there is a slight race condition-          -- here, but we think it is benign. It could report an exeption in+          -- here, but we think it is benign. It could report an exception in           -- the case that the dir did exist but another process deletes the           -- directory and creates a file in its place before we can check           -- that the directory did indeed exist.@@ -982,6 +993,13 @@   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+  info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")+  srcFiles <- getDirectoryContentsRecursive srcDir+  copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f) | f <- srcFiles ]+ ------------------- -- File permissions @@ -1085,7 +1103,7 @@  -- | Writes a file atomically. ----- The file is either written sucessfully or an IO exception is raised and+-- The file is either written successfully or an IO exception is raised and -- the original file is left unchanged. -- -- On windows it is not possible to delete a file that is open by a process.@@ -1095,7 +1113,7 @@ writeFileAtomic targetPath content = do   let (targetDir, targetFile) = splitFileName targetPath   Exception.bracketOnError-    (openBinaryTempFile targetDir $ targetFile <.> "tmp")+    (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")     (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)     (\(tmpPath, handle) -> do         BS.hPut handle content@@ -1125,6 +1143,16 @@ currentDir :: FilePath currentDir = "." +shortRelativePath :: FilePath -> FilePath -> FilePath+shortRelativePath from to =+    case dropCommonPrefix (splitDirectories from) (splitDirectories to) of+        (stuff, path) -> joinPath (map (const "..") stuff ++ path)+  where+    dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a])+    dropCommonPrefix (x:xs) (y:ys)+        | x == y    = dropCommonPrefix xs ys+    dropCommonPrefix xs ys = (xs,ys)+ -- ------------------------------------------------------------ -- * Finding the description file -- ------------------------------------------------------------@@ -1256,6 +1284,16 @@                  : toUTF8 cs   where w = ord c +-- | Whether BOM is at the beginning of the input+startsWithBOM :: String -> Bool+startsWithBOM ('\xFEFF':_) = True+startsWithBOM _            = False++-- | Check whether a file has Unicode byte order mark (BOM).+fileHasBOM :: FilePath -> IO Bool+fileHasBOM f = fmap (startsWithBOM . fromUTF8)+             . hGetContents =<< openBinaryFile f ReadMode+ -- | Ignore a Unicode byte order mark (BOM) at the beginning of the input -- ignoreBOM :: String -> String@@ -1292,12 +1330,90 @@ normaliseLineEndings :: String -> String normaliseLineEndings [] = [] normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows-normaliseLineEndings ('\r':s)      = '\n' : normaliseLineEndings s -- old osx+normaliseLineEndings ('\r':s)      = '\n' : normaliseLineEndings s -- old OS X normaliseLineEndings (  c :s)      =   c  : normaliseLineEndings s  -- ------------------------------------------------------------ -- * Common utils -- ------------------------------------------------------------++-- | @dropWhileEndLE p@ is equivalent to @reverse . dropWhile p . reverse@, but+-- quite a bit faster. The difference between "Data.List.dropWhileEnd" and this+-- version is that the one in "Data.List" is strict in elements, but spine-lazy,+-- while this one is spine-strict but lazy in elements. That's what @LE@ stands+-- for - "lazy in elements".+--+-- Example:+--+-- @+-- > tail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1]+-- *** Exception: Prelude.undefined+-- > tail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1]+-- [5,4,3]+-- > take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined]+-- [5,4,3]+-- > take 3 $ dropWhileEndLE (<3) [5, 4, 3, 2, 1, undefined]+-- *** Exception: Prelude.undefined+-- @+dropWhileEndLE :: (a -> Bool) -> [a] -> [a]+dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) []++-- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but+-- is usually faster (as well as being easier to read).+takeWhileEndLE :: (a -> Bool) -> [a] -> [a]+takeWhileEndLE p = fst . foldr go ([], False)+  where+    go x (rest, done)+      | not done && p x = (x:rest, False)+      | otherwise = (rest, True)++-- | Like "Data.List.nub", but has @O(n log n)@ complexity instead of+-- @O(n^2)@. Code for 'ordNub' and 'listUnion' taken from Niklas Hambüchen's+-- <http://github.com/nh2/haskell-ordnub ordnub> package.+ordNub :: (Ord a) => [a] -> [a]+ordNub l = go Set.empty l+  where+    go _ [] = []+    go s (x:xs) = if x `Set.member` s then go s xs+                                      else x : go (Set.insert x s) xs++-- | Like "Data.List.union", but has @O(n log n)@ complexity instead of+-- @O(n^2)@.+listUnion :: (Ord a) => [a] -> [a] -> [a]+listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b)+  where+    aSet = Set.fromList a++-- | A right-biased version of 'ordNub'.+--+-- Example:+--+-- @+-- > ordNub [1,2,1]+-- [1,2]+-- > ordNubRight [1,2,1]+-- [2,1]+-- @+ordNubRight :: (Ord a) => [a] -> [a]+ordNubRight = fst . foldr go ([], Set.empty)+  where+    go x p@(l, s) = if x `Set.member` s then p+                                        else (x:l, Set.insert x s)++-- | A right-biased version of 'listUnion'.+--+-- Example:+--+-- @+-- > listUnion [1,2,3,4,3] [2,1,1]+-- [1,2,3,4,3]+-- > listUnionRight [1,2,3,4,3] [2,1,1]+-- [4,3,2,1,1]+-- @+listUnionRight :: (Ord a) => [a] -> [a] -> [a]+listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b+  where+    bSet = Set.fromList b  equating :: Eq a => (b -> a) -> b -> b -> Bool equating p x y = p x == p y

cabal/Cabal/Distribution/System.hs view

@@ -1,4 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.System@@ -32,11 +34,13 @@ import qualified System.Info (os, arch) import qualified Data.Char as Char (toLower, isAlphaNum) +import Distribution.Compat.Binary (Binary) import Data.Data (Data) import Data.Typeable (Typeable) import Data.Maybe (fromMaybe, listToMaybe) import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse+import GHC.Generics (Generic) import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>)) @@ -45,13 +49,13 @@ -- The reason we have multiple ways to do the classification is because there -- are two situations where we need to do it. ----- For parsing os and arch names in .cabal files we really want everyone to be+-- For parsing OS and arch names in .cabal files we really want everyone to be -- referring to the same or or arch by the same name. Variety is not a virtue -- in this case. We don't mind about case though. -- -- For the System.Info.os\/arch different Haskell implementations use different -- names for the same or\/arch. Also they tend to distinguish versions of an--- os\/arch which we just don't care about.+-- OS\/arch which we just don't care about. -- -- The 'Compat' classification allows us to recognise aliases that are already -- in common use but it allows us to distinguish them from the canonical name@@ -64,32 +68,36 @@ -- ------------------------------------------------------------  data OS = Linux | Windows | OSX        -- tier 1 desktop OSs-        | FreeBSD | OpenBSD | NetBSD   -- other free unix OSs+        | FreeBSD | OpenBSD | NetBSD   -- other free Unix OSs+        | DragonFly         | Solaris | AIX | HPUX | IRIX  -- ageing Unix OSs         | HaLVM                        -- bare metal / VMs / hypervisors-        | IOS                          -- iOS+        | Hurd                         -- GNU's microkernel+        | IOS  | Android               -- mobile OSs+        | Ghcjs         | OtherOS String-  deriving (Eq, Ord, Show, Read, Typeable, Data)+  deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) ---TODO: decide how to handle Android and iOS.--- They are like Linux and OSX but with some differences.--- Should they be separate from linux/osx, or a subtype?--- e.g. should we have os(linux) && os(android) true simultaneously?+instance Binary OS  knownOSs :: [OS] knownOSs = [Linux, Windows, OSX-           ,FreeBSD, OpenBSD, NetBSD+           ,FreeBSD, OpenBSD, NetBSD, DragonFly            ,Solaris, AIX, HPUX, IRIX            ,HaLVM-           ,IOS]+           ,Hurd+           ,IOS, Android+           ,Ghcjs]  osAliases :: ClassificationStrictness -> OS -> [String]-osAliases Permissive Windows = ["mingw32", "cygwin32"]+osAliases Permissive Windows = ["mingw32", "win32", "cygwin32"] osAliases Compat     Windows = ["mingw32", "win32"] osAliases _          OSX     = ["darwin"]-osAliases _          IOS     = ["ios"]+osAliases _          Hurd    = ["gnu"] osAliases Permissive FreeBSD = ["kfreebsdgnu"]+osAliases Compat     FreeBSD = ["kfreebsdgnu"] osAliases Permissive Solaris = ["solaris2"]+osAliases Compat     Solaris = ["solaris2"] osAliases _          _       = []  instance Text OS where@@ -118,15 +126,19 @@           | IA64  | S390           | Alpha | Hppa   | Rs6000           | M68k  | Vax+          | JavaScript           | OtherArch String-  deriving (Eq, Ord, Show, Read, Typeable, Data)+  deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) +instance Binary Arch+ knownArches :: [Arch] knownArches = [I386, X86_64, PPC, PPC64, Sparc               ,Arm, Mips, SH               ,IA64, S390               ,Alpha, Hppa, Rs6000-              ,M68k, Vax]+              ,M68k, Vax+              ,JavaScript]  archAliases :: ClassificationStrictness -> Arch -> [String] archAliases Strict _     = []@@ -160,7 +172,9 @@ -- ------------------------------------------------------------  data Platform = Platform Arch OS-  deriving (Eq, Ord, Show, Read, Typeable, Data)+  deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)++instance Binary Platform  instance Text Platform where   disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os

cabal/Cabal/Distribution/TestSuite.hs view

@@ -2,42 +2,13 @@ -- | -- Module      :  Distribution.TestSuite -- Copyright   :  Thomas Tuegel 2010+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable -- -- This module defines the detailed test suite interface which makes it -- possible to expose individual tests to Cabal or other test agents.--{- 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. -}  module Distribution.TestSuite     ( TestInstance(..)

cabal/Cabal/Distribution/Text.hs view

@@ -57,8 +57,9 @@    parse = do       branch <- Parse.sepBy1 digits (Parse.char '.')-      tags   <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum)-      return (Version branch tags)  --TODO: should we ignore the tags?+                -- allow but ignore tags:+      _tags  <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum)+      return (Version branch [])     where       digits = do         first <- Parse.satisfy Char.isDigit

+ cabal/Cabal/Distribution/Utils/NubList.hs view

@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}+module Distribution.Utils.NubList+    ( NubList    -- opaque+    , toNubList  -- smart construtor+    , fromNubList+    , overNubList++    , NubListR+    , toNubListR+    , fromNubListR+    , overNubListR+    ) where++import Distribution.Compat.Binary+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid+#endif++import Distribution.Simple.Utils (ordNub, listUnion, ordNubRight, listUnionRight)++import qualified Text.Read as R++-- | NubList : A de-duplicated list that maintains the original order.+newtype NubList a =+    NubList { fromNubList :: [a] }+    deriving Eq++-- NubList assumes that nub retains the list order while removing duplicate+-- elements (keeping the first occurence). Documentation for "Data.List.nub"+-- does not specifically state that ordering is maintained so we will add a test+-- for that to the test suite.++-- | Smart constructor for the NubList type.+toNubList :: Ord a => [a] -> NubList a+toNubList list = NubList $ ordNub list++-- | Lift a function over lists to a function over NubLists.+overNubList :: Ord a => ([a] -> [a]) -> NubList a -> NubList a+overNubList f (NubList list) = toNubList . f $ list++-- | Monoid operations on NubLists.+-- For a valid Monoid instance we need to satistfy the required monoid laws;+-- identity, associativity and closure.+--+-- Identity : by inspection:+--      mempty `mappend` NubList xs == NubList xs `mappend` mempty+--+-- Associativity : by inspection:+--      (NubList xs `mappend` NubList ys) `mappend` NubList zs+--      == NubList xs `mappend` (NubList ys `mappend` NubList zs)+--+-- Closure : appending two lists of type a and removing duplicates obviously+-- does not change the type.++instance Ord a => Monoid (NubList a) where+    mempty = NubList []+    mappend (NubList xs) (NubList ys) = NubList $ xs `listUnion` ys++instance Show a => Show (NubList a) where+    show (NubList list) = show list++instance (Ord a, Read a) => Read (NubList a) where+    readPrec = readNubList toNubList++-- | Helper used by NubList/NubListR's Read instances.+readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a)+readNubList toList = R.parens . R.prec 10 $ fmap toList R.readPrec++-- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we+-- just pull off constructor and put the list. For 'get', we get the list and+-- make a 'NubList' out of it using 'toNubList'.+instance (Ord a, Binary a) => Binary (NubList a) where+    put (NubList l) = put l+    get = fmap toNubList get++-- | NubListR : A right-biased version of 'NubList'. That is @toNubListR+-- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@,+-- unlike the normal 'NubList', which is left-biased. Built on top of+-- 'ordNubRight' and 'listUnionRight'.+newtype NubListR a =+    NubListR { fromNubListR :: [a] }+    deriving Eq++-- | Smart constructor for the NubListR type.+toNubListR :: Ord a => [a] -> NubListR a+toNubListR list = NubListR $ ordNubRight list++-- | Lift a function over lists to a function over NubListRs.+overNubListR :: Ord a => ([a] -> [a]) -> NubListR a -> NubListR a+overNubListR f (NubListR list) = toNubListR . f $ list++instance Ord a => Monoid (NubListR a) where+  mempty = NubListR []+  mappend (NubListR xs) (NubListR ys) = NubListR $ xs `listUnionRight` ys++instance Show a => Show (NubListR a) where+  show (NubListR list) = show list++instance (Ord a, Read a) => Read (NubListR a) where+    readPrec = readNubList toNubListR

cabal/Cabal/Distribution/Verbosity.hs view

@@ -1,7 +1,10 @@+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Verbosity -- Copyright   :  Ian Lynagh 2007+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -10,38 +13,7 @@ -- verbosity levels from 'silent', 'normal', 'verbose' up to 'deafening'. This -- is used for deciding what logging messages to print. --- Verbosity for Cabal functions--{- Copyright (c) 2007, Ian Lynagh-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. -}+-- Verbosity for Cabal functions.  module Distribution.Verbosity (   -- * Verbosity@@ -52,11 +24,15 @@   showForCabal, showForGHC  ) where +import Distribution.Compat.Binary (Binary) import Data.List (elemIndex) import Distribution.ReadE+import GHC.Generics  data Verbosity = Silent | Normal | Verbose | Deafening-    deriving (Show, Read, Eq, Ord, Enum, Bounded)+    deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded)++instance Binary Verbosity  -- We shouldn't print /anything/ unless an error occurs in silent mode silent :: Verbosity

cabal/Cabal/Distribution/Version.hs view

@@ -1,9 +1,16 @@-{-# LANGUAGE CPP, DeriveDataTypeable, StandaloneDeriving #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+#if __GLASGOW_HASKELL__ < 707+{-# LANGUAGE StandaloneDeriving #-}+#endif+{-# OPTIONS_GHC -fno-warn-orphans #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Version -- Copyright   :  Isaac Jones, Simon Marlow 2003-2004 --                Duncan Coutts 2008+-- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -12,37 +19,6 @@ -- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data -- types. Version ranges are like @\">= 1.2 && < 2\"@. -{- Copyright (c) 2003-2004, Isaac Jones-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. -}- module Distribution.Version (   -- * Package versions   Version(..),@@ -56,6 +32,7 @@   laterVersion, earlierVersion,   orLaterVersion, orEarlierVersion,   unionVersionRanges, intersectVersionRanges,+  invertVersionRange,   withinVersion,   betweenVersionsInclusive, @@ -67,6 +44,8 @@   simplifyVersionRange,   foldVersionRange,   foldVersionRange',+  hasUpperBound,+  hasLowerBound,    -- ** Modification   removeUpperBound,@@ -92,12 +71,15 @@   mkVersionIntervals,   unionVersionIntervals,   intersectVersionIntervals,+  invertVersionIntervals   ) where +import Distribution.Compat.Binary ( Binary(..) ) import Data.Data        ( Data ) import Data.Typeable    ( Typeable ) import Data.Version     ( Version(..) )+import GHC.Generics     ( Generic )  import Distribution.Text ( Text(..) ) import qualified Distribution.Compat.ReadP as Parse@@ -122,13 +104,26 @@   | UnionVersionRanges     VersionRange VersionRange   | IntersectVersionRanges VersionRange VersionRange   | VersionRangeParens     VersionRange -- just '(exp)' parentheses syntax-  deriving (Show,Read,Eq,Typeable,Data)+  deriving (Data, Eq, Generic, Read, Show, Typeable) +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 +-- 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+ {-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} {-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} {-# DEPRECATED LaterVersion "use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}@@ -150,7 +145,7 @@ -- This can be constructed using any unsatisfiable version range expression, -- for example @> 1 && < 1@. ----- > withinRange v anyVersion = False+-- > withinRange v noVersion = False -- noVersion :: VersionRange noVersion = IntersectVersionRanges (LaterVersion v) (EarlierVersion v)@@ -214,6 +209,15 @@ intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange intersectVersionRanges = IntersectVersionRanges +-- | The inverse of a version range+--+-- >   withinRange v' (invertVersionRange vr)+-- > = not (withinRange v' vr)+--+invertVersionRange :: VersionRange -> VersionRange+invertVersionRange =+    fromVersionIntervals . invertVersionIntervals . VersionIntervals . asVersionIntervals+ -- | The version range @== v.*@. -- -- For example, for version @1.2@, the version range @== 1.2.*@ is the same as@@ -254,7 +258,7 @@  -- | Fold over the basic syntactic structure of a 'VersionRange'. ----- This provides a syntacic view of the expression defining the version range.+-- This provides a syntactic view of the expression defining the version range. -- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented -- in terms of the other basic syntax. --@@ -508,7 +512,7 @@ -- | Directly construct a 'VersionIntervals' from a list of intervals. -- -- Each interval must be non-empty. The sequence must be in increasing order--- and no invervals may overlap or touch. If any of these conditions are not+-- and no intervals may overlap or touch. If any of these conditions are not -- satisfied the function returns @Nothing@. -- mkVersionIntervals :: [VersionInterval] -> Maybe VersionIntervals@@ -686,6 +690,45 @@   where     lowerBound = max lower lower' +invertVersionIntervals :: VersionIntervals+                       -> VersionIntervals+invertVersionIntervals (VersionIntervals xs) =+    case xs of+      -- Empty interval set+      [] -> VersionIntervals [(noLowerBound, NoUpperBound)]+      -- Interval with no lower bound+      ((lb, ub) : more) | lb == noLowerBound -> VersionIntervals $ invertVersionIntervals' ub more+      -- Interval with a lower bound+      ((lb, ub) : more) ->+          VersionIntervals $ (noLowerBound, invertLowerBound lb) : invertVersionIntervals' ub more+    where+      -- Invert subsequent version intervals given the upper bound of+      -- the intervals already inverted.+      invertVersionIntervals' :: UpperBound+                              -> [(LowerBound, UpperBound)]+                              -> [(LowerBound, UpperBound)]+      invertVersionIntervals' NoUpperBound [] = []+      invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)]+      invertVersionIntervals' ub0 [(lb, NoUpperBound)] =+          [(invertUpperBound ub0, invertLowerBound lb)]+      invertVersionIntervals' ub0 ((lb, ub1) : more) =+          (invertUpperBound ub0, invertLowerBound lb)+            : invertVersionIntervals' ub1 more++      invertLowerBound :: LowerBound -> UpperBound+      invertLowerBound (LowerBound v b) = UpperBound v (invertBound b)++      invertUpperBound :: UpperBound -> LowerBound+      invertUpperBound (UpperBound v b) = LowerBound v (invertBound b)+      invertUpperBound NoUpperBound = error "NoUpperBound: unexpected"++      invertBound :: Bound -> Bound+      invertBound ExclusiveBound = InclusiveBound+      invertBound InclusiveBound = ExclusiveBound++      noLowerBound :: LowerBound+      noLowerBound = LowerBound (Version [0] []) InclusiveBound+ ------------------------------- -- Parsing and pretty printing --@@ -702,7 +745,7 @@            (\v _ -> (Disp.text "==" <> dispWild 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, p)   -> (Disp.parens r, p))+           (\(r, _)   -> (Disp.parens r, 0))      where dispWild (Version b _) =                Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))@@ -731,9 +774,11 @@                      return f)         factor = Parse.choice $ parens expr                               : parseAnyVersion+                              : parseNoVersion                               : parseWildcardRange                               : map parseRangeOp rangeOps         parseAnyVersion    = Parse.string "-any" >> return AnyVersion+        parseNoVersion     = Parse.string "-none" >> return noVersion          parseWildcardRange = do           _ <- Parse.string "=="@@ -762,3 +807,32 @@                      (">",  LaterVersion),                      (">=", orLaterVersion),                      ("==", ThisVersion) ]++-- | Does the version range have an upper bound?+--+-- @since 1.24.0.0+hasUpperBound :: VersionRange -> Bool+hasUpperBound AnyVersion = False+hasUpperBound (ThisVersion _) = True+hasUpperBound (LaterVersion _) = False+hasUpperBound (EarlierVersion _) = True+hasUpperBound (WildcardVersion _) = True+hasUpperBound (UnionVersionRanges x y) = hasUpperBound x && hasUpperBound y+hasUpperBound (IntersectVersionRanges x y) = hasUpperBound x || hasUpperBound y+hasUpperBound (VersionRangeParens x) = hasUpperBound x++-- | Does the version range have an explicit lower bound?+--+-- Note: this function only considers the user-specified lower bounds, but not+-- the implicit >=0 lower bound.+--+-- @since 1.24.0.0+hasLowerBound :: VersionRange -> Bool+hasLowerBound AnyVersion = False+hasLowerBound (ThisVersion _) = True+hasLowerBound (LaterVersion _) = True+hasLowerBound (EarlierVersion _) = False+hasLowerBound (WildcardVersion _) = True+hasLowerBound (UnionVersionRanges x y) = hasLowerBound x && hasLowerBound y+hasLowerBound (IntersectVersionRanges x y) = hasLowerBound x || hasLowerBound y+hasLowerBound (VersionRangeParens x) = hasLowerBound x

cabal/Cabal/LICENSE view

@@ -1,7 +1,8 @@-Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren,+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+                         Duncan Coutts, Thomas Schilling,+                         Johan Tibell, Mikhail Glushenkov All rights reserved.  Redistribution and use in source and binary forms, with or without

cabal/Cabal/Language/Haskell/Extension.hs view

@@ -1,44 +1,17 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Language.Haskell.Extension -- Copyright   :  Isaac Jones 2003-2004+-- License     :  BSD3 -- -- Maintainer  :  libraries@haskell.org -- Portability :  portable -- -- Haskell language dialects and extensions -{- 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. -}- module Language.Haskell.Extension (         Language(..),         knownLanguages,@@ -54,8 +27,10 @@ import qualified Text.PrettyPrint as Disp import qualified Data.Char as Char (isAlphaNum) import Data.Array (Array, accumArray, bounds, Ix(inRange), (!))+import Distribution.Compat.Binary (Binary) import Data.Data (Data) import Data.Typeable (Typeable)+import GHC.Generics (Generic)  -- ------------------------------------------------------------ -- * Language@@ -78,8 +53,10 @@    -- | An unknown language, identified by its name.   | UnknownLanguage String-  deriving (Show, Read, Eq, Typeable, Data)+  deriving (Generic, Show, Read, Eq, Typeable, Data) +instance Binary Language+ knownLanguages :: [Language] knownLanguages = [Haskell98, Haskell2010] @@ -106,7 +83,7 @@ -- Note: if you add a new 'KnownExtension': -- -- * also add it to the Distribution.Simple.X.languageExtensions lists---   (where X is each compiler: GHC, JHC, Hugs, NHC)+--   (where X is each compiler: GHC, JHC, LHC, UHC, HaskellSuite) -- -- | This represents language extensions beyond a base 'Language' definition -- (such as 'Haskell98') that are supported by some implementations, usually@@ -126,8 +103,10 @@   -- pragma.   | UnknownExtension String -  deriving (Show, Read, Eq, Typeable, Data)+  deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) +instance Binary Extension+ data KnownExtension =    -- | Allow overlapping class instances, provided there is a unique@@ -152,11 +131,11 @@   -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-overlap>   | IncoherentInstances -  -- | /(deprecated)/ Allows recursive bindings in @do@ blocks, using the @rec@+  -- | /(deprecated)/ Allow recursive bindings in @do@ blocks, using the @rec@   -- keyword. See also 'RecursiveDo'.   | DoRec -  -- | Allows recursive bindings using @mdo@, a variant of @do@.+  -- | Allow recursive bindings using @mdo@, a variant of @do@.   -- @DoRec@ provides a different, preferred syntax.   --   -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#recursive-do-notation>@@ -533,13 +512,13 @@   -- and Josef Svenningsson, from ICFP '04.   | RegularPatterns -  -- | Enables the use of tuple sections, e.g. @(, True)@ desugars into+  -- | Enable the use of tuple sections, e.g. @(, True)@ desugars into   -- @\x -> (x, True)@.   --   -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#tuple-sections>   | TupleSections -  -- | Allows GHC primops, written in C--, to be imported into a Haskell+  -- | Allow GHC primops, written in C--, to be imported into a Haskell   -- file.   | GHCForeignImportPrim @@ -657,7 +636,7 @@   -- * <http://www.haskell.org/haskellwiki/GHC/Data_Parallel_Haskell>   | ParallelArrays -  -- | Enable explicit role annotations, like in (@data T a\@R@).+  -- | Enable explicit role annotations, like in (@type role Foo representational representational@).   --   -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/roles.html>   | RoleAnnotations@@ -668,7 +647,7 @@   -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#overloaded-lists>   | OverloadedLists -  -- | Enables case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled.+  -- | Enable case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled.   --   -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#empty-case>   | EmptyCase@@ -684,12 +663,17 @@   -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#negative-literals>   | NegativeLiterals -  -- | Allows the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'.+  -- | Allow the use of binary integer literal syntax (e.g. @0b11001001@ to denote @201@).   --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#binary-literals>+  | BinaryLiterals++  -- | Allow the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'.+  --   -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#num-decimals>   | NumDecimals -  -- | Enables support for type classes with no type parameter.+  -- | Enable support for type classes with no type parameter.   --   -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#nullary-type-classes>   | NullaryTypeClasses@@ -704,8 +688,36 @@   -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#ambiguity>   | AllowAmbiguousTypes -  deriving (Show, Read, Eq, Enum, Bounded, Typeable, Data)+  -- | Enable @foreign import javascript@.+  | JavaScriptFFI +  -- | Allow giving names to and abstracting over patterns.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#pattern-synonyms>+  | PatternSynonyms++  -- | Allow anonymous placeholders (underscore) inside type signatures.  The+  -- type inference engine will generate a message describing the type inferred+  -- at the hole's location.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#partial-type-signatures>+  | PartialTypeSignatures++  -- | Allow named placeholders written with a leading underscore inside type+  -- signatures.  Wildcards with the same name unify to the same type.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#named-wildcards>+  | NamedWildCards++  -- | Enable @deriving@ for any class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#derive-any-class>+  | DeriveAnyClass++  deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data)++instance Binary KnownExtension+ {-# DEPRECATED knownExtensions    "KnownExtension is an instance of Enum and Bounded, use those instead." #-} knownExtensions :: [KnownExtension]@@ -721,7 +733,7 @@   ] -- NOTE: when adding deprecated extensions that have new alternatives -- we must be careful to make sure that the deprecation messages are--- valid. We must not recomend aliases that cannot be used with older+-- valid. We must not recommend aliases that cannot be used with older -- compilers, perhaps by adding support in Cabal to translate the new -- name to the old one for older compilers. Otherwise we are in danger -- of the scenario in ticket #689.

cabal/Cabal/Makefile view

@@ -1,5 +1,5 @@ -VERSION=1.18.1+VERSION=1.23.0.0  #KIND=devel KIND=rc@@ -7,8 +7,8 @@  PREFIX=/usr/local HC=ghc-GHCFLAGS=-Wall-SSH_USER=$USER+GHCFLAGS=-Wall -threaded+SSH_USER=$(USER)  all: build @@ -29,9 +29,6 @@ 	-mkdir -p dist/setup 	$(HC) $(GHCFLAGS) --make -i. -odir dist/setup -hidir dist/setup Setup.hs -o setup -Setup-nhc:-	hmake -nhc98 -package base -prelude Setup- $(CONFIG_STAMP): setup Cabal.cabal 	./setup configure --with-compiler=$(HC) --prefix=$(PREFIX) @@ -42,19 +39,6 @@ install: $(BUILD_STAMP) 	./setup install -hugsbootstrap:-	rm -rf dist/tmp dist/hugs-	mkdir -p dist/tmp-	mkdir dist/hugs-	cp -r Distribution dist/tmp-	hugs-package dist/tmp dist/hugs-	cp Setup.lhs Cabal.cabal dist/hugs--hugsinstall: hugsbootstrap-	cd dist/hugs && ./Setup.lhs configure --hugs-	cd dist/hugs && ./Setup.lhs build-	cd dist/hugs && ./Setup.lhs install- # documentation...  haddock: $(HADDOCK_STAMP)@@ -112,7 +96,7 @@ 	rm -rf $(DISTLOC) 	mkdir $(DISTLOC) 	tar -xzf $(SDIST_STAMP) -C $(DISTLOC)/-	mkdir $(DISTLOC)/Cabal-$(VERSION)/doc+	mkdir -p $(DISTLOC)/Cabal-$(VERSION)/doc 	cp -r dist/doc/html $(DISTLOC)/Cabal-$(VERSION)/doc/API 	cp -r dist/doc/users-guide $(DISTLOC)/Cabal-$(VERSION)/doc/ 	cp changelog $(DISTLOC)/Cabal-$(VERSION)/@@ -124,8 +108,8 @@ 	@echo "Release fileset prepared: $(DISTLOC)/"  release: $(DIST_STAMP)-	scp -r $(DISTLOC) $(SSH_USER)@haskell.org:/srv/web/haskell.org/cabal/release/cabal-$(VERSION)-	ssh $(SSH_USER)@haskell.org 'cd /srv/web/haskell.org/cabal/release && rm -f $(KIND) && ln -s cabal-$(VERSION) $(KIND)'+	scp -r $(DISTLOC) $(SSH_USER)@haskell.org:/home/web/haskell.org/cabal/release/cabal-$(VERSION)+	ssh $(SSH_USER)@haskell.org 'cd /home/web/haskell.org/cabal/release && rm -f $(KIND) && ln -s cabal-$(VERSION) $(KIND)'  # tags...

− cabal/Cabal/README

@@ -1,179 +0,0 @@-The Cabal library package-=========================--[Cabal home page](http://www.haskell.org/cabal/)--If you also want the `cabal` command line program then you need-the `cabal-install` package in addition to this library.---Installation instructions for the Cabal library-===============================================--If you have the `cabal` program already------------------------------------------In this case it's simple, just--    cabal install--Of course, if you don't have an existing version of the `cabal` program-then to get one you'd first need to install the Cabal library! To avoid-this bootstrapping problem, you can install the Cabal library directly:--Installing as a user (no root or administrator access)---------------------------------------------------------    ghc --make Setup-    ./Setup configure --user-    ./Setup build-    ./Setup install--Note the use of the `--user` flag at the configure step.--Compiling Setup rather than using `runghc Setup` is much faster and works on-Windows. For all packages other than Cabal itself it is fine to use `runghc`.--This will install into `$HOME/.cabal/` on unix and into-`$Documents and Settings\$User\Application Data\cabal\` on Windows-If you want to install elsewhere use the `--prefix=` flag at the-configure step.---Installing as root / Administrator-------------------------------------    ghc --make Setup-    ./Setup configure-    ./Setup build-    sudo ./Setup install--Compiling Setup rather than using `runghc Setup` is much faster and works on-Windows. For all packages other than Cabal itself it is fine to use `runghc`.--This will install into `/usr/local` on unix and on Windows it will-install into `$ProgramFiles/Haskell`. If you want to install-elsewhere use the `--prefix=` flag at the configure step.---Working with older versions of GHC and Cabal-============================================--It is recommended just to leave any pre-existing version of Cabal-installed. In particular it is *essential* to keep the version that-came with GHC itself since other installed packages need it (eg the-"ghc" api package).--Prior to GHC 6.4.2 however, GHC didn't deal particularly well with-having multiple versions of packages installed at once. So if you-are using GHC 6.4.1 or older and you have an older version of Cabal-installed, you probably just want to remove it:--    ghc-pkg unregister Cabal--or if you had Cabal installed just for your user account then:--    ghc-pkg unregister Cabal --user---The `filepath` dependency-=========================--Cabal now uses the `filepath` package so that must be installed first.-GHC-6.6.1 and later come with `filepath` however earlier versions do not by-default. If you do not already have `filepath` then you need to install it. You-can use any existing version of Cabal to do that. If you have neither Cabal or-filepath then it is slightly harder but still possible.--Unpack Cabal and filepath into separate directories. For example:--    tar -xzf filepath-1.1.0.0.tar.gz-    tar -xzf Cabal-1.6.0.0.tar.gz--    # rename to make the following instructions simpler:-    mv filepath-1.1.0.0/ filepath/-    mv Cabal-1.6.0.0/ Cabal/--    cd Cabal-    ghc -i../filepath -cpp --make Setup.hs -o ../filepath/setup-    cd ../filepath/-    ./setup configure --user-    ./setup build-    ./setup install--This installs filepath so you are then in a position to install Cabal by the-normal method.---More Information-================--Please see the web site for the [user guide] and API documentation.-There is some more information available on the [development wiki].--[user guide]:       http://www.haskell.org/cabal/-[development wiki]: http://hackage.haskell.org/trac/hackage/---Bugs-=======--Please report bugs and wish-list items in our [bug tracker].--[bug tracker]: https://github.com/haskell/cabal/issues---Your Help------------To help us in the next round of development work it would be-enormously helpful to know from our users what their most pressing-problems are with Cabal and Hackage. You probably have a favourite-Cabal bug or limitation. Take a look at our [bug tracker]. Make sure-the problem is reported there and properly described. Comment on the-ticket to tell us how much of a problem the bug is for you. Add-yourself to the ticket's cc list so we can discuss requirements and-keep you informed on progress. For feature requests it is very-helpful if there is a description of how you would expect to-interact with the new feature.---Code-=======--You can get the code from the web page; the version control system we-use is very open and welcoming to new developers.--You can get the main development branch:--> darcs get --partial http://darcs.haskell.org/cabal--and you can get the stable 1.6 branch:--> darcs get --partial http://darcs.haskell.org/cabal-branches/cabal-1.6---Credits-=======--Cabal Coders (in alphabetical order):--- Krasimir Angelov-- Bjorn Bringert-- Duncan Coutts-- Isaac Jones-- David Himmelstrup (Lemmih)-- Simon Marlow-- Ross Patterson-- Thomas Schilling-- Martin Sjögren-- Malcolm Wallace-- and nearly 30 other people have contributed occasional patches--Cabal spec:--- Isaac Jones-- Simon Marlow-- Ross Patterson-- Simon Peyton Jones-- Malcolm Wallace

+ cabal/Cabal/README.md view

@@ -0,0 +1,182 @@+The Cabal library package+=========================++See the [Cabal web site] for more information.++If you also want the `cabal` command-line program, you need the+[cabal-install] package in addition to this library.++[cabal-install]: ../cabal-install/README.md++Installing the Cabal library+============================++If you already have the `cabal` program+---------------------------------------++In this case run:++    $ cabal install++However, if you do not have an existing version of the `cabal` program,+you first must install the Cabal library. To avoid this bootstrapping+problem, you can install the Cabal library directly as described below.+++Installing as a user (no root or administrator access)+------------------------------------------------------++    ghc -threaded --make Setup+    ./Setup configure --user+    ./Setup build+    ./Setup install++Note the use of the `--user` flag at the configure step.++Compiling 'Setup' rather than using `runghc Setup` is much faster and+works on Windows. For all packages other than Cabal itself, it is fine+to use `runghc`.++This will install into `$HOME/.cabal/` on Unix and into+`Documents and Settings\$User\Application Data\cabal\` on Windows.+If you want to install elsewhere, use the `--prefix=` flag at the+configure step.+++Installing as root or Administrator+-----------------------------------++    ghc -threaded --make Setup+    ./Setup configure+    ./Setup build+    sudo ./Setup install++Compiling Setup rather than using `runghc Setup` is much faster and+works on Windows. For all packages other than Cabal itself, it is fine+to use `runghc`.++This will install into `/usr/local` on Unix, and on Windows it will+install into `$ProgramFiles/Haskell`. If you want to install elsewhere,+use the `--prefix=` flag at the configure step.+++Using older versions of GHC and Cabal+======================================++It is recommended that you leave any pre-existing version of Cabal+installed. In particular, it is *essential* you keep the version that+came with GHC itself, since other installed packages require it (for+instance, the "ghc" API package).++Prior to GHC 6.4.2, however, GHC did not deal particularly well with+having multiple versions of packages installed at once. So if you are+using GHC 6.4.1 or older and you have an older version of Cabal+installed, you should probably remove it by running:++    $ ghc-pkg unregister Cabal++or, if you had Cabal installed only for your user account, run:++    $ ghc-pkg unregister Cabal --user++The `filepath` dependency+=========================++Cabal uses the [filepath] package, so it must be installed first.+GHC version 6.6.1 and later come with `filepath`, however, earlier+versions do not by default. If you do not already have `filepath`,+you need to install it. You can use any existing version of Cabal to do+that. If you have neither Cabal nor `filepath`, it is slightly+harder but still possible.++Unpack Cabal and `filepath` into separate directories. For example:++    tar -xzf filepath-1.1.0.0.tar.gz+    tar -xzf Cabal-1.6.0.0.tar.gz++    # rename to make the following instructions simpler:+    mv filepath-1.1.0.0/ filepath/+    mv Cabal-1.6.0.0/ Cabal/++    cd Cabal+    ghc -i../filepath -cpp --make Setup.hs -o ../filepath/setup+    cd ../filepath/+    ./setup configure --user+    ./setup build+    ./setup install++This installs `filepath` so that you can install Cabal with the normal+method.++[filepath]: http://hackage.haskell.org/package/filepath++More information+================++Please see the [Cabal web site] for the [user guide] and [API+documentation]. There is additional information available on the+[development wiki].++[user guide]:        http://www.haskell.org/cabal/users-guide+[API documentation]: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html+[development wiki]:  https://github.com/haskell/cabal/wiki+++Bugs+====++Please report bugs and feature requests to Cabal's [bug tracker].+++Your help+---------++To help Cabal's development, it is enormously helpful to know from+Cabal's users what their most pressing problems are with Cabal and+[Hackage]. You may have a favourite Cabal bug or limitation. Look at+Cabal's [bug tracker]. Ensure that the problem is reported there and+adequately described. Comment on the issue to report how much of a+problem the bug is for you. Subscribe to the issues's notifications to+discussed requirements and keep informed on progress. For feature+requests, it is helpful if there is a description of how you would+expect to interact with the new feature.++[Hackage]: http://hackage.haskell.org+++Source code+===========++You can get the master development branch using:++    $ git clone https://github.com/haskell/cabal.git+++Credits+=======++Cabal developers (in alphabetical order):++- Krasimir Angelov+- Bjorn Bringert+- Duncan Coutts+- Isaac Jones+- David Himmelstrup ("Lemmih")+- Simon Marlow+- Ross Patterson+- Thomas Schilling+- Martin Sjögren+- Malcolm Wallace+- and nearly 30 other people have contributed occasional patches++Cabal specification authors:++- Isaac Jones+- Simon Marlow+- Ross Patterson+- Simon Peyton Jones+- Malcolm Wallace+++[bug tracker]: https://github.com/haskell/cabal/issues+[Cabal web site]: http://www.haskell.org/cabal/

− cabal/Cabal/cabal.config

@@ -1,1 +0,0 @@-ghc-options: -fno-ignore-asserts

cabal/Cabal/changelog view

@@ -1,8 +1,78 @@ -*-change-log-*- -1.11.x (current development version)+1.23.x.x (current development version)+	* 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+	* Add '--profiling-defail=$level' flag with a default for libraries+	  and executables of 'exported-functions' and 'toplevel-functions'+	  respetively (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). -1.10.0.x (next stable release version)+1.22.0.0 Johan Tibell <johan.tibell@gmail.com> January 2015+	* Support GHC 7.10.+	* Experimental support for emitting DWARF debug info.+	* Preliminary support for relocatable packages.+	* Allow cabal to be used inside cabal exec enviroments.+	* hpc: support mutliple "ways" (e.g. profiling and vanilla).+	* Support GHCJS.+	* Improved command line documentation.+	* Add '-none' constraint syntax for version ranges (#2093).+	* Make the default doc index file path compiler/arch/os-dependent+	(#2136).+	* Warn instead of dying when generating documentation and hscolour+	isn't installed (455f51622fa38347db62197a04bb0fa5b928ff17).+	* Support the new BinaryLiterals extension+	(1f25ab3c5eff311ada73c6c987061b80e9bbebd9).+	* Warn about 'ghc-prof-options: -auto-all' in 'cabal check' (#2162).+	* Add preliminary support for multiple instances of the same package+	version installed side-by-side (#2002).+	* New binary build config format - faster build times (#2076).+	* Support module thinning and renaming (#2038).+	* Add a new license type: UnspecifiedLicense (#2141).+	* Remove support for Hugs and nhc98 (#2168).+	* Invoke 'tar' with '--formar ustar' if possible in 'sdist' (#1903).+	* Replace --enable-library-coverage with --enable-coverage, which+	enables program coverage for all components (#1945).+	* Suggest that `ExitFailure 9` is probably due to memory+	exhaustion (#1522).+	* Drop support for Haddock < 2.0 (#1808, #1718).+	* Make 'cabal test'/'cabal bench' build only what's needed for+	running tests/benchmarks (#1821).+	* Build shared libraries by default when linking executables dynamically.+	* Build profiled libraries by default when profiling executable.s++1.20.0.1 Johan Tibell <johan.tibell@gmail.com> May 2014+	* Fix streaming test output.++1.20.0.0 Johan Tibell <johan.tibell@gmail.com> April 2014+	* Rewrite user guide+	* Fix repl Ctrl+C handling+	* Add haskell-suite compiler support+	* Add __HADDOCK_VERSION__ define+	* Allow specifying exact dependency version using hash+	* Rename extra-html-files to extra-doc-files+	* Add parallel build support for GHC 7.8 and later+	* Don't call ranlib on OS X+	* Avoid re-linking executables, test suites, and benchmarks+	unnecessarily, shortening build times+	* Add --allow-newer which allows upper version bounds to be+	ignored+	* Add --enable-library-stripping+	* Add command for freezing dependencies+	* Allow repl to be used outside Cabal packages+	* Add --require-sandbox+	* Don't use --strip-unneeded on OS X or iOS+	* Add new license-files field got additional licenses+	* Fix if(solaris) on some Solaris versions+	* Don't use -dylib-install-name on OS X with GHC > 7.8+	* Add DragonFly as a known OS+	* Improve pretty-printing of Cabal files+	* Add test flag --show-details=streaming for real-time test output+	* Add exec command  1.10.2.0 Duncan Coutts <duncan@community.haskell.org> June 2011 	* Include test suites in cabal sdist

cabal/Cabal/doc/developing-packages.markdown view

@@ -18,9 +18,7 @@ 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. See section [TODO](#TODO)-for the standard practices for organising the files in your project-directory.+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:@@ -40,8 +38,8 @@  ~~~~~~~~~~ $ cabal init-Package name [default "proglet"]? -Package version [default "0.1"]? +Package name [default "proglet"]?+Package version [default "0.1"]? ... ~~~~~~~~~~ @@ -264,7 +262,7 @@  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". +"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@@ -285,7 +283,7 @@ 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. @@ -294,14 +292,14 @@     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.@@ -310,12 +308,12 @@ :   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.@@ -351,7 +349,7 @@ 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 managager install dependencies automatically.+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@@ -364,15 +362,15 @@  The explicit dependency approach is in contrast to the traditional "./configure" approach where instead of specifying dependencies-declarativly, the `./configure` script checks if the dependencies are+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 managment. Instead,+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-managment.+management.  The "./configure" approach tends to encourage packages that adapt themselves to the environment in which they are built, for example by@@ -380,7 +378,7 @@ 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 managment view is that packages should just declare what they+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. @@ -419,7 +417,7 @@ 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 distro packages).+Linux distribution packages).  In fact both of these examples fall into the category of explicitly specifying dependencies. Not all dependencies are other Cabal packages.@@ -449,7 +447,7 @@ 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 dependended on+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@@ -489,7 +487,7 @@  :   a single-module Haskell program to perform various setup tasks (with     the interface described in the section on [building and installing-    packages](#building-and-installing-a-package)). This module should+    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@@ -498,7 +496,7 @@  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](#building-and-installing-a-package).+[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@@ -527,7 +525,6 @@   exposed-modules: Foo   extensions:      ForeignFunctionInterface   ghc-options:     -Wall-  nhc98-options:   -K4m   if os(windows)     build-depends: Win32 ~~~~~~~~~~~~~~~~@@ -621,13 +618,13 @@ [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 (except nhc98, for now).+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](#complex-packages).+elaborate solutions](#more-complex-packages).  ## Package descriptions ## @@ -655,8 +652,8 @@   information](#build-information).  * Following is an arbitrary number of executable sections-  which describe an [executable program](#executable) and relevant-  [build information](#build-information).+  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@@ -691,9 +688,8 @@ :   A letter followed by zero or more alphanumerics or underscores.  _compiler_-:   A compiler flavor (one of: `GHC`, `NHC`, `YHC`, `Hugs`, `HBC`,-    `Helium`, `JHC`, or `LHC`) followed by a version range.  For-    example, `GHC ==6.10.3`, or `LHC >=0.6 && <0.8`.+:   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 ### @@ -709,8 +705,12 @@ * `.x` ([alex][]) * `.cpphs` ([cpphs][]) -When building, Cabal will automatically run the appropriate preprocessor-and compile the Haskell module it produces.+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.@@ -724,8 +724,7 @@ describe the package as a whole:  `name:` _package-name_ (required)-:   The unique name of the [package](#packages), without the version-    number.+:   The unique name of the package, without the version number.  `version:` _numbers_ (required) :   The package version number, usually consisting of a sequence of@@ -733,7 +732,7 @@  `cabal-version:`  _>= x.y_ :   The version of the Cabal specification that this package description uses.-    The Cabal specification does slowly evolve, intoducing new features and+    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@@ -744,8 +743,8 @@     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 compatability and-    behaviour. Most tools (including the Cabal libray and cabal program)+    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@@ -760,7 +759,7 @@     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-    compatability with very old Cabal versions then you may write your package+    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. @@ -792,8 +791,8 @@     ~~~~~~~~~~~~~~~~      For build type `Make` (see the section on [more complex-    packages](#more-complex-packages) below), the contents of-    `Setup.hs` must be:+    packages](installing-packages.html#more-complex-packages) below),+    the contents of `Setup.hs` must be:      ~~~~~~~~~~~~~~~~     import Distribution.Make@@ -809,10 +808,13 @@ :   The type of license under which this package is distributed.     License names are the constants of the [License][dist-license] type. -`license-file:` _filename_-:   The name of a file containing the precise license for this package.-    It will be installed with the package.+`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@@ -837,7 +839,7 @@ `bug-reports:` _URL_ :   The URL where users should direct bug reports. This would normally be either: -    * A `mailto:` URL, eg for a person or a mailing list.+    * A `mailto:` URL, e.g. for a person or a mailing list.      * An `http:` (or `https:`) URL for an online bug tracking system. @@ -863,8 +865,8 @@     package before.      For library packages, this field is used as prologue text by [`setup-    haddock`](#setup-haddock), and thus may contain the same markup as-    [haddock][] documentation comments.+    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@@ -907,8 +909,9 @@  `extra-source-files:` _filename list_ :   A list of additional files to be included in source distributions-    built with [`setup sdist`](#setup-sdist). As with `data-files` it-    can use a limited form of `*` wildcards in file names.+    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,@@ -918,9 +921,10 @@  `extra-tmp-files:` _filename list_ :   A list of additional files or directories to be removed by [`setup-    clean`](#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).+    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 ### @@ -943,6 +947,21 @@     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)). @@ -1030,41 +1049,39 @@  `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-1.0`.  Each of+    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-1.0`+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-1.0`)+`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-1.0` interface are modules exporting the symbol+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-1.0` interface allows Cabal and other test agents to inspect a+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-1.0` interface requires the+machine-readable log files.  The `detailed-0.9` interface requires the `test-module` field. -`test-module:` _identifier_ (required: `detailed-1.0`, disallowed: `exitcode-stdio-1.0`)+`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.  For brevity, the example package-does not include a library or any normal executables, but a real package would-be required to have at least one library or executable.+the use of the `exitcode-stdio-1.0` interface.  foo.cabal: @@ -1093,15 +1110,13 @@     exitFailure ~~~~~~~~~~~~~~~~ -#### Example: Package using `detailed-1.0` interface ####+#### Example: Package using `detailed-0.9` interface ####  The example package description and test module source file below demonstrate-the use of the `detailed-1.0` interface.  For brevity, the example package does-note include a library or any normal executables, but a real package would be-required to have at least one library or executable.  The test module below-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.+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: @@ -1113,7 +1128,7 @@ Build-Type:     Simple  Test-Suite test-bar-    type:       detailed-1.0+    type:       detailed-0.9     test-module: Bar     build-depends: base, Cabal >= 1.9.2 ~~~~~~~~~~~~~~~~@@ -1189,9 +1204,7 @@ #### 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.  For brevity, the example package-does not include a library or any normal executables, but a real package would-be required to have at least one library or executable.+the use of the `exitcode-stdio-1.0` interface.  foo.cabal: @@ -1277,6 +1290,23 @@      It is only syntactic sugar. It is exactly equivalent to `foo >= 1.2 && < 1.3`. +    With Cabal 1.20 and GHC 7.10, `build-depends` also supports module+    thinning and renaming, which allows you to selectively decide what+    modules become visible from a package dependency.  For example:++    ~~~~~~~~~~~~~~~~+    build-depends: containers (Data.Set, Data.IntMap as Map)+    ~~~~~~~~~~~~~~~~++    This results in only the modules `Data.Set` and `Map` being visible to+    the user from containers, hiding all other modules.  To add additional+    names for modules without hiding the others, you can use the `with`+    keyword:++    ~~~~~~~~~~~~~~~~+    build-depends: containers with (Data.IntMap as Map)+    ~~~~~~~~~~~~~~~~+     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@@ -1298,21 +1328,38 @@     For backwards compatibility, the old variant `hs-source-dir` is also     recognized. -`extensions:` _identifier list_-:   A list of Haskell extensions used by every module. Extension names-    are the constructors of the [Extension][extension] type. These-    determine corresponding compiler options. In particular, `CPP` specifies that-    Haskell source files are to be preprocessed with a C preprocessor.+`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. -    Extensions used only by one module may be specified by placing a-    `LANGUAGE` pragma in the source file affected, e.g.:+`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 #-}     ~~~~~~~~~~~~~~~~ -    Note:  GHC versions prior to 6.6 do not support the `LANGUAGE` pragma.+    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@@ -1335,22 +1382,23 @@ :   Additional options for GHC when the package is built with profiling     enabled. -`ghc-shared-options:` _token list_-:   Additional options for GHC when the package is built as shared library.+    Note that as of Cabal-1.24, the default profiling detail level defaults to+    `exported-functions` for libraries and `toplevel-funcitons` 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. -`hugs-options:` _token list_-:   Additional options for Hugs. You can often achieve the same effect-    using the `extensions` field, which is preferred.+    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. -    Options required only by one module may be specified by placing an-    `OPTIONS_HUGS` pragma in the source file affected. -`nhc98-options:` _token list_-:   Additional options for nhc98. 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_NHC98` pragma in the source file affected.+`ghc-shared-options:` _token list_+:   Additional options for GHC when the package is built as shared library.  `includes:` _filename list_ :   A list of header files to be included in any compilations via C.@@ -1374,20 +1422,23 @@  `include-dirs:` _directory list_ :   A list of directories to search for header files, when preprocessing-    with `c2hs`, `hsc2hs`, `ffihugs`, `cpphs` or the C preprocessor, and+    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. -    If you use this field, you should also name the C files in `CFILES`-    pragmas in the Haskell source files that use them, e.g.: `{-# CFILES-    dir/file1.c dir/file2.c #-}` These are ignored by the compilers, but-    needed by Hugs.+`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. @@ -1397,6 +1448,11 @@     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@@ -1533,12 +1589,12 @@ :   The default value of this flag.      Note that this value may be [overridden in several-    ways](#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.+    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@@ -1615,9 +1671,9 @@  #### Resolution of Conditions and Flags #### -If a package descriptions specifies configuration flags the package user-can [control these in several ways](#controlling-flag-assignments). If-the user does not fix the value of a flag, Cabal will try to find a flag+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@@ -1661,15 +1717,15 @@     items, for example      ~~~~~~~~~~~~~~~~-    Extensions: CPP-    if impl(ghc) || impl(hugs)-      Extensions: MultiParamTypeClasses+    other-extensions: CPP+    if impl(ghc)+      other-extensions: MultiParamTypeClasses     ~~~~~~~~~~~~~~~~ -    when compiled using Hugs or GHC will be combined to+    when compiled using GHC will be combined to      ~~~~~~~~~~~~~~~~-    Extensions: CPP, MultiParamTypeClasses+    other-extensions: CPP, MultiParamTypeClasses     ~~~~~~~~~~~~~~~~      Similarly, if two conditional sections appear at the same nesting@@ -1726,7 +1782,7 @@  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-repo specifies a tag.+repository specifies a tag.  ~~~~~~~~~~~~~~~~ source-repository head@@ -1770,8 +1826,8 @@ :   CVS requires a named module, as each CVS server can host multiple     named repositories. -    This field is required for the CVS repo type and should not be used-    otherwise.+    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@@ -1784,17 +1840,17 @@  `tag:` _token_ :   A tag identifies a particular state of a source repository. The tag-    can be used with a `this` repo kind to identify the state of a repo-    corresponding to a particular package version or release. The exact-    form of the tag depends on the repository type.+    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` repo kind.+    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, ie the directory containing the package's `.cabal` file.+    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.@@ -1817,7 +1873,7 @@  `-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 repo kind.+    system. The optional argument allows to choose a specific repository kind.   ## Accessing data files from package code ##@@ -1825,9 +1881,9 @@ 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](#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+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 @@ -1846,6 +1902,21 @@ 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@@ -2094,27 +2165,27 @@   * 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](#building-and-installing-a-package), 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.+    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]:  ../libraries/Cabal/Distribution-Simple.html-[dist-make]:    ../libraries/Cabal/Distribution-Make.html-[dist-license]: ../libraries/Cabal/Distribution-License.html#t:License-[extension]:    ../libraries/Cabal/Language-Haskell-Extension.html#t:Extension-[BuildType]:    ../libraries/Cabal/Distribution-PackageDescription.html#t:BuildType+[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://www.haskell.org/cpphs/-[greencard]:  http://www.haskell.org/greencard/+[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://pkg-config.freedesktop.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

cabal/Cabal/doc/index.markdown view

@@ -19,7 +19,6 @@       - [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)-  * [Cabal specification, design and implementation]()   * [Reporting bugs and deficiencies](misc.html#reporting-bugs-and-deficiencies)   * [Stability of Cabal interfaces](misc.html#stability-of-cabal-interfaces) @@ -84,7 +83,7 @@  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 centeral Haskell package archive called [Hackage] but it+use the central Haskell package archive called [Hackage] but it is possible to use it with any other suitable archive.  ~~~~~~~~~~~~~~~~@@ -164,7 +163,7 @@ 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-paramaters.+parameters.  ~~~~~~~~~~ ./configure --prefix=...@@ -183,7 +182,7 @@ 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+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

cabal/Cabal/doc/installing-packages.markdown view

@@ -216,7 +216,7 @@  ## Creating a binary package ## -When creating binary packages (e.g. for RedHat or Debian) one needs to+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: @@ -267,19 +267,20 @@ private file read by later stages.  If a user-supplied `configure` script is run (see the section on-[system-dependent parameters](#system-dependent-parameters) or on-[complex packages](#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.+[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`, `--nhc`, `--jhc`, `--hugs`+`--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@@ -315,7 +316,7 @@ :   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 embeded+    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,@@ -323,8 +324,8 @@  `--`_`prog`_`-option=`_option_ :   Specify a single additional option to the program _prog_. For-    passing an option that contain embeded spaces, such as a file name-    with embeded spaces, using this rather than `--`_`prog`_`-options`+    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"`.@@ -346,21 +347,21 @@      In the simple build system, _dir_ may contain the following path     variables: `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`,-    `$arch`+    `$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`+    `$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`+    `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`  `--libexecdir=`_dir_ :   Executables that are not expected to be invoked directly by the user@@ -368,21 +369,21 @@      In the simple build system, _dir_ may contain the following path     variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`,-    `$pkg`, `$version`, `$compiler`, `$os`, `$arch`+    `$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`+    `$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`+    `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`  In addition the simple build system supports the following installation path options: @@ -394,34 +395,34 @@     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`+    `$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`+    `$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`+    `$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`+    `$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`+    `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`  `--program-suffix=`_suffix_ :   Append _suffix_ to installed program names. The most obvious use for@@ -430,7 +431,7 @@     `--program-suffix='$version'`.      _suffix_ may contain the following path variables: `$pkgid`, `$pkg`,-    `$version`, `$compiler`, `$os`, `$arch`+    `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`  #### Path variables in the simple build system #### @@ -444,7 +445,7 @@  `$prefix` :   The path variable that stands for the root of the installation. For-    an installation to be relocatable, all other instllation paths must+    an installation to be relocatable, all other installation paths must     be relative to the `$prefix` variable.  `$bindir`@@ -467,25 +468,35 @@ :   As above but for `--docdir`  `$pkgid`-:   The name and version of the package, eg `mypkg-0.2`+:   The name and version of the package, e.g. `mypkg-0.2`  `$pkg`-:   The name of the package, eg `mypkg`+:   The name of the package, e.g. `mypkg`  `$version`-:   The version of the package, eg `0.2`+:   The version of the package, e.g. `0.2`  `$compiler`-:   The compiler being used to build the package, eg `ghc-6.6.1`+:   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, eg `linux`, `windows`, `osx`, `freebsd` or `solaris`+    package, e.g. `linux`, `windows`, `osx`, `freebsd` or `solaris`  `$arch`-:   The architecture of the computer being used to build the package, eg+:   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:@@ -496,7 +507,6 @@ `--prefix` (per-user)      `C:\Documents And Settings\user\Application Data\cabal`   `$HOME/.cabal` `--bindir`                 `$prefix\bin`                                             `$prefix/bin` `--libdir`                 `$prefix`                                                 `$prefix/lib`-`--libsubdir` (Hugs)       `hugs\packages\$pkg`                                      `hugs/packages/$pkg` `--libsubdir` (others)     `$pkgid\$compiler`                                        `$pkgid/$compiler` `--libexecdir`             `$prefix\$pkgid`                                          `$prefix/libexec` `--datadir` (executable)   `$prefix`                                                 `$prefix/share`@@ -511,15 +521,14 @@  #### Prefix-independence #### -On Windows, and when using Hugs on any system, 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.+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@@ -528,8 +537,9 @@  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](#accessing-data-files-from-package-code), the-files will be accessed relative to the location of the current+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@@ -539,8 +549,8 @@ ### Controlling Flag Assignments ###  Flag assignments (see the [resolution of conditions and-flags](#resolution-of-conditions-and-flags)) can be controlled with the-followingcommand line options.+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@@ -567,6 +577,14 @@     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`@@ -582,7 +600,7 @@ :   (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 instllation step will require administrative privileges.+    the final installation step will require administrative privileges.  `--package-db=`_db_ :   Allows package dependencies to be satisfied from this additional@@ -608,24 +626,81 @@ :   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`-:   Request that an additional version of the library with profiling-    features enabled be built and installed (only for implementations-    that support profiling).+:   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. -`--enable-executable-profiling`-:   Any executables generated should have profiling enabled (only for-    implementations that support profiling). For this to work, all-    libraries used by these executables must also have been built with-    profiling support.+`--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. -`--disable-executable-profiling`-:   (default) Do not enable profiling in generated executables.+    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`@@ -673,7 +748,7 @@     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).+    itself (such as some Linux distributions).  `--enable-shared` :   Build shared library. This implies a separate compiler run to@@ -682,11 +757,19 @@ `--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](#system-dependent-parameters)).  There can be several of-    these options.+    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@@ -755,12 +838,16 @@     It's also possible to enable `--allow-newer` permanently by setting     `allow-newer: True` in the `~/.cabal/config` file. --In the simple build infrastructure, an additional option is recognized:+`--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. -`--scratchdir=`_dir_-:   Specify the directory into which the Hugs output will be placed-    (default: `dist/scratch`).+    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 ## @@ -979,17 +1066,17 @@     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`, `$test-suite`, and `$result`.+    `$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`, and `$result`.+    `$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), or-    `failures` (show only the test cases of failing test suites).+    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.@@ -1009,8 +1096,8 @@ 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`, `data-files`, `extra-source-files` and `extra-doc-files`-fields.+`c-sources`, `js-sources`, `data-files`, `extra-source-files` and+`extra-doc-files` fields.  This command takes the following option: @@ -1019,18 +1106,18 @@     the generated source package.  The original package is unaffected.  -[dist-simple]:  ../libraries/Cabal/Distribution-Simple.html-[dist-make]:    ../libraries/Cabal/Distribution-Make.html-[dist-license]: ../libraries/Cabal/Distribution-License.html#t:License-[extension]:    ../libraries/Cabal/Language-Haskell-Extension.html#t:Extension-[BuildType]:    ../libraries/Cabal/Distribution-PackageDescription.html#t:BuildType+[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://www.haskell.org/cpphs/-[greencard]:  http://www.haskell.org/greencard/+[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://pkg-config.freedesktop.org/+[pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/

cabal/Cabal/doc/misc.markdown view

@@ -15,7 +15,7 @@ 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 therefor cannot promise complete future-proof+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@@ -34,7 +34,7 @@ * `./setup configure`   * `--prefix`   * `--user`-  * `--ghc`, `--hugs`+  * `--ghc`, `--uhc`   * `--verbose`   * `--prefix` @@ -61,7 +61,7 @@ gives some informal advice on what level of API stability you can expect between major releases. -[PVP]: http://haskell.org/haskellwiki/Package_versioning_policy+[PVP]: http://www.haskell.org/haskellwiki/Package_versioning_policy  ### Very Stable API ### @@ -92,18 +92,18 @@ name of the index file, i.e., `00-index.tar.gz`, `01-index.tar.gz` etc.  -[dist-simple]:  ../libraries/Cabal/Distribution-Simple.html-[dist-make]:    ../libraries/Cabal/Distribution-Make.html-[dist-license]: ../libraries/Cabal/Distribution-License.html#t:License-[extension]:    ../libraries/Cabal/Language-Haskell-Extension.html#t:Extension-[BuildType]:    ../libraries/Cabal/Distribution-PackageDescription.html#t:BuildType+[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://www.haskell.org/cpphs/-[greencard]:  http://www.haskell.org/greencard/+[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/-[HackageDB]:  http://hackage.haskell.org/-[pkg-config]: http://pkg-config.freedesktop.org/+[Hackage]:    http://hackage.haskell.org/+[pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/

cabal/Cabal/misc/gen-extra-source-files.sh view

@@ -1,5 +1,5 @@ #! /bin/sh -find tests -type f \( -name '*.hs' -or -name '*.c' -or -name '*.sh' \+find tests -type f \( -name '*.hs' -or -name '*.lhs' -or -name '*.c' -or -name '*.sh' \     -or -name '*.cabal' -or -name '*.hsc' \) -and -not -regex ".*/dist/.*" \     | awk '/Check.hs$|UnitTests|PackageTester|autogen|PackageTests.hs|CreatePipe/ { next } { print }'

− cabal/HACKING

@@ -1,25 +0,0 @@-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 dev wiki:-  https://github.com/haskell/cabal/wiki-  http://hackage.haskell.org/trac/hackage/ (old wiki)--In particular, the open tickets and the cabal-devel mailing list-which is a good place to ask questions.---Dependencies policy----------------------Cabal's policy is to support being built by versions of GHC that are up-to 3 years old.-

+ cabal/HACKING.md view

@@ -0,0 +1,147 @@+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 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.)++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/Paths_Cabal.hs view

@@ -5,4 +5,4 @@ import Data.Version (Version(..))  version :: Version-version = Version {versionBranch = [1,17,0], versionTags = []}+version = Version {versionBranch = [1,23,0,0], versionTags = []}

cabal/Paths_cabal_install.hs view

@@ -5,4 +5,4 @@ import Data.Version (Version(..))  version :: Version-version = Version {versionBranch = [0,17,0], versionTags = []}+version = Version {versionBranch = [1,23,0,0], versionTags = []}

cabal/README.md view

@@ -1,12 +1,12 @@-# Cabal--[![Build Status](https://secure.travis-ci.org/haskell/cabal.png?branch=master)](http://travis-ci.org/haskell/cabal)+# Cabal [![Build Status](https://secure.travis-ci.org/haskell/cabal.svg?branch=master)](http://travis-ci.org/haskell/cabal) -This Cabal git repository contains multiple packages:+This Cabal Git repository contains the following packages: - * `Cabal`          -- the Cabal library package- * `cabal-install`  -- the cabal-install package containing the `cabal` tool.+ * [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 the README in each subdir for more details.+See [HACKING.md](HACKING.md) for information about contributing and building+from git cloned sources. -The canonical upstream repo lives at https://github.com/haskell/cabal+The canonical upstream repository is located at+https://github.com/haskell/cabal.

cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs view

@@ -26,8 +26,6 @@ --    showList,   ) where -import Distribution.Client.Types-         ( ConfiguredPackage(..) ) import qualified Distribution.Client.Types as BR          ( BuildResult, BuildFailure(..), BuildSuccess(..)          , DocsResult(..), TestsResult(..) )@@ -36,7 +34,7 @@ import qualified Paths_cabal_install (version)  import Distribution.Package-         ( PackageIdentifier(..), PackageName(..), Package(packageId) )+         ( PackageIdentifier(..), PackageName(..) ) import Distribution.PackageDescription          ( FlagName(..), FlagAssignment ) --import Distribution.Version@@ -44,7 +42,7 @@ import Distribution.System          ( OS, Arch ) import Distribution.Compiler-         ( CompilerId )+         ( CompilerId(..) ) import qualified Distribution.Text as Text          ( Text(disp, parse) ) import Distribution.ParseUtils@@ -106,7 +104,8 @@   }  data InstallOutcome-   = DependencyFailed PackageIdentifier+   = PlanningFailed+   | DependencyFailed PackageIdentifier    | DownloadFailed    | UnpackFailed    | SetupFailed@@ -120,12 +119,11 @@ data Outcome = NotTried | Failed | Ok   deriving Eq -new :: OS -> Arch -> CompilerId -- -> Version-    -> ConfiguredPackage -> BR.BuildResult-    -> BuildReport-new os' arch' comp (ConfiguredPackage pkg flags _ deps) result =+new :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment+    -> [PackageIdentifier] -> BR.BuildResult -> BuildReport+new os' arch' comp pkgid flags deps result =   BuildReport {-    package               = packageId pkg,+    package               = pkgid,     os                    = os',     arch                  = arch',     compiler              = comp,@@ -139,6 +137,7 @@   }   where     convertInstallOutcome = case result of+      Left  BR.PlanningFailed      -> PlanningFailed       Left  (BR.DependentFailed p) -> DependencyFailed p       Left  (BR.DownloadFailed  _) -> DownloadFailed       Left  (BR.UnpackFailed    _) -> UnpackFailed@@ -276,6 +275,7 @@     flag       -> return (FlagName flag, True)  instance Text.Text InstallOutcome where+  disp PlanningFailed  = Disp.text "PlanningFailed"   disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid   disp DownloadFailed  = Disp.text "DownloadFailed"   disp UnpackFailed    = Disp.text "UnpackFailed"@@ -289,6 +289,7 @@   parse = do     name <- Parse.munch1 Char.isAlphaNum     case name of+      "PlanningFailed"   -> return PlanningFailed       "DependencyFailed" -> do Parse.skipSpaces                                pkgid <- Text.parse                                return (DependencyFailed pkgid)

cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs view

@@ -20,6 +20,7 @@      -- * 'InstallPlan' support     fromInstallPlan,+    fromPlanningFailure,   ) where  import qualified Distribution.Client.BuildReports.Anonymous as BuildReport@@ -27,16 +28,21 @@  import Distribution.Client.Types import qualified Distribution.Client.InstallPlan as InstallPlan+import qualified Distribution.Client.ComponentDeps as CD import Distribution.Client.InstallPlan          ( InstallPlan ) +import Distribution.Package+         ( PackageId, packageId )+import Distribution.PackageDescription+         ( FlagAssignment ) import Distribution.Simple.InstallDirs          ( PathTemplate, fromPathTemplate          , initialPathTemplateEnv, substPathTemplate ) import Distribution.System          ( Platform(Platform) ) import Distribution.Compiler-         ( CompilerId )+         ( CompilerId(..), CompilerInfo(..)  ) import Distribution.Simple.Utils          ( comparing, equating ) @@ -49,7 +55,7 @@ import System.Directory          ( createDirectoryIfMissing ) -storeAnonymous :: [(BuildReport, Repo)] -> IO ()+storeAnonymous :: [(BuildReport, Maybe Repo)] -> IO () storeAnonymous reports = sequence_   [ appendFile file (concatMap format reports')   | (repo, reports') <- separate reports@@ -59,7 +65,7 @@    where     format r = '\n' : BuildReport.show r ++ "\n"-    separate :: [(BuildReport, Repo)]+    separate :: [(BuildReport, Maybe Repo)]              -> [(Repo, [BuildReport])]     separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))              . map concat@@ -69,13 +75,15 @@              . onlyRemote     repoName (_,_,rrepo) = remoteRepoName rrepo -    onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)]+    onlyRemote :: [(BuildReport, Maybe Repo)]+               -> [(BuildReport, Repo, RemoteRepo)]     onlyRemote rs =       [ (report, repo, remoteRepo)-      | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ]+      | (report, Just repo@Repo { repoKind = Left remoteRepo }) <- rs ] -storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> Platform -> IO ()-storeLocal templates reports platform = sequence_+storeLocal :: CompilerInfo -> [PathTemplate] -> [(BuildReport, Maybe Repo)]+           -> Platform -> IO ()+storeLocal cinfo templates reports platform = sequence_   [ do createDirectoryIfMissing True (takeDirectory file)        appendFile file output        --TODO: make this concurrency safe, either lock the report file or make@@ -93,7 +101,12 @@         fromPathTemplate (substPathTemplate env template)       where env = initialPathTemplateEnv                     (BuildReport.package  report)-                    (BuildReport.compiler report)+                    -- ToDo: In principle, we can support $pkgkey, but only+                    -- if the configure step succeeds.  So add a Maybe field+                    -- to the build report, and either use that or make up+                    -- a fake identifier if it's not available.+                    (error "storeLocal: package key not available")+                    cinfo                     platform      groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp))@@ -104,26 +117,43 @@ -- * InstallPlan support -- ------------------------------------------------------------ -fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)]-fromInstallPlan plan = catMaybes-                     . map (fromPlanPackage platform comp)-                     . InstallPlan.toList-                     $ plan-  where platform = InstallPlan.planPlatform plan-        comp     = InstallPlan.planCompiler plan+fromInstallPlan :: Platform -> CompilerId+                -> InstallPlan+                -> [(BuildReport, Maybe Repo)]+fromInstallPlan platform comp plan =+     catMaybes+   . map (fromPlanPackage platform comp)+   . InstallPlan.toList+   $ plan  fromPlanPackage :: Platform -> CompilerId                 -> InstallPlan.PlanPackage-                -> Maybe (BuildReport, Repo)+                -> Maybe (BuildReport, Maybe Repo) fromPlanPackage (Platform arch os) comp planPackage = case planPackage of--  InstallPlan.Installed pkg@(ReadyPackage (SourcePackage {-                          packageSource = RepoTarballPackage repo _ _ }) _ _ _) result-    -> Just $ (BuildReport.new os arch comp-               (readyPackageToConfiguredPackage pkg) (Right result), repo)+  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 pkg@(ConfiguredPackage (SourcePackage {-                       packageSource = RepoTarballPackage repo _ _ }) _ _ _) result-    -> Just $ (BuildReport.new os arch comp pkg (Left result), repo)+  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++  where+    extractRepo (SourcePackage { packageSource = RepoTarballPackage repo _ _ })+                  = Just repo+    extractRepo _ = Nothing++fromPlanningFailure :: Platform -> CompilerId+    -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)]+fromPlanningFailure (Platform arch os) comp pkgids flags =+  [ (BuildReport.new os arch comp pkgid flags [] (Left PlanningFailed), Nothing)+  | pkgid <- pkgids ]

cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs view

@@ -5,17 +5,17 @@     ( BuildLog     , BuildReportId     , uploadReports-    , postBuildReport-    , putBuildLog     ) where +{- import Network.Browser          ( BrowserAction, request, setAllowRedirects ) import Network.HTTP          ( Header(..), HeaderName(..)          , Request(..), RequestMethod(..), Response(..) ) import Network.TCP (HandleStream)-import Network.URI (URI, uriPath, parseRelativeReference, relativeTo)+-}+import Network.URI (URI, uriPath) --parseRelativeReference, relativeTo)  import Control.Monad          ( forM_ )@@ -24,22 +24,31 @@ import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import Distribution.Client.BuildReports.Anonymous (BuildReport) import Distribution.Text (display)+import Distribution.Verbosity (Verbosity)+import Distribution.Simple.Utils (die)+import Distribution.Client.HttpUtils  type BuildReportId = URI type BuildLog = String -uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]-              ->  BrowserAction (HandleStream BuildLog) ()-uploadReports uri reports = do+uploadReports :: Verbosity -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO ()+uploadReports verbosity auth uri reports = do   forM_ reports $ \(report, mbBuildLog) -> do-     buildId <- postBuildReport uri report+     buildId <- postBuildReport verbosity auth uri report      case mbBuildLog of-       Just buildLog -> putBuildLog buildId buildLog+       Just buildLog -> putBuildLog verbosity auth buildId buildLog        Nothing       -> return () -postBuildReport :: URI -> BuildReport-                -> BrowserAction (HandleStream BuildLog) BuildReportId-postBuildReport uri buildReport = do+postBuildReport :: Verbosity -> (String, String) -> URI -> BuildReport -> IO BuildReportId+postBuildReport verbosity auth uri buildReport = do+  let fullURI = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" }+  transport <- configureTransport verbosity Nothing+  res <- postHttp transport verbosity fullURI (BuildReport.show buildReport) (Just auth)+  case res of+    (303, redir) -> return $ undefined redir --TODO parse redir+    _ -> die "unrecognized response" -- give response++{-   setAllowRedirects False   (_, response) <- request Request {     rqURI     = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" },@@ -51,26 +60,31 @@   }   case rspCode response of     (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location+#if defined(VERSION_network_uri)+                                     return $ relativeTo rel uri+#elif defined(VERSION_network) #if MIN_VERSION_network(2,4,0)                                      return $ relativeTo rel uri #else                                      relativeTo rel uri #endif+#endif                                   | Header HdrLocation location <- rspHeaders response ]               -> return $ buildId     _         -> error "Unrecognised response from server."   where body  = BuildReport.show buildReport+-} -putBuildLog :: BuildReportId -> BuildLog-            -> BrowserAction (HandleStream BuildLog) ()-putBuildLog reportId buildLog = do-  --FIXME: do something if the request fails-  (_, _response) <- request Request {-      rqURI     = reportId{uriPath = uriPath reportId </> "log"},-      rqMethod  = PUT,-      rqHeaders = [Header HdrContentType   ("text/plain"),-                   Header HdrContentLength (show (length buildLog)),-                   Header HdrAccept        ("text/plain")],-      rqBody    = buildLog-    }-  return ()++-- TODO force this to be a PUT?++putBuildLog :: Verbosity -> (String, String)+            -> BuildReportId -> BuildLog+            -> IO ()+putBuildLog verbosity auth reportId buildLog = do+  let fullURI = reportId {uriPath = uriPath reportId </> "log"}+  transport <- configureTransport verbosity Nothing+  res <- postHttp transport verbosity fullURI buildLog (Just auth)+  case res of+    (200, _) -> return ()+    _ -> die "unrecognized response" -- give response

cabal/cabal-install/Distribution/Client/Check.hs view

@@ -50,6 +50,7 @@         buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ]         buildWarning    = [ x | x@PackageBuildWarning {}    <- packageChecks ]         distSuspicious  = [ x | x@PackageDistSuspicious {}  <- packageChecks ]+                          ++ [ x | x@PackageDistSuspiciousWarn {}  <- packageChecks ]         distInexusable  = [ x | x@PackageDistInexcusable {} <- packageChecks ]      unless (null buildImpossible) $ do@@ -68,8 +69,11 @@         putStrLn "The following errors will cause portability problems on other environments:"         printCheckMessages distInexusable -    let isDistError (PackageDistSuspicious {}) = False-        isDistError _                          = True+    let isDistError (PackageDistSuspicious     {}) = False+        isDistError (PackageDistSuspiciousWarn {}) = False+        isDistError _                              = True+        isCheckError (PackageDistSuspiciousWarn {}) = False+        isCheckError _                              = True         errors = filter isDistError packageChecks      unless (null errors) $@@ -78,7 +82,7 @@     when (null packageChecks) $         putStrLn "No errors or warnings could be found in the package." -    return (null packageChecks)+    return (null . filter isCheckError $ packageChecks)    where     printCheckMessages = mapM_ (putStrLn . format . explanation)

− cabal/cabal-install/Distribution/Client/Compat/Environment.hs

@@ -1,88 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Compat.Environment--- Copyright   :  (c) Simon Hengel 2012--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ A cross-platform library for setting environment variables.-----------------------------------------------------------------------------------module Distribution.Client.Compat.Environment (-  lookupEnv, setEnv-) where--#ifdef mingw32_HOST_OS-import GHC.Windows-import Foreign.Safe-import Foreign.C-import Control.Monad-#else-import Foreign.C.Types-import Foreign.C.String-import Foreign.C.Error (throwErrnoIfMinus1_)-import System.Posix.Internals ( withFilePath )-#endif /* mingw32_HOST_OS */--#if MIN_VERSION_base(4,6,0)-import System.Environment (lookupEnv)-#else-import System.Environment (getEnv)-import Distribution.Compat.Exception (catchIO)-#endif--#if !MIN_VERSION_base(4,6,0)--- | @lookupEnv var@ returns the value of the environment variable @var@, or--- @Nothing@ if there is no such value.-lookupEnv :: String -> IO (Maybe String)-lookupEnv name = (Just `fmap` getEnv name) `catchIO` const (return Nothing)-#endif /* !MIN_VERSION_base(4,6,0) */---- | @setEnv name value@ sets the specified environment variable to @value@.------ 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-  where-    -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We-    -- still strip it manually so that the null check above succeds if a value-    -- starts with NUL.-    value = takeWhile (/= '\NUL') value_--setEnv_ :: String -> String -> IO ()--#ifdef mingw32_HOST_OS--setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do-  success <- c_SetEnvironmentVariable k v-  unless success (throwGetLastError "setEnv")--# if defined(i386_HOST_ARCH)-#  define WINDOWS_CCONV stdcall-# elif defined(x86_64_HOST_ARCH)-#  define WINDOWS_CCONV ccall-# else-#  error Unknown mingw32 arch-# endif /* i386_HOST_ARCH */--foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"-  c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool-#else-setEnv_ key value = do-  withFilePath key $ \ keyP ->-    withFilePath value $ \ valueP ->-      throwErrnoIfMinus1_ "setenv" $-        c_setenv keyP valueP (fromIntegral (fromEnum True))--foreign import ccall unsafe "setenv"-   c_setenv :: CString -> CString -> CInt -> IO CInt-#endif /* mingw32_HOST_OS */

cabal/cabal-install/Distribution/Client/Compat/ExecutablePath.hs view

@@ -35,6 +35,25 @@ import System.Posix.Internals #endif +-- GHC 7.0.* compatibility. 'System.Posix.Internals' in base-4.3.* doesn't+-- provide 'peekFilePath' and 'peekFilePathLen'.+#if !MIN_VERSION_base(4,4,0)+#ifdef mingw32_HOST_OS++peekFilePath :: CWString -> IO FilePath+peekFilePath = peekCWString++#else++peekFilePath :: CString -> IO FilePath+peekFilePath = peekCString++peekFilePathLen :: CStringLen -> IO FilePath+peekFilePathLen = peekCStringLen++#endif+#endif+ -- The exported function is defined outside any if-guard to make sure -- every OS implements it with the same type. @@ -119,9 +138,9 @@ #elif defined(mingw32_HOST_OS)  # if defined(i386_HOST_ARCH)-##  define WINDOWS_CCONV stdcall+#  define WINDOWS_CCONV stdcall # elif defined(x86_64_HOST_ARCH)-##  define WINDOWS_CCONV ccall+#  define WINDOWS_CCONV ccall # else #  error Unknown mingw32 arch # endif

cabal/cabal-install/Distribution/Client/Compat/Process.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-}  ----------------------------------------------------------------------------- -- |@@ -16,6 +17,10 @@ module Distribution.Client.Compat.Process (   readProcessWithExitCode ) where++#if !MIN_VERSION_base(4,6,0)+import           Prelude           hiding (catch)+#endif  import           Control.Exception (catch, throw) import           System.Exit       (ExitCode (ExitFailure))

cabal/cabal-install/Distribution/Client/Compat/Time.hs view

@@ -11,20 +11,29 @@ import Data.Time (getCurrentTime, diffUTCTime) #else import System.Time (ClockTime(..), getClockTime-                   ,diffClockTimes, normalizeTimeDiff, tdDay)+                   ,diffClockTimes, normalizeTimeDiff, tdDay, tdHour) #endif  #if defined mingw32_HOST_OS +#if MIN_VERSION_base(4,7,0)+import Data.Bits          ((.|.), finiteBitSize, unsafeShiftL)+#else import Data.Bits          ((.|.), bitSize, unsafeShiftL)+#endif import Data.Int           (Int32) import Data.Word          (Word64) import Foreign            (allocaBytes, peekByteOff) import System.IO.Error    (mkIOError, doesNotExistErrorType) import System.Win32.Types (BOOL, DWORD, LPCTSTR, LPVOID, withTString) +#ifdef x86_64_HOST_ARCH+#define CALLCONV ccall+#else+#define CALLCONV stdcall+#endif -foreign import stdcall "windows.h GetFileAttributesExW"+foreign import CALLCONV "windows.h GetFileAttributesExW"   c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> IO BOOL  getFileAttributesEx :: String -> LPVOID -> IO BOOL@@ -46,11 +55,7 @@  #else -#if MIN_VERSION_base(4,5,0) import Foreign.C.Types    (CTime(..))-#else-import Foreign.C.Types    (CTime)-#endif import System.Posix.Files (getFileStatus, modificationTime)  #endif@@ -87,8 +92,13 @@           windowsTimeToPOSIXSeconds dwLow dwHigh =             let wINDOWS_TICK      = 10000000                 sEC_TO_UNIX_EPOCH = 11644473600+#if MIN_VERSION_base(4,7,0)+                qwTime = (fromIntegral dwHigh `unsafeShiftL` finiteBitSize dwHigh)+                         .|. (fromIntegral dwLow)+#else                 qwTime = (fromIntegral dwHigh `unsafeShiftL` bitSize dwHigh)                          .|. (fromIntegral dwLow)+#endif                 res    = ((qwTime :: Word64) `div` wINDOWS_TICK)                          - sEC_TO_UNIX_EPOCH             -- TODO: What if the result is not representable as POSIX seconds?@@ -110,17 +120,17 @@ #endif  -- | Return age of given file in days.-getFileAge :: FilePath -> IO Int+getFileAge :: FilePath -> IO Double getFileAge file = do   t0 <- getModificationTime file #if MIN_VERSION_directory(1,2,0)   t1 <- getCurrentTime-  let days = truncate $ (t1 `diffUTCTime` t0) / posixDayLength+  return $ realToFrac (t1 `diffUTCTime` t0) / realToFrac posixDayLength #else   t1 <- getClockTime-  let days = (tdDay . normalizeTimeDiff) (t1 `diffClockTimes` t0)+  let dt = normalizeTimeDiff (t1 `diffClockTimes` t0)+  return $ fromIntegral ((24 * tdDay dt) + tdHour dt) / 24.0 #endif-  return days  getCurTime :: IO EpochTime getCurTime =  do

+ cabal/cabal-install/Distribution/Client/ComponentDeps.hs view

@@ -0,0 +1,142 @@+-- | 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 #-}+module Distribution.Client.ComponentDeps (+    -- * Fine-grained package dependencies+    Component(..)+  , ComponentDep+  , ComponentDeps -- opaque+    -- ** Constructing ComponentDeps+  , empty+  , fromList+  , singleton+  , insert+  , fromLibraryDeps+  , fromSetupDeps+  , fromInstalled+    -- ** Deconstructing ComponentDeps+  , toList+  , flatDeps+  , nonSetupDeps+  , libraryDeps+  , setupDeps+  , select+  ) where++import Data.Map (Map)+import qualified Data.Map as Map+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+  | ComponentExe   String+  | ComponentTest  String+  | ComponentBench String+  | ComponentSetup+  deriving (Show, Eq, Ord)++-- | Dependency for a single component+type ComponentDep a = (Component, a)++-- | Fine-grained dependencies for a package+newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a }+  deriving (Show, Functor, Eq, Ord)++instance Monoid a => Monoid (ComponentDeps a) where+  mempty =+    ComponentDeps Map.empty+  (ComponentDeps d) `mappend` (ComponentDeps d') =+    ComponentDeps (Map.unionWith mappend d d')++instance Foldable ComponentDeps where+  foldMap f = foldMap f . unComponentDeps++instance Traversable ComponentDeps where+  traverse f = fmap ComponentDeps . traverse f . unComponentDeps++{-------------------------------------------------------------------------------+  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'++-- | 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 (TODO: Version? 1.23) 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 (== ComponentLib)++-- | 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

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Config@@ -30,27 +32,36 @@     commentSavedConfig,     initialSavedConfig,     configFieldDescriptions,-    installDirsFields+    haddockFlagsFields,+    installDirsFields,+    withProgramsFields,+    withProgramOptionsFields,+    userConfigDiff,+    userConfigUpdate   ) where - import Distribution.Client.Types-         ( RemoteRepo(..), Username(..), Password(..) )+         ( 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          , InstallFlags(..), installOptions, defaultInstallFlags          , UploadFlags(..), uploadCommand          , ReportFlags(..), reportCommand-         , showRepo, parseRepo )+         , showRepo, parseRepo, readRepo )+import Distribution.Utils.NubList+         ( NubList, fromNubList, toNubList)  import Distribution.Simple.Compiler-         ( OptimisationLevel(..) )+         ( DebugInfoLevel(..), OptimisationLevel(..) ) import Distribution.Simple.Setup          ( ConfigFlags(..), configureOptions, defaultConfigFlags-         , installDirsOptions+         , HaddockFlags(..), haddockOptions, defaultHaddockFlags+         , installDirsOptions, optionDistPref          , programConfigurationPaths', programConfigurationOptions          , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs@@ -61,7 +72,8 @@          , ParseResult(..), PError(..), PWarning(..)          , locatedErrorMsg, showPWarning          , readFields, warning, lineNo-         , simpleField, listField, parseFilePathQ, parseTokenQ )+         , simpleField, listField, spaceListField+         , parseFilePathQ, parseTokenQ ) import Distribution.Client.ParseUtils          ( parseFields, ppFields, ppSection ) import qualified Distribution.ParseUtils as ParseUtils@@ -74,30 +86,34 @@ import Distribution.Simple.Program          ( defaultProgramConfiguration ) import Distribution.Simple.Utils-         ( notice, warn, lowercase )+         ( die, notice, warn, lowercase, cabalVersion ) import Distribution.Compiler          ( CompilerFlavor(..), defaultCompilerFlavor ) import Distribution.Verbosity          ( Verbosity, normal )  import Data.List-         ( partition, find )+         ( partition, find, foldl' ) import Data.Maybe          ( fromMaybe )+#if !MIN_VERSION_base(4,8,0) import Data.Monoid          ( Monoid(..) )+#endif import Control.Monad-         ( unless, foldM, liftM )+         ( unless, foldM, liftM, liftM2 ) import qualified Distribution.Compat.ReadP as Parse          ( option ) import qualified Text.PrettyPrint as Disp          ( render, text, empty ) import Text.PrettyPrint          ( ($+$) )+import Text.PrettyPrint.HughesPJ+         ( text, Doc ) import System.Directory          ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile ) import Network.URI-         ( URI(..), URIAuth(..) )+         ( URI(..), URIAuth(..), parseURI ) import System.FilePath          ( (<.>), (</>), takeDirectory ) import System.IO.Error@@ -106,6 +122,17 @@          ( getEnvironment ) import Distribution.Compat.Exception          ( catchIO )+import qualified Paths_cabal_install+         ( version )+import Data.Version+         ( showVersion )+import Data.Char+         ( isSpace )+import qualified Data.Map as M+import Data.Function+         ( on )+import Data.List+         ( nubBy )  -- -- * Configuration saved in the config file@@ -119,7 +146,8 @@     savedUserInstallDirs   :: InstallDirs (Flag PathTemplate),     savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate),     savedUploadFlags       :: UploadFlags,-    savedReportFlags       :: ReportFlags+    savedReportFlags       :: ReportFlags,+    savedHaddockFlags      :: HaddockFlags   }  instance Monoid SavedConfig where@@ -131,38 +159,231 @@     savedUserInstallDirs   = mempty,     savedGlobalInstallDirs = mempty,     savedUploadFlags       = mempty,-    savedReportFlags       = mempty+    savedReportFlags       = mempty,+    savedHaddockFlags      = mempty   }   mappend a b = SavedConfig {-    savedGlobalFlags       = combine savedGlobalFlags,-    savedInstallFlags      = combine savedInstallFlags,-    savedConfigureFlags    = combine savedConfigureFlags,-    savedConfigureExFlags  = combine savedConfigureExFlags,-    savedUserInstallDirs   = combine savedUserInstallDirs,-    savedGlobalInstallDirs = combine savedGlobalInstallDirs,-    savedUploadFlags       = combine savedUploadFlags,-    savedReportFlags       = combine savedReportFlags+    savedGlobalFlags       = combinedSavedGlobalFlags,+    savedInstallFlags      = combinedSavedInstallFlags,+    savedConfigureFlags    = combinedSavedConfigureFlags,+    savedConfigureExFlags  = combinedSavedConfigureExFlags,+    savedUserInstallDirs   = combinedSavedUserInstallDirs,+    savedGlobalInstallDirs = combinedSavedGlobalInstallDirs,+    savedUploadFlags       = combinedSavedUploadFlags,+    savedReportFlags       = combinedSavedReportFlags,+    savedHaddockFlags      = combinedSavedHaddockFlags   }-    where combine field = field a `mappend` field b+    where+      -- This is ugly, but necessary. If we're mappending two config files, we+      -- want the values of the *non-empty* list fields from the second one to+      -- *override* the corresponding values from the first one. Default+      -- behaviour (concatenation) is confusing and makes some use cases (see+      -- #1884) impossible.+      --+      -- However, we also want to allow specifying multiple values for a list+      -- field in a *single* config file. For example, we want the following to+      -- continue to work:+      --+      -- remote-repo: hackage.haskell.org:http://hackage.haskell.org/+      -- remote-repo: private-collection:http://hackage.local/+      --+      -- So we can't just wrap the list fields inside Flags; we have to do some+      -- special-casing just for SavedConfig. -updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig-updateInstallDirs userInstallFlag-  savedConfig@SavedConfig {-    savedConfigureFlags    = configureFlags,-    savedUserInstallDirs   = userInstallDirs,-    savedGlobalInstallDirs = globalInstallDirs-  } =-  savedConfig {-    savedConfigureFlags = configureFlags {-      configInstallDirs = installDirs-    }-  }-  where-    installDirs | userInstall = userInstallDirs-                | otherwise   = globalInstallDirs-    userInstall = fromFlagOrDefault defaultUserInstall $-                    configUserInstall configureFlags `mappend` userInstallFlag+      -- NB: the signature prevents us from using 'combine' on lists.+      combine' :: (SavedConfig -> flags) -> (flags -> Flag a) -> Flag a+      combine'        field subfield =+        (subfield . field $ a) `mappend` (subfield . field $ b) +      lastNonEmpty' :: (SavedConfig -> flags) -> (flags -> [a]) -> [a]+      lastNonEmpty'   field subfield =+        let a' = subfield . field $ a+            b' = subfield . field $ b+        in case b' of [] -> a'+                      _  -> b'++      lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a)+                      -> NubList a+      lastNonEmptyNL' field subfield =+        let a' = subfield . field $ a+            b' = subfield . field $ b+        in case fromNubList b' of [] -> a'+                                  _  -> b'++      combinedSavedGlobalFlags = GlobalFlags {+        globalVersion           = combine globalVersion,+        globalNumericVersion    = combine globalNumericVersion,+        globalConfigFile        = combine globalConfigFile,+        globalSandboxConfigFile = combine globalSandboxConfigFile,+        globalRemoteRepos       = lastNonEmptyNL globalRemoteRepos,+        globalCacheDir          = combine globalCacheDir,+        globalLocalRepos        = lastNonEmptyNL globalLocalRepos,+        globalLogsDir           = combine globalLogsDir,+        globalWorldFile         = combine globalWorldFile,+        globalRequireSandbox    = combine globalRequireSandbox,+        globalIgnoreSandbox     = combine globalIgnoreSandbox,+        globalHttpTransport     = combine globalHttpTransport+        }+        where+          combine        = combine'        savedGlobalFlags+          lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags++      combinedSavedInstallFlags = InstallFlags {+        installDocumentation         = combine installDocumentation,+        installHaddockIndex          = combine installHaddockIndex,+        installDryRun                = combine installDryRun,+        installMaxBackjumps          = combine installMaxBackjumps,+        installReorderGoals          = combine installReorderGoals,+        installIndependentGoals      = combine installIndependentGoals,+        installShadowPkgs            = combine installShadowPkgs,+        installStrongFlags           = combine installStrongFlags,+        installReinstall             = combine installReinstall,+        installAvoidReinstalls       = combine installAvoidReinstalls,+        installOverrideReinstall     = combine installOverrideReinstall,+        installUpgradeDeps           = combine installUpgradeDeps,+        installOnly                  = combine installOnly,+        installOnlyDeps              = combine installOnlyDeps,+        installRootCmd               = combine installRootCmd,+        installSummaryFile           = lastNonEmptyNL installSummaryFile,+        installLogFile               = combine installLogFile,+        installBuildReports          = combine installBuildReports,+        installReportPlanningFailure = combine installReportPlanningFailure,+        installSymlinkBinDir         = combine installSymlinkBinDir,+        installOneShot               = combine installOneShot,+        installNumJobs               = combine installNumJobs,+        installRunTests              = combine installRunTests,+        installOfflineMode           = combine installOfflineMode+        }+        where+          combine        = combine'        savedInstallFlags+          lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags++      combinedSavedConfigureFlags = ConfigFlags {+        configPrograms            = configPrograms . savedConfigureFlags $ b,+        -- TODO: NubListify+        configProgramPaths        = lastNonEmpty configProgramPaths,+        -- TODO: NubListify+        configProgramArgs         = lastNonEmpty configProgramArgs,+        configProgramPathExtra    = lastNonEmptyNL configProgramPathExtra,+        configHcFlavor            = combine configHcFlavor,+        configHcPath              = combine configHcPath,+        configHcPkg               = combine configHcPkg,+        configVanillaLib          = combine configVanillaLib,+        configProfLib             = combine configProfLib,+        configProf                = combine configProf,+        configSharedLib           = combine configSharedLib,+        configDynExe              = combine configDynExe,+        configProfExe             = combine configProfExe,+        configProfDetail          = combine configProfDetail,+        configProfLibDetail       = combine configProfLibDetail,+        -- TODO: NubListify+        configConfigureArgs       = lastNonEmpty configConfigureArgs,+        configOptimization        = combine configOptimization,+        configDebugInfo           = combine configDebugInfo,+        configProgPrefix          = combine configProgPrefix,+        configProgSuffix          = combine configProgSuffix,+        -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.+        configInstallDirs         =+          (configInstallDirs . savedConfigureFlags $ a)+          `mappend` (configInstallDirs . savedConfigureFlags $ b),+        configScratchDir          = combine configScratchDir,+        -- TODO: NubListify+        configExtraLibDirs        = lastNonEmpty configExtraLibDirs,+        -- TODO: NubListify+        configExtraIncludeDirs    = lastNonEmpty configExtraIncludeDirs,+        configDistPref            = combine configDistPref,+        configVerbosity           = combine configVerbosity,+        configUserInstall         = combine configUserInstall,+        -- TODO: NubListify+        configPackageDBs          = lastNonEmpty configPackageDBs,+        configGHCiLib             = combine configGHCiLib,+        configSplitObjs           = combine configSplitObjs,+        configStripExes           = combine configStripExes,+        configStripLibs           = combine configStripLibs,+        -- TODO: NubListify+        configConstraints         = lastNonEmpty configConstraints,+        -- TODO: NubListify+        configDependencies        = lastNonEmpty configDependencies,+        configInstantiateWith     = lastNonEmpty configInstantiateWith,+        -- TODO: NubListify+        configConfigurationsFlags = lastNonEmpty configConfigurationsFlags,+        configTests               = combine configTests,+        configBenchmarks          = combine configBenchmarks,+        configCoverage            = combine configCoverage,+        configLibCoverage         = combine configLibCoverage,+        configExactConfiguration  = combine configExactConfiguration,+        configFlagError           = combine configFlagError,+        configRelocatable         = combine configRelocatable+        }+        where+          combine        = combine'        savedConfigureFlags+          lastNonEmpty   = lastNonEmpty'   savedConfigureFlags+          lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags++      combinedSavedConfigureExFlags = ConfigExFlags {+        configCabalVersion  = combine configCabalVersion,+        -- TODO: NubListify+        configExConstraints = lastNonEmpty configExConstraints,+        -- TODO: NubListify+        configPreferences   = lastNonEmpty configPreferences,+        configSolver        = combine configSolver,+        configAllowNewer    = combine configAllowNewer+        }+        where+          combine      = combine' savedConfigureExFlags+          lastNonEmpty = lastNonEmpty' savedConfigureExFlags++      -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.+      combinedSavedUserInstallDirs = savedUserInstallDirs a+                                     `mappend` savedUserInstallDirs b++      -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.+      combinedSavedGlobalInstallDirs = savedGlobalInstallDirs a+                                       `mappend` savedGlobalInstallDirs b++      combinedSavedUploadFlags = UploadFlags {+        uploadCheck       = combine uploadCheck,+        uploadUsername    = combine uploadUsername,+        uploadPassword    = combine uploadPassword,+        uploadPasswordCmd = combine uploadPasswordCmd,+        uploadVerbosity   = combine uploadVerbosity+        }+        where+          combine = combine' savedUploadFlags++      combinedSavedReportFlags = ReportFlags {+        reportUsername  = combine reportUsername,+        reportPassword  = combine reportPassword,+        reportVerbosity = combine reportVerbosity+        }+        where+          combine = combine' savedReportFlags++      combinedSavedHaddockFlags = HaddockFlags {+        -- TODO: NubListify+        haddockProgramPaths  = lastNonEmpty haddockProgramPaths,+        -- TODO: NubListify+        haddockProgramArgs   = lastNonEmpty haddockProgramArgs,+        haddockHoogle        = combine haddockHoogle,+        haddockHtml          = combine haddockHtml,+        haddockHtmlLocation  = combine haddockHtmlLocation,+        haddockExecutables   = combine haddockExecutables,+        haddockTestSuites    = combine haddockTestSuites,+        haddockBenchmarks    = combine haddockBenchmarks,+        haddockInternal      = combine haddockInternal,+        haddockCss           = combine haddockCss,+        haddockHscolour      = combine haddockHscolour,+        haddockHscolourCss   = combine haddockHscolourCss,+        haddockContents      = combine haddockContents,+        haddockDistPref      = combine haddockDistPref,+        haddockKeepTempFiles = combine haddockKeepTempFiles,+        haddockVerbosity     = combine haddockVerbosity+        }+        where+          combine      = combine'        savedHaddockFlags+          lastNonEmpty = lastNonEmpty'   savedHaddockFlags++ -- -- * Default config --@@ -207,14 +428,14 @@   return mempty {     savedGlobalFlags     = mempty {       globalCacheDir     = toFlag cacheDir,-      globalRemoteRepos  = [defaultRemoteRepo],+      globalRemoteRepos  = toNubList [addInfoForKnownRepos defaultRemoteRepo],       globalWorldFile    = toFlag worldFile     },     savedConfigureFlags  = mempty {-      configProgramPathExtra = extraPath+      configProgramPathExtra = toNubList extraPath     },     savedInstallFlags    = mempty {-      installSummaryFile = [toPathTemplate (logsDir </> "build.log")],+      installSummaryFile = toNubList [toPathTemplate (logsDir </> "build.log")],       installBuildReports= toFlag AnonymousReports,       installNumJobs     = toFlag Nothing     }@@ -260,17 +481,40 @@ -- global installs on Windows but that no longer works on Windows Vista or 7.  defaultRemoteRepo :: RemoteRepo-defaultRemoteRepo = RemoteRepo name uri+defaultRemoteRepo = RemoteRepo name uri () False   where     name = "hackage.haskell.org"-    uri  = URI "http:" (Just (URIAuth "" name "")) "/packages/archive" "" ""+    uri  = URI "http:" (Just (URIAuth "" name "")) "/" "" ""+    -- Note that lots of old ~/.cabal/config files will have the old url+    -- http://hackage.haskell.org/packages/archive+    -- but new config files can use the new url (without the /packages/archive)+    -- and avoid having to do a http redirect +    -- Use this as a source for crypto credentials when finding old remote-repo+    -- entries that match repo name and url (not only be used for generating+    -- fresh config files).++-- For the default repo we know extra information, fill this in. --+-- We need this because the 'defaultRemoteRepo' above is only used for the+-- first time when a config file is made. So for users with older config files+-- we might have only have older info. This lets us fill that in even for old+-- config files.+--+addInfoForKnownRepos :: RemoteRepo -> RemoteRepo+addInfoForKnownRepos repo@RemoteRepo{ remoteRepoName = "hackage.haskell.org" } =+    repo {+      --remoteRepoRootKeys --TODO: when this list is empty, fill in known crypto credentials+      remoteRepoShouldTryHttps = True+    }+addInfoForKnownRepos other = other++-- -- * Config file reading -- -loadConfig :: Verbosity -> Flag FilePath -> Flag Bool -> IO SavedConfig-loadConfig verbosity configFileFlag userInstallFlag = addBaseConf $ do+loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig+loadConfig verbosity configFileFlag = addBaseConf $ do   let sources = [         ("commandline option",   return . flagToMaybe $ configFileFlag),         ("env var CABAL_CONFIG", lookup "CABAL_CONFIG" `liftM` getEnvironment),@@ -297,21 +541,20 @@       return conf     Just (ParseFailed err) -> do       let (line, msg) = locatedErrorMsg err-      warn verbosity $+      die $           "Error parsing config file " ++ configFile         ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg-      warn verbosity "Using default configuration."-      initialSavedConfig    where     addBaseConf body = do       base  <- baseSavedConfig       extra <- body-      return (updateInstallDirs userInstallFlag (base `mappend` extra))+      return (base `mappend` extra)  readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) readConfigFile initial file = handleNotExists $-  fmap (Just . parseConfig initial) (readFile file)+  fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial)+       (readFile file)    where     handleNotExists action = catchIO action $ \ioe ->@@ -335,6 +578,9 @@       ,"-- 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+      ,"-- cabal-install version: " ++ showVersion Paths_cabal_install.version       ,"",""       ] @@ -357,21 +603,22 @@     savedUserInstallDirs   = fmap toFlag userInstallDirs,     savedGlobalInstallDirs = fmap toFlag globalInstallDirs,     savedUploadFlags       = commandDefaultFlags uploadCommand,-    savedReportFlags       = commandDefaultFlags reportCommand+    savedReportFlags       = commandDefaultFlags reportCommand,+    savedHaddockFlags      = defaultHaddockFlags   }  -- | All config file fields. ---configFieldDescriptions :: [FieldDescr SavedConfig]-configFieldDescriptions =+configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig]+configFieldDescriptions src =       toSavedConfig liftGlobalFlag-       (commandOptions globalCommand ParseArgs)+       (commandOptions (globalCommand []) ParseArgs)        ["version", "numeric-version", "config-file", "sandbox-config-file"] []    ++ toSavedConfig liftConfigFlag        (configureOptions ParseArgs)-       (["builddir", "configure-option", "constraint", "dependency"]+       (["builddir", "constraint", "dependency"]         ++ map fieldName installDirsFields)          --FIXME: this is only here because viewAsFieldDescr gives us a parser@@ -380,10 +627,11 @@        [simpleField "compiler"           (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)           configHcFlavor (\v flags -> flags { configHcFlavor = v })-        -- TODO: The following is a temporary fix. The "optimization" field is-        -- OptArg, and viewAsFieldDescr fails on that. Instead of a hand-written-        -- hackaged parser and printer, we should handle this case properly in-        -- the library.+        -- TODO: The following is a temporary fix. The "optimization"+        -- and "debug-info" fields are OptArg, and viewAsFieldDescr+        -- fails on that. Instead of a hand-written hackaged parser+        -- and printer, we should handle this case properly in the+        -- library.        ,liftField configOptimization (\v flags -> flags { configOptimization = v }) $         let name = "optimization" in         FieldDescr name@@ -405,10 +653,33 @@                lstr = lowercase str                caseWarning = PWarning $                  "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")+       ,liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $+        let name = "debug-info" in+        FieldDescr name+          (\f -> case f of+                   Flag NoDebugInfo      -> Disp.text "False"+                   Flag MinimalDebugInfo -> Disp.text "1"+                   Flag NormalDebugInfo  -> Disp.text "True"+                   Flag MaximalDebugInfo -> Disp.text "3"+                   _                     -> Disp.empty)+          (\line str _ -> case () of+           _ |  str == "False" -> ParseOk [] (Flag NoDebugInfo)+             |  str == "True"  -> ParseOk [] (Flag NormalDebugInfo)+             |  str == "0"     -> ParseOk [] (Flag NoDebugInfo)+             |  str == "1"     -> ParseOk [] (Flag MinimalDebugInfo)+             |  str == "2"     -> ParseOk [] (Flag NormalDebugInfo)+             |  str == "3"     -> ParseOk [] (Flag MaximalDebugInfo)+             | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo)+             | lstr == "true"  -> ParseOk [caseWarning] (Flag NormalDebugInfo)+             | otherwise       -> ParseFailed (NoParse name line)+             where+               lstr = lowercase str+               caseWarning = PWarning $+                 "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")        ]    ++ toSavedConfig liftConfigExFlag-       (configureExOptions ParseArgs)+       (configureExOptions ParseArgs src)        [] []    ++ toSavedConfig liftInstallFlag@@ -422,11 +693,23 @@   ++ toSavedConfig liftReportFlag        (commandOptions reportCommand ParseArgs)        ["verbose", "username", "password"] []-       --FIXME: this is a hack, hiding the username and password.+       --FIXME: this is a hack, hiding the user name and password.        -- But otherwise it masks the upload ones. Either need to        -- share the options or make then distinct. In any case        -- they should probably be per-server. +  ++ [ viewAsFieldDescr+       $ optionDistPref+       (configDistPref . savedConfigureFlags)+       (\distPref config ->+          config+          { savedConfigureFlags = (savedConfigureFlags config) { configDistPref = distPref }+          , savedHaddockFlags = (savedHaddockFlags config) { haddockDistPref = distPref }+          }+       )+       ParseArgs+     ]+   where     toSavedConfig lift options exclusions replacements =       [ lift (fromMaybe field replacement)@@ -444,7 +727,8 @@   [ liftGlobalFlag $     listField "repos"       (Disp.text . showRepo) parseRepo-      globalRemoteRepos (\rs cfg -> cfg { globalRemoteRepos = rs })+      (fromNubList . globalRemoteRepos)+      (\rs cfg -> cfg { globalRemoteRepos = toNubList rs })   , liftGlobalFlag $     simpleField "cachedir"       (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ)@@ -459,6 +743,11 @@       (Disp.text . fromFlagOrDefault "" . fmap unPassword)       (optional (fmap Password parseTokenQ))       uploadPassword    (\d cfg -> cfg { uploadPassword = d })+  , liftUploadFlag $+    spaceListField "hackage-password-command"+      Disp.text parseTokenQ+      (fromFlagOrDefault [] . uploadPasswordCmd)+                        (\d cfg -> cfg { uploadPasswordCmd = Flag d })   ]  ++ map (modifyFieldName ("user-"++)   . liftUserInstallDirs)   installDirsFields  ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields@@ -501,53 +790,91 @@ liftReportFlag = liftField   savedReportFlags (\flags conf -> conf { savedReportFlags = flags }) -parseConfig :: SavedConfig -> String -> ParseResult SavedConfig-parseConfig initial = \str -> do+parseConfig :: ConstraintSource+            -> SavedConfig+            -> String+            -> ParseResult SavedConfig+parseConfig src initial = \str -> do   fields <- readFields str   let (knownSections, others) = partition isKnownSection fields   config <- parse others   let user0   = savedUserInstallDirs config       global0 = savedGlobalInstallDirs config-  (user, global, paths, args) <--    foldM parseSections (user0, global0, [], []) knownSections+  (remoteRepoSections0, haddockFlags, user, global, paths, args) <-+    foldM parseSections+          ([], savedHaddockFlags config, user0, global0, [], [])+          knownSections++  let remoteRepoSections =+          map addInfoForKnownRepos+        . reverse+        . nubBy ((==) `on` remoteRepoName)+        $ remoteRepoSections0+   return config {+    savedGlobalFlags       = (savedGlobalFlags config) {+       globalRemoteRepos   = toNubList remoteRepoSections+       },     savedConfigureFlags    = (savedConfigureFlags config) {        configProgramPaths  = paths,        configProgramArgs   = args        },+    savedHaddockFlags      = haddockFlags,     savedUserInstallDirs   = user,     savedGlobalInstallDirs = global   }    where+    isKnownSection (ParseUtils.Section _ "remote-repo" _ _)             = True+    isKnownSection (ParseUtils.F _ "remote-repo" _)                     = True+    isKnownSection (ParseUtils.Section _ "haddock" _ _)                 = True     isKnownSection (ParseUtils.Section _ "install-dirs" _ _)            = True     isKnownSection (ParseUtils.Section _ "program-locations" _ _)       = True     isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True     isKnownSection _                                                    = False -    parse = parseFields (configFieldDescriptions+    parse = parseFields (configFieldDescriptions src                       ++ deprecatedFieldDescriptions) initial -    parseSections accum@(u,g,p,a) (ParseUtils.Section _ "install-dirs" name fs)+    parseSections (rs, h, u, g, p, a)+                 (ParseUtils.Section _ "remote-repo" name fs) = do+      r' <- parseFields remoteRepoFields (emptyRemoteRepo name) fs+      return (r':rs, h, u, g, p, a)++    parseSections (rs, h, u, g, p, a)+                 (ParseUtils.F lno "remote-repo" raw) = do+      let mr' = readRepo raw+      r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr'+      return (r':rs, h, u, g, p, a)++    parseSections accum@(rs, h, u, g, p, a)+                 (ParseUtils.Section _ "haddock" name fs)+      | name == ""        = do h' <- parseFields haddockFlagsFields h fs+                               return (rs, h', u, g, p, a)+      | otherwise         = do+          warning "The 'haddock' section should be unnamed"+          return accum+    parseSections accum@(rs, h, u, g, p, a)+                  (ParseUtils.Section _ "install-dirs" name fs)       | name' == "user"   = do u' <- parseFields installDirsFields u fs-                               return (u', g, p, a)+                               return (rs, h, u', g, p, a)       | name' == "global" = do g' <- parseFields installDirsFields g fs-                               return (u, g', p, a)+                               return (rs, h, u, g', p, a)       | otherwise         = do-          warning "The install-paths section should be for 'user' or 'global'"+          warning "The 'install-paths' section should be for 'user' or 'global'"           return accum       where name' = lowercase name-    parseSections accum@(u,g,p,a)+    parseSections accum@(rs, h, u, g, p, a)                  (ParseUtils.Section _ "program-locations" name fs)       | name == ""        = do p' <- parseFields withProgramsFields p fs-                               return (u, g, p', a)+                               return (rs, h, u, g, p', a)       | otherwise         = do           warning "The 'program-locations' section should be unnamed"           return accum-    parseSections accum@(u, g, p, a)+    parseSections accum@(rs, h, u, g, p, a)                   (ParseUtils.Section _ "program-default-options" name fs)       | name == ""        = do a' <- parseFields withProgramOptionsFields a fs-                               return (u, g, p, a')+                               return (rs, h, u, g, p, a')       | otherwise         = do           warning "The 'program-default-options' section should be unnamed"           return accum@@ -560,8 +887,16 @@  showConfigWithComments :: SavedConfig -> SavedConfig -> String showConfigWithComments comment vals = Disp.render $-      ppFields configFieldDescriptions mcomment vals+      case fmap ppRemoteRepoSection . fromNubList . globalRemoteRepos . savedGlobalFlags $ vals of+        [] -> Disp.text ""+        (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs   $+$ Disp.text ""+  $+$ ppFields (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown))+               mcomment vals+  $+$ Disp.text ""+  $+$ ppSection "haddock" "" haddockFlagsFields+                (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals)+  $+$ Disp.text ""   $+$ installDirsSection "user"   savedUserInstallDirs   $+$ Disp.text ""   $+$ installDirsSection "global" savedGlobalInstallDirs@@ -581,10 +916,39 @@                (fmap (field . savedConfigureFlags) mcomment)                ((field . savedConfigureFlags) vals) +    -- skip fields based on field name.  currently only skips "remote-repo",+    -- because that is rendered as a section.  (see 'ppRemoteRepoSection'.)+    skipSomeFields = filter ((/= "remote-repo") . fieldName) +-- | Fields for the 'install-dirs' sections. installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirsFields = map viewAsFieldDescr installDirsOptions +ppRemoteRepoSection :: RemoteRepo -> Doc+ppRemoteRepoSection vals = ppSection "remote-repo" (remoteRepoName vals)+        remoteRepoFields Nothing vals++remoteRepoFields :: [FieldDescr RemoteRepo]+remoteRepoFields =+    [ FieldDescr { fieldName = "url",+                   fieldGet = text . show . remoteRepoURI,+                   fieldSet = \ _ uriString remoteRepo -> maybe+                          (fail $ "remote-repo: no parse on " ++ show uriString)+                          (\ uri -> return $ remoteRepo { remoteRepoURI = uri })+                          (parseURI uriString)+                 }+    ]++-- | Fields for the 'haddock' section.+haddockFlagsFields :: [FieldDescr HaddockFlags]+haddockFlagsFields = [ field+                     | opt <- haddockOptions ParseArgs+                     , let field = viewAsFieldDescr opt+                           name  = fieldName field+                     , name `notElem` exclusions ]+  where+    exclusions = ["verbose", "builddir"]+ -- | Fields for the 'program-locations' section. withProgramsFields :: [FieldDescr [(String, FilePath)]] withProgramsFields =@@ -597,3 +961,60 @@ withProgramOptionsFields =   map viewAsFieldDescr $   programConfigurationOptions defaultProgramConfiguration 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+  return $ reverse . foldl' createDiff [] . M.toList+                $ M.unionWith combine+                    (M.fromList . map justFst $ filterShow testConfig)+                    (M.fromList . map justSnd $ filterShow userConfig)+  where+    justFst (a, b) = (a, (Just b, Nothing))+    justSnd (a, b) = (a, (Nothing, Just b))++    combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b)+    combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b)+    combine x y = error $ "Can't happen : userConfigDiff " ++ show x ++ " " ++ show y++    createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String]+    createDiff acc (key, (Just a, Just b))+        | a == b = acc+        | otherwise = ("+ " ++ key ++ ": " ++ b) : ("- " ++ key ++ ": " ++ a) : acc+    createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc+    createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc+    createDiff acc (_, (Nothing, Nothing)) = acc++    filterShow :: SavedConfig -> [(String, String)]+    filterShow cfg = map keyValueSplit+        . filter (\s -> not (null s) && any (== ':') s)+        . map nonComment+        . lines+        $ showConfig cfg++    nonComment [] = []+    nonComment ('-':'-':_) = []+    nonComment (x:xs) = x : nonComment xs++    topAndTail = reverse . dropWhile isSpace . reverse . dropWhile isSpace++    keyValueSplit s =+        let (left, right) = break (== ':') s+        in (topAndTail left, topAndTail (drop 1 right))+++-- | 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+  commentConf <- commentSavedConfig+  cabalFile <- defaultConfigFile+  let backup = cabalFile ++ ".backup"+  notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "."+  renameFile cabalFile backup+  notice verbosity $ "Writing merged config to " ++ cabalFile ++ "."+  writeConfigFile cabalFile commentConf (newConfig `mappend` userConfig)

cabal/cabal-install/Distribution/Client/Configure.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Configure@@ -12,35 +13,46 @@ ----------------------------------------------------------------------------- module Distribution.Client.Configure (     configure,+    configureSetupScript,     chooseCabalVersion,+    checkConfigExFlags   ) where  import Distribution.Client.Dependency-import Distribution.Client.Dependency.Types (AllowNewer(..), isAllowNewer)+import Distribution.Client.Dependency.Types+         ( AllowNewer(..), isAllowNewer, ConstraintSource(..)+         , LabeledPackageConstraint(..), showConstraintSource ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages )+import Distribution.Client.PackageIndex ( PackageIndex, elemByPackageName ) import Distribution.Client.Setup          ( ConfigExFlags(..), configureCommand, filterConfigureFlags ) import Distribution.Client.Types as Source import Distribution.Client.SetupWrapper          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Targets-         ( userToPackageConstraint )+         ( userToPackageConstraint, userConstraintPackageName )+import qualified Distribution.Client.ComponentDeps as CD+import Distribution.Package (PackageId)+import Distribution.Client.JobControl (Lock)  import Distribution.Simple.Compiler-         ( CompilerId(..), Compiler(compilerId)-         , PackageDB(..), PackageDBStack )+         ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration ) import Distribution.Simple.Setup          ( ConfigFlags(..), fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )-import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.Simple.PackageIndex+         ( InstalledPackageIndex, lookupPackageName ) import Distribution.Simple.Utils          ( defaultPackageDesc ) import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package-         ( Package(..), packageName, Dependency(..), thisPackageVersion )+         ( Package(..), InstalledPackageId, packageName+         , Dependency(..), thisPackageVersion+         )+import qualified Distribution.PackageDescription as PkgDesc import Distribution.PackageDescription.Parse          ( readPackageDescription ) import Distribution.PackageDescription.Configuration@@ -48,15 +60,20 @@ import Distribution.Version          ( anyVersion, thisVersion ) import Distribution.Simple.Utils as Utils-         ( notice, debug, die )+         ( warn, notice, info, debug, die ) 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)  -- | Choose the Cabal version such that the setup scripts compiled against this -- version will support the given command-line flags.@@ -64,6 +81,8 @@ chooseCabalVersion configExFlags maybeVersion =   maybe defaultVersionRange thisVersion maybeVersion   where+    -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed+    -- for '--allow-newer' to work.     allowNewer = fromFlagOrDefault False $                  fmap isAllowNewer (configAllowNewer configExFlags) @@ -87,6 +106,8 @@    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf   sourcePkgDb       <- getSourcePackages    verbosity repos+  checkConfigExFlags verbosity installedPkgIndex+                     (packageIndex sourcePkgDb) configExFlags    progress <- planLocalPackage verbosity comp platform configFlags configExFlags                                installedPkgIndex sourcePkgDb@@ -95,62 +116,160 @@   maybePlan <- foldProgress logMsg (return . Left) (return . Right)                             progress   case maybePlan of-    Left message -> die message+    Left message -> do+      info verbosity $+           "Warning: solver failed to find a solution:\n"+        ++ message+        ++ "Trying configure anyway."+      setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing)+        Nothing configureCommand (const configFlags) extraArgs      Right installPlan -> case InstallPlan.ready installPlan of-      [pkg@(ReadyPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) _ _ _)] ->+      [pkg@(ReadyPackage+             (ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _) _)+                                 _ _ _)+             _)] -> do         configurePackage verbosity-          (InstallPlan.planPlatform installPlan)-          (InstallPlan.planCompiler installPlan)-          (setupScriptOptions installedPkgIndex)+          platform (compilerInfo comp)+          (setupScriptOptions installedPkgIndex (Just pkg))           configFlags pkg extraArgs        _ -> die $ "internal error: configure install plan should have exactly "               ++ "one local ready package."    where-    setupScriptOptions index = SetupScriptOptions {-      useCabalVersion  = chooseCabalVersion configExFlags-                         (flagToMaybe (configCabalVersion configExFlags)),-      useCompiler      = Just comp,-      usePlatform      = Just platform,-      usePackageDB     = packageDBs',-      usePackageIndex  = index',-      useProgramConfig = conf,-      useDistPref      = fromFlagOrDefault-                           (useDistPref defaultSetupScriptOptions)-                           (configDistPref configFlags),-      useLoggingHandle = Nothing,-      useWorkingDir    = Nothing,-      forceExternalSetupMethod = False,-      setupCacheLock   = Nothing-    }-      where-        -- Hack: we typically want to allow the UserPackageDB for finding the-        -- Cabal lib when compiling any Setup.hs even if we're doing a global-        -- install. However we also allow looking in a specific package db.-        (packageDBs', index') =-          case packageDBs of-            (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs-                -> (GlobalPackageDB:UserPackageDB:dbs, Nothing)-            -- but if the user is using an odd db stack, don't touch it-            dbs -> (dbs, Just index)+    setupScriptOptions :: InstalledPackageIndex+                       -> Maybe ReadyPackage+                       -> SetupScriptOptions+    setupScriptOptions =+      configureSetupScript+        packageDBs+        comp+        platform+        conf+        (fromFlagOrDefault+           (useDistPref defaultSetupScriptOptions)+           (configDistPref configFlags))+        (chooseCabalVersion+           configExFlags+           (flagToMaybe (configCabalVersion configExFlags)))+        Nothing+        False      logMsg message rest = debug verbosity message >> rest +configureSetupScript :: PackageDBStack+                     -> Compiler+                     -> Platform+                     -> ProgramConfiguration+                     -> FilePath+                     -> VersionRange+                     -> Maybe Lock+                     -> Bool+                     -> InstalledPackageIndex+                     -> Maybe ReadyPackage+                     -> SetupScriptOptions+configureSetupScript packageDBs+                     comp+                     platform+                     conf+                     distPref+                     cabalVersion+                     lock+                     forceExternal+                     index+                     mpkg+  = SetupScriptOptions {+      useCabalVersion   = cabalVersion+    , useCompiler       = Just comp+    , usePlatform       = Just platform+    , usePackageDB      = packageDBs'+    , usePackageIndex   = index'+    , useProgramConfig  = conf+    , useDistPref       = distPref+    , useLoggingHandle  = Nothing+    , useWorkingDir     = Nothing+    , 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+      -- Cabal here, so that we no longer need the special case for that in+      -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet+      -- 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+    }+  where+    -- When we are compiling a legacy setup script without an explicit+    -- setup stanza, we typically want to allow the UserPackageDB for+    -- finding the Cabal lib when compiling any Setup.hs even if we're doing+    -- a global install. However we also allow looking in a specific package+    -- db.+    packageDBs' :: PackageDBStack+    index'      :: Maybe InstalledPackageIndex+    (packageDBs', index') =+      case packageDBs of+        (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs+                              , Nothing <- explicitSetupDeps+            -> (GlobalPackageDB:UserPackageDB:dbs, Nothing)+        -- but if the user is using an odd db stack, don't touch it+        _otherwise -> (packageDBs, Just index)++    explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)]+    explicitSetupDeps = do+      ReadyPackage (ConfiguredPackage (SourcePackage _ gpkg _ _) _ _ _) deps+                 <- mpkg+      -- Check if there is an explicit setup stanza+      _buildInfo <- PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)+      -- Return the setup dependencies computed by the solver+      return [ ( Installed.installedPackageId deppkg+               , Installed.sourcePackageId    deppkg+               )+             | deppkg <- CD.setupDeps deps+             ]++-- | Warn if any constraints or preferences name packages that are not in the+-- source package index or installed package index.+checkConfigExFlags :: Package pkg+                   => Verbosity+                   -> InstalledPackageIndex+                   -> PackageIndex pkg+                   -> ConfigExFlags+                   -> IO ()+checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do+  unless (null unknownConstraints) $ warn verbosity $+             "Constraint refers to an unknown package: "+          ++ showConstraint (head unknownConstraints)+  unless (null unknownPreferences) $ warn verbosity $+             "Preference refers to an unknown package: "+          ++ display (head unknownPreferences)+  where+    unknownConstraints = filter (unknown . userConstraintPackageName . fst) $+                         configExConstraints flags+    unknownPreferences = filter (unknown . \(Dependency name _) -> name) $+                         configPreferences flags+    unknown pkg = null (lookupPackageName installedPkgIndex pkg)+               && not (elemByPackageName sourcePkgIndex pkg)+    showConstraint (uc, src) =+        display uc ++ " (" ++ showConstraintSource src ++ ")"+ -- | Make an 'InstallPlan' for the unpacked package in the current directory, -- and all its dependencies. -- planLocalPackage :: Verbosity -> Compiler                  -> Platform                  -> ConfigFlags -> ConfigExFlags-                 -> PackageIndex+                 -> InstalledPackageIndex                  -> SourcePackageDb                  -> IO (Progress String String InstallPlan)-planLocalPackage verbosity comp platform configFlags configExFlags installedPkgIndex+planLocalPackage verbosity comp platform configFlags configExFlags+  installedPkgIndex   (SourcePackageDb _ packagePrefs) = do   pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity-  solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerId comp)+  solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags)+            (compilerInfo comp)    let -- We create a local package and ask to resolve a dependency on it       localPkg = SourcePackage {@@ -177,19 +296,23 @@             -- version constraints from the config file or command line             -- TODO: should warn or error on constraints that are not on direct             -- deps or flag constraints not on the package in question.-            (map userToPackageConstraint (configExConstraints configExFlags))+            [ LabeledPackageConstraint (userToPackageConstraint uc) src+            | (uc, src) <- configExConstraints configExFlags ]          . addConstraints             -- package flags from the config file or command line-            [ PackageConstraintFlags (packageName pkg)-                                     (configConfigurationsFlags configFlags) ]+            [ let pc = PackageConstraintFlags (packageName pkg)+                       (configConfigurationsFlags configFlags)+              in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget+            ]          . addConstraints             -- '--enable-tests' and '--enable-benchmarks' constraints from-            -- command line-            [ PackageConstraintStanzas (packageName pkg) $-                [ TestStanzas  | testsEnabled ] ++-                [ BenchStanzas | benchmarksEnabled ]+            -- the config file or command line+            [ let pc = PackageConstraintStanzas (packageName pkg) $+                       [ TestStanzas  | testsEnabled ] +++                       [ BenchStanzas | benchmarksEnabled ]+              in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget             ]          $ standardInstallPolicy@@ -197,7 +320,7 @@             (SourcePackageDb mempty packagePrefs)             [SpecificSourcePackage localPkg] -  return (resolveDependencies platform (compilerId comp) solver resolverParams)+  return (resolveDependencies platform (compilerInfo comp) solver resolverParams)   -- | Call an installer for an 'SourcePackage' but override the configure@@ -209,14 +332,17 @@ -- NB: when updating this function, don't forget to also update -- 'installReadyPackage' in D.C.Install. configurePackage :: Verbosity-                 -> Platform -> CompilerId+                 -> Platform -> CompilerInfo                  -> SetupScriptOptions                  -> ConfigFlags                  -> ReadyPackage                  -> [String]                  -> IO () configurePackage verbosity platform comp scriptOptions configFlags-  (ReadyPackage (SourcePackage _ gpkg _ _) flags stanzas deps) extraArgs =+                 (ReadyPackage (ConfiguredPackage (SourcePackage _ gpkg _ _)+                                                  flags stanzas _)+                               deps)+                 extraArgs =    setupWrapper verbosity     scriptOptions (Just pkg) configureCommand configureFlags extraArgs@@ -228,10 +354,10 @@       -- deps.  In the end only one set gets passed to Setup.hs configure,       -- depending on the Cabal version we are talking to.       configConstraints  = [ thisPackageVersion (packageId deppkg)-                           | deppkg <- deps ],+                           | deppkg <- CD.nonSetupDeps deps ],       configDependencies = [ (packageName (Installed.sourcePackageId deppkg),                               Installed.installedPackageId deppkg)-                           | deppkg <- deps ],+                           | deppkg <- CD.nonSetupDeps deps ],       -- Use '--exact-configuration' if supported.       configExactConfiguration = toFlag True,       configVerbosity          = toFlag verbosity,

cabal/cabal-install/Distribution/Client/Dependency.hs view

@@ -37,7 +37,7 @@     applySandboxInstallPolicy,      -- ** Extra policy options-    dontUpgradeBasePackage,+    dontUpgradeNonUpgradeablePackages,     hideBrokenInstalledPackages,     upgradeDependencies,     reinstallTargets,@@ -50,6 +50,7 @@     setIndependentGoals,     setAvoidReinstalls,     setShadowPkgs,+    setStrongFlags,     setMaxBackjumps,     addSourcePackages,     hideInstalledPackagesSpecificByInstalledPackageId,@@ -63,36 +64,50 @@ import Distribution.Client.Dependency.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.Types-         ( SourcePackageDb(SourcePackageDb)-         , SourcePackage(..) )+         ( SourcePackageDb(SourcePackageDb), SourcePackage(..)+         , ConfiguredPackage(..), ConfiguredId(..), enableStanzas ) import Distribution.Client.Dependency.Types-         ( PreSolver(..), Solver(..), DependencyResolver, PackageConstraint(..)+         ( PreSolver(..), Solver(..), DependencyResolver, ResolverPackage(..)+         , PackageConstraint(..), showPackageConstraint+         , LabeledPackageConstraint(..), unlabelPackageConstraint+         , ConstraintSource(..), showConstraintSource          , AllowNewer(..), PackagePreferences(..), InstalledPreference(..)          , PackagesPreferenceDefault(..)          , Progress(..), foldProgress ) 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(..), PackageId, Package(..), packageName, packageVersion+         ( PackageName(..), PackageIdentifier(PackageIdentifier), PackageId+         , Package(..), packageName, packageVersion          , InstalledPackageId, Dependency(Dependency)) import qualified Distribution.PackageDescription as PD-         ( PackageDescription(..), GenericPackageDescription(..)-         , Library(..), Executable(..), TestSuite(..), Benchmark(..), CondTree)+         ( PackageDescription(..), Library(..), Executable(..)+         , TestSuite(..), Benchmark(..), SetupBuildInfo(..)+         , GenericPackageDescription(..), CondTree+         , Flag(flagName), FlagName(..) ) import Distribution.PackageDescription (BuildInfo(targetBuildDepends))-import Distribution.PackageDescription.Configuration (mapCondTree)+import Distribution.PackageDescription.Configuration+         ( mapCondTree, finalizePackageDescription )+import Distribution.Client.PackageUtils+         ( externalBuildDepends ) import Distribution.Version-         ( Version(..), VersionRange, anyVersion, thisVersion, withinRange+         ( VersionRange, anyVersion, thisVersion, withinRange          , removeUpperBound, simplifyVersionRange ) import Distribution.Compiler-         ( CompilerId(..), CompilerFlavor(..) )+         ( CompilerInfo(..) ) import Distribution.System          ( Platform )+import Distribution.Client.Utils+         ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) import Distribution.Simple.Utils          ( comparing, warn, info ) import Distribution.Text@@ -100,12 +115,17 @@ import Distribution.Verbosity          ( Verbosity ) -import Data.List (maximumBy, foldl')+import Data.List+         ( foldl', sort, sortBy, nubBy, maximumBy, intercalate )+import Data.Function (on) import Data.Maybe (fromMaybe) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set)+import Control.Exception+         ( assert ) + -- ------------------------------------------------------------ -- * High level planner policy -- ------------------------------------------------------------@@ -116,18 +136,33 @@ -- data DepResolverParams = DepResolverParams {        depResolverTargets           :: [PackageName],-       depResolverConstraints       :: [PackageConstraint],+       depResolverConstraints       :: [LabeledPackageConstraint],        depResolverPreferences       :: [PackagePreference],        depResolverPreferenceDefault :: PackagesPreferenceDefault,-       depResolverInstalledPkgIndex :: InstalledPackageIndex.PackageIndex,+       depResolverInstalledPkgIndex :: InstalledPackageIndex,        depResolverSourcePkgIndex    :: PackageIndex.PackageIndex SourcePackage,        depResolverReorderGoals      :: Bool,        depResolverIndependentGoals  :: Bool,        depResolverAvoidReinstalls   :: Bool,        depResolverShadowPkgs        :: Bool,+       depResolverStrongFlags       :: Bool,        depResolverMaxBackjumps      :: Maybe Int      } +showDepResolverParams :: DepResolverParams -> String+showDepResolverParams p =+     "targets: " ++ intercalate ", " (map display (depResolverTargets p))+  ++ "\nconstraints: "+  ++   concatMap (("\n  " ++) . showLabeledConstraint)+       (depResolverConstraints p)+  ++ "\npreferences: "+  ++   concatMap (("\n  " ++) . showPackagePreference)+       (depResolverPreferences p)+  ++ "\nstrategy: " ++ show (depResolverPreferenceDefault p)+  where+    showLabeledConstraint :: LabeledPackageConstraint -> String+    showLabeledConstraint (LabeledPackageConstraint pc src) =+        showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")"  -- | A package selection preference for a particular package. --@@ -143,7 +178,16 @@      -- | If we prefer versions of packages that are already installed.    | PackageInstalledPreference PackageName InstalledPreference -basicDepResolverParams :: InstalledPackageIndex.PackageIndex+-- | Provide a textual representation of a package preference+-- for debugging purposes.+--+showPackagePreference :: PackagePreference -> String+showPackagePreference (PackageVersionPreference   pn vr) =+  display pn ++ " " ++ display (simplifyVersionRange vr)+showPackagePreference (PackageInstalledPreference pn ip) =+  display pn ++ " " ++ show ip++basicDepResolverParams :: InstalledPackageIndex                        -> PackageIndex.PackageIndex SourcePackage                        -> DepResolverParams basicDepResolverParams installedPkgIndex sourcePkgIndex =@@ -158,6 +202,7 @@        depResolverIndependentGoals  = False,        depResolverAvoidReinstalls   = False,        depResolverShadowPkgs        = False,+       depResolverStrongFlags       = False,        depResolverMaxBackjumps      = Nothing      } @@ -168,7 +213,7 @@       depResolverTargets = extraTargets ++ depResolverTargets params     } -addConstraints :: [PackageConstraint]+addConstraints :: [LabeledPackageConstraint]                -> DepResolverParams -> DepResolverParams addConstraints extraConstraints params =     params {@@ -215,24 +260,35 @@       depResolverShadowPkgs = b     } +setStrongFlags :: Bool -> DepResolverParams -> DepResolverParams+setStrongFlags b params =+    params {+      depResolverStrongFlags = b+    }+ setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams setMaxBackjumps n params =     params {       depResolverMaxBackjumps = n     } -dontUpgradeBasePackage :: DepResolverParams -> DepResolverParams-dontUpgradeBasePackage params =+-- | Some packages are specific to a given compiler version and should never be+-- upgraded.+dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams+dontUpgradeNonUpgradeablePackages params =     addConstraints extraConstraints params   where     extraConstraints =-      [ PackageConstraintInstalled pkgname+      [ LabeledPackageConstraint+        (PackageConstraintInstalled pkgname)+        ConstraintSourceNonUpgradeablePackage       | all (/=PackageName "base") (depResolverTargets params)-      , pkgname <-  [ PackageName "base", PackageName "ghc-prim" ]+      , pkgname <- map PackageName [ "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 contraints separate from needing packages.+    -- Need to refactor constraints separate from needing packages.     isInstalled = not . null                 . InstalledPackageIndex.lookupPackageName                                  (depResolverInstalledPkgIndex params)@@ -382,7 +438,7 @@     hideInstalledPackagesAllVersions (depResolverTargets params) params  -standardInstallPolicy :: InstalledPackageIndex.PackageIndex+standardInstallPolicy :: InstalledPackageIndex                       -> SourcePackageDb                       -> [PackageSpecifier SourcePackage]                       -> DepResolverParams@@ -426,8 +482,10 @@         (thisVersion (packageVersion pkg)) | pkg <- otherDeps ]    . addConstraints-      [ PackageConstraintVersion (packageName pkg)-        (thisVersion (packageVersion pkg)) | pkg <- modifiedDeps ]+      [ let pc = PackageConstraintVersion (packageName pkg)+                 (thisVersion (packageVersion pkg))+        in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep+      | pkg <- modifiedDeps ]    . addTargets [ packageName pkg | pkg <- modifiedDeps ] @@ -451,19 +509,20 @@ -- * Interface to the standard resolver -- ------------------------------------------------------------ -chooseSolver :: Verbosity -> PreSolver -> CompilerId -> IO Solver-chooseSolver _         AlwaysTopDown _                = return TopDown-chooseSolver _         AlwaysModular _                = return Modular-chooseSolver verbosity Choose        (CompilerId f v) = do-  let chosenSolver | f == GHC && v <= Version [7] [] = TopDown-                   | otherwise                       = Modular-      msg TopDown = warn verbosity "Falling back to topdown solver for GHC < 7."-      msg Modular = info verbosity "Choosing modular solver."-  msg chosenSolver-  return chosenSolver+chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver+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-runSolver TopDown = const topDownResolver -- TODO: warn about unsuported options+runSolver TopDown = const topDownResolver -- TODO: warn about unsupported options runSolver Modular = modularResolver  -- | Run the dependency solver.@@ -473,25 +532,29 @@ -- logging messages and the final result or an error. -- resolveDependencies :: Platform-                    -> CompilerId+                    -> CompilerInfo                     -> Solver                     -> DepResolverParams                     -> Progress String String InstallPlan -    --TODO: is this needed here? see dontUpgradeBasePackage+    --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages resolveDependencies platform comp _solver params   | null (depResolverTargets params)-  = return (mkInstallPlan platform comp [])+  = return (validateSolverResult platform comp indGoals [])+  where+    indGoals = depResolverIndependentGoals params  resolveDependencies platform comp  solver params = -    fmap (mkInstallPlan platform comp)+    Step (showDepResolverParams finalparams)+  $ fmap (validateSolverResult platform comp indGoals)   $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls-                      shadowing maxBkjumps)+                      shadowing strFlags maxBkjumps)                      platform comp installedPkgIndex sourcePkgIndex                      preferences constraints targets   where-    DepResolverParams++    finalparams @ (DepResolverParams       targets constraints       prefs defpref       installedPkgIndex@@ -500,12 +563,13 @@       indGoals       noReinstalls       shadowing-      maxBkjumps      = dontUpgradeBasePackage+      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 Topdown solver.+                      -- into a module that is specific to the top-down solver.                       . (if solver /= Modular then hideBrokenInstalledPackages                                               else id)                       $ params@@ -513,21 +577,7 @@     preferences = interpretPackagesPreference                     (Set.fromList targets) defpref prefs --- | Make an install plan from the output of the dep resolver.--- It checks that the plan is valid, or it's an error in the dep resolver.----mkInstallPlan :: Platform-              -> CompilerId-              -> [InstallPlan.PlanPackage] -> InstallPlan-mkInstallPlan platform comp pkgIndex =-  case InstallPlan.new platform comp (PackageIndex.fromList pkgIndex) of-    Right plan     -> plan-    Left  problems -> error $ unlines $-        "internal error: could not construct a valid install plan."-      : "The proposed (invalid) plan contained the following problems:"-      : map InstallPlan.showPlanProblem problems - -- | Give an interpretation to the global 'PackagesPreference' as --  specific per-package 'PackageVersionPreference'. --@@ -560,6 +610,165 @@                                          else PreferInstalled  -- ------------------------------------------------------------+-- * Checking the result of the solver+-- ------------------------------------------------------------++-- | Make an install plan from the output of the dep resolver.+-- It checks that the plan is valid, or it's an error in the dep resolver.+--+validateSolverResult :: Platform+                     -> CompilerInfo+                     -> Bool+                     -> [ResolverPackage]+                     -> InstallPlan+validateSolverResult platform comp indepGoals pkgs =+    case planPackagesProblems platform comp pkgs of+      [] -> case InstallPlan.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++    formatPkgProblems  = formatProblemMessage . map showPlanPackageProblem+    formatPlanProblems = formatProblemMessage . map InstallPlan.showPlanProblem++    formatProblemMessage problems = +      unlines $+        "internal error: could not construct a valid install plan."+      : "The proposed (invalid) plan contained the following problems:"+      : problems+      ++ "Proposed plan:"+      : [InstallPlan.showPlanIndex index]+++data PlanPackageProblem =+       InvalidConfiguredPackage ConfiguredPackage [PackageProblem]++showPlanPackageProblem :: PlanPackageProblem -> String+showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =+     "Package " ++ display (packageId pkg)+  ++ " has an invalid configuration, in particular:\n"+  ++ unlines [ "  " ++ showPackageProblem problem+             | problem <- packageProblems ]++planPackagesProblems :: Platform -> CompilerInfo+                     -> [ResolverPackage]+                     -> [PlanPackageProblem]+planPackagesProblems platform cinfo pkgs =+     [ InvalidConfiguredPackage pkg packageProblems+     | Configured pkg <- pkgs+     , let packageProblems = configuredPackageProblems platform cinfo pkg+     , not (null packageProblems) ]++data PackageProblem = DuplicateFlag PD.FlagName+                    | MissingFlag   PD.FlagName+                    | ExtraFlag     PD.FlagName+                    | DuplicateDeps [PackageId]+                    | MissingDep    Dependency+                    | ExtraDep      PackageId+                    | InvalidDep    Dependency PackageId++showPackageProblem :: PackageProblem -> String+showPackageProblem (DuplicateFlag (PD.FlagName flag)) =+  "duplicate flag in the flag assignment: " ++ flag++showPackageProblem (MissingFlag (PD.FlagName flag)) =+  "missing an assignment for the flag: " ++ flag++showPackageProblem (ExtraFlag (PD.FlagName flag)) =+  "extra flag given that is not used by the package: " ++ flag++showPackageProblem (DuplicateDeps pkgids) =+     "duplicate packages specified as selected dependencies: "+  ++ intercalate ", " (map display pkgids)++showPackageProblem (MissingDep dep) =+     "the package has a dependency " ++ display dep+  ++ " but no package has been selected to satisfy it."++showPackageProblem (ExtraDep pkgid) =+     "the package configuration specifies " ++ display pkgid+  ++ " but (with the given flag assignment) the package does not actually"+  ++ " depend on any version of that package."++showPackageProblem (InvalidDep dep pkgid) =+     "the package depends on " ++ display dep+  ++ " but the configuration specifies " ++ display pkgid+  ++ " which does not satisfy the dependency."++-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if+-- in the configuration given by the flag assignment, all the package+-- dependencies are satisfied by the specified packages.+--+configuredPackageProblems :: Platform -> CompilerInfo+                          -> ConfiguredPackage -> [PackageProblem]+configuredPackageProblems platform cinfo+  (ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps') =+     [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]+  ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]+  ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]+  ++ [ DuplicateDeps pkgs+     | pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName))+                                specifiedDeps) ]+  ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]+  ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]+  ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps+                            , not (packageSatisfiesDependency pkgid dep) ]+  where+    specifiedDeps :: ComponentDeps [PackageId]+    specifiedDeps = fmap (map confSrcId) specifiedDeps'++    mergedFlags = mergeBy compare+      (sort $ map PD.flagName (PD.genPackageFlags (packageDescription pkg)))+      (sort $ map fst specifiedFlags)++    packageSatisfiesDependency+      (PackageIdentifier name  version)+      (Dependency        name' versionRange) = assert (name == name') $+        version `withinRange` versionRange++    dependencyName (Dependency name _) = name++    mergedDeps :: [MergeResult Dependency PackageId]+    mergedDeps = mergeDeps requiredDeps (CD.flatDeps specifiedDeps)++    mergeDeps :: [Dependency] -> [PackageId]+              -> [MergeResult Dependency PackageId]+    mergeDeps required specified =+      let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in+      mergeBy+        (\dep pkgid -> dependencyName dep `compare` packageName pkgid)+        (sortNubOn dependencyName required)+        (sortNubOn packageName    specified)++    -- TODO: It would be nicer to use ComponentDeps here so we can be more+    -- precise in our checks. That's a bit tricky though, as this currently+    -- relies on the 'buildDepends' field of 'PackageDescription'. (OTOH, that+    -- field is deprecated and should be removed anyway.)  As long as we _do_+    -- use a flat list here, we have to allow for duplicates when we fold+    -- specifiedDeps; once we have proper ComponentDeps here we should get rid+    -- of the `nubOn` in `mergeDeps`.+    requiredDeps :: [Dependency]+    requiredDeps =+      --TODO: use something lower level than finalizePackageDescription+      case finalizePackageDescription specifiedFlags+         (const True)+         platform cinfo+         []+         (enableStanzas stanzas $ packageDescription pkg) of+        Right (resolvedPkg, _) ->+             externalBuildDepends resolvedPkg+          ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg)+        Left  _ ->+          error "configuredPackageInvalidDeps internal error"+++-- ------------------------------------------------------------ -- * Simple resolver that ignores dependencies -- ------------------------------------------------------------ @@ -574,7 +783,7 @@ -- It is suitable for tasks such as selecting packages to download for user -- inspection. It is not suitable for selecting packages to install. ----- Note: if no installed package index is available, it is ok to pass 'mempty'.+-- Note: if no installed package index is available, it is OK to pass 'mempty'. -- It simply means preferences for installed packages will be ignored. -- resolveWithoutDependencies :: DepResolverParams@@ -582,7 +791,7 @@ resolveWithoutDependencies (DepResolverParams targets constraints                               prefs defpref installedPkgIndex sourcePkgIndex                               _reorderGoals _indGoals _avoidReinstalls-                              _shadowing _maxBjumps) =+                              _shadowing _strFlags _maxBjumps) =     collectEithers (map selectPackage targets)   where     selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage@@ -615,8 +824,9 @@     packageConstraints pkgname =       Map.findWithDefault anyVersion pkgname packageVersionConstraintMap     packageVersionConstraintMap =-      Map.fromList [ (name, range)-                   | PackageConstraintVersion name range <- constraints ]+      let pcs = map unlabelPackageConstraint constraints+      in Map.fromList [ (name, range)+                      | PackageConstraintVersion name range <- pcs ]      packagePreferences :: PackageName -> PackagePreferences     packagePreferences = interpretPackagesPreference

cabal/cabal-install/Distribution/Client/Dependency/Modular.hs view

@@ -26,27 +26,28 @@ import Distribution.Client.Dependency.Modular.Solver          ( SolverConfig(..), solve ) import Distribution.Client.Dependency.Types-         ( DependencyResolver, PackageConstraint(..) )-import Distribution.Client.InstallPlan-         ( PlanPackage )+         ( DependencyResolver, ResolverPackage+         , 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-modularResolver sc (Platform arch os) cid iidx sidx pprefs pcs pns =+modularResolver sc (Platform arch os) cinfo iidx sidx pprefs pcs pns =   fmap (uncurry postprocess)      $ -- convert install plan   logToProgress (maxBackjumps sc) $ -- convert log format into progress format   solve sc idx pprefs gcs pns     where       -- Indices have to be converted into solver-specific uniform index.-      idx    = convPIs os arch cid (shadowPkgs sc) iidx sidx+      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 (\ pc -> (pcName pc, [pc])) pcs)+      gcs    = M.fromListWith (++) (map pair pcs)+        where+          pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc])        -- Results have to be converted into an install plan.-      postprocess :: Assignment -> RevDepMap -> [PlanPackage]+      postprocess :: Assignment -> RevDepMap -> [ResolverPackage]       postprocess a rdm = map (convCP iidx sidx) (toCPs a rdm)        -- Helper function to extract the PN from a constraint.

cabal/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs view

@@ -6,11 +6,13 @@ import Data.List as L import Data.Map as M import Data.Maybe-import Data.Graph import Prelude hiding (pi)  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@@ -77,13 +79,13 @@ toCPs (A pa fa sa) rdm =   let     -- get hold of the graph-    g   :: Graph-    vm  :: Vertex -> ((), QPN, [QPN])+    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+    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@@ -106,17 +108,20 @@            M.toList $            sa     -- Dependencies per package.-    depp :: QPN -> [PI QPN]+    depp :: QPN -> [(Component, PI QPN)]     depp qpn = let v :: Vertex                    v   = fromJust (cvm qpn)-                   dvs :: [Vertex]+                   dvs :: [(Component, Vertex)]                    dvs = tg A.! v-               in L.map (\ dv -> case vm dv of (_, x, _) -> PI x (pa M.! x)) dvs+               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))+                                 (depp' qpn))           ps  -- | Finalize an assignment and a reverse dependency map.@@ -126,8 +131,8 @@ finalize idx (A pa fa _) rdm =   let     -- get hold of the graph-    g  :: Graph-    vm :: Vertex -> ((), QPN, [QPN])+    g  :: Graph Component+    vm :: Vertex -> ((), QPN, [(Component, QPN)])     (g, vm) = graphFromEdges' (L.map (\ (x, xs) -> ((), x, xs)) (M.toList rdm))     -- topsort the dependency graph, yielding a list of pkgs in the right order     f :: [PI QPN]

cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs view

@@ -1,4 +1,5 @@-module Distribution.Client.Dependency.Modular.Builder where+{-# LANGUAGE CPP #-}+module Distribution.Client.Dependency.Modular.Builder (buildTree) where  -- Building the search tree. --@@ -15,7 +16,6 @@ -- flag-guarded dependencies, we cannot introduce them immediately. Instead, we -- store the entire dependency. -import Control.Monad.Reader hiding (sequence, mapM) import Data.List as L import Data.Map as M import Prelude hiding (sequence, mapM)@@ -27,58 +27,79 @@ import 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-  scope :: Scope,           -- ^ information about encapsulations-  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+  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] -> BuildState -> BuildState+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] -> BuildState-    go g o []                                             = s { rdeps = g, open = o }-    go g o (ng@(OpenGoal (Flagged _ _ _ _)    _gr) : ngs) = go g (cons ng () o) ngs-    go g o (ng@(OpenGoal (Stanza  _   _  )    _gr) : ngs) = go g (cons ng () o) ngs-    go g o (ng@(OpenGoal (Simple (Dep qpn _)) _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 (qpn':) qpn g)             o  ngs-      | otherwise                                         = go (M.insert qpn [qpn']  g) (cons ng () o) ngs-                                       -- code above is correct; insert/adjust have different arg order+    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 --- | Update the current scope by taking into account the encapsulations that--- are defined for the current package.-establishScope :: QPN -> Encaps -> BuildState -> BuildState-establishScope (Q pp pn) ecs s =-    s { scope = L.foldl (\ m e -> M.insert e pp' m) (scope s) ecs }-  where-    pp' = pn : pp -- new path+    cons' = 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 PN -> FlagInfo ->+scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps Component PN -> FlagInfo ->                     BuildState -> BuildState scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s   where-    sc     = scope s-    qfdeps = L.map (fmap (qualify sc)) fdeps -- qualify all the package names+    -- 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-    gs     = L.map (flip OpenGoal gr) (qfdeps ++ qfdefs)+    -- 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. -data BuildType = Goals | OneGoal OpenGoal | Instance QPN I PInfo QGoalReasonChain+-- | 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, Scope)+build :: BuildState -> Tree QGoalReasonChain build = ana go   where-    go :: BuildState -> TreeF (QGoalReasonChain, Scope) BuildState+    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@@ -93,11 +114,11 @@     --     -- For a package, we look up the instances available in the global info,     -- and then handle each instance in turn.-    go bs@(BS { index = idx, scope = sc, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _)) gr) }) =+    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, sc) (P.fromList (L.map (\ (i, info) ->-                                                           (i, bs { next = Instance qpn i info gr }))+        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 @@ -105,8 +126,8 @@     -- that is indicated by the flag default.     --     -- TODO: Should we include the flag default in the tree?-    go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m) t f) gr) }) =-      FChoiceF qfn (gr, sc) trivial m (P.fromList (reorder b+    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@@ -114,9 +135,9 @@         reorder False = reverse         trivial = L.null t && L.null f -    go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =-      SChoiceF qsn (gr, sc) trivial (P.fromList-        [(False,                                                                        bs  { next = Goals }),+    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@@ -125,20 +146,23 @@     -- and furthermore we update the set of goals.     --     -- TODO: We could inline this above.-    go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs ecs _) gr }) =-      go ((establishScope qpn ecs-             (scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs))+    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, Scope)+buildTree :: Index -> Bool -> [PN] -> Tree QGoalReasonChain buildTree idx ind igs =-    build (BS idx sc-                  (M.fromList (L.map (\ qpn -> (qpn, []))                                                     qpns))-                  (P.fromList (L.map (\ qpn -> (OpenGoal (Simple (Dep qpn (Constrained []))) [UserGoal], ())) qpns))-                  Goals)+    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-    sc | ind       = makeIndependent igs-       | otherwise = emptyScope-    qpns           = L.map (qualify sc) igs+    topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) [UserGoal]++    qpns | ind       = makeIndependent igs+         | otherwise = L.map (Q None) igs

cabal/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs view

@@ -2,9 +2,10 @@  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] [PI qpn]+data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] (ComponentDeps [PI qpn])

cabal/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs view

@@ -3,38 +3,43 @@ import Data.Maybe import Prelude hiding (pi) -import Distribution.Client.InstallPlan import Distribution.Client.Types-import Distribution.Compiler+import Distribution.Client.Dependency.Types (ResolverPackage(..)) import qualified Distribution.Client.PackageIndex as CI import qualified Distribution.Simple.PackageIndex as SI-import Distribution.System  import Distribution.Client.Dependency.Modular.Configured import Distribution.Client.Dependency.Modular.Package -mkPlan :: Platform -> CompilerId ->-          SI.PackageIndex -> CI.PackageIndex SourcePackage ->-          [CP QPN] -> Either [PlanProblem] InstallPlan-mkPlan plat comp iidx sidx cps =-  new plat comp (CI.fromList (map (convCP iidx sidx) cps))+import Distribution.Client.ComponentDeps (ComponentDeps) -convCP :: SI.PackageIndex -> CI.PackageIndex SourcePackage ->-          CP QPN -> PlanPackage++convCP :: SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage ->+          CP QPN -> ResolverPackage convCP iidx sidx (CP qpi fa es ds) =   case convPI qpi of-    Left  pi -> PreExisting $ InstalledPackage+    Left  pi -> PreExisting                   (fromJust $ SI.lookupInstalledPackageId iidx pi)-                  (map convPI' ds)     Right pi -> Configured $ ConfiguredPackage                   (fromJust $ CI.lookupPackageId sidx pi)                   fa                   es-                  (map convPI' ds)+                  ds'+  where+    ds' :: ComponentDeps [ConfiguredId]+    ds' = fmap (map convConfId) ds  convPI :: PI QPN -> Either InstalledPackageId PackageId convPI (PI _ (I _ (Inst pi))) = Left pi-convPI qpi                    = Right $ convPI' qpi+convPI qpi                    = Right $ confSrcId $ convConfId qpi -convPI' :: PI QPN -> PackageId-convPI' (PI (Q _ pn) (I v _))  = PackageIdentifier pn v+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 -> fakeInstalledPackageId sourceId

cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs view

@@ -1,15 +1,74 @@-module Distribution.Client.Dependency.Modular.Dependency where+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RecordWildCards #-}+module Distribution.Client.Dependency.Modular.Dependency (+    -- * Variables+    Var(..)+  , simplifyVar+  , showVar+  , varPI+    -- * Conflict sets+  , ConflictSet+  , showCS+    -- * Constrained instances+  , CI(..)+  , showCI+  , merge+    -- * Flagged dependencies+  , FlaggedDeps+  , FlaggedDep(..)+  , TrueFlaggedDeps+  , FalseFlaggedDeps+  , Dep(..)+  , showDep+  , flattenFlaggedDeps+  , QualifyOptions(..)+  , qualifyDeps+    -- ** Setting/forgetting components+  , forgetCompOpenGoal+  , setCompFlaggedDeps+    -- ** Selecting subsets+  , nonSetupDeps+  , setupDeps+  , select+    -- * Reverse dependency map+  , RevDepMap+    -- * Goals+  , Goal(..)+  , GoalReason(..)+  , GoalReasonChain+  , QGoalReasonChain+  , ResetGoal(..)+  , toConflictSet+  , goalReasonToVars+  , goalReasonChainToVars+  , goalReasonChainsToVars+    -- * Open goals+  , OpenGoal(..)+  , close+    -- * Version ranges pairsed with origins (goals)+  , VROrigin+  , collapse+  ) where  import Prelude hiding (pi) -import Data.List as L-import Data.Map as M-import Data.Set as S+import Data.List (intercalate)+import Data.Map (Map)+import Data.Maybe (mapMaybe)+import Data.Set (Set)+import qualified Data.List as L+import qualified Data.Set  as S  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@@ -19,44 +78,48 @@ -- 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)+  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 -instance Functor Var where-  fmap f (P n)  = P (f n)-  fmap f (F fn) = F (fmap f fn)-  fmap f (S sn) = S (fmap f sn)+-- | 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)--instance Functor CI where-  fmap f (Fixed i g)       = Fixed i (fmap f g)-  fmap f (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, fmap f y)) vrs)--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)--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 (.&&.) anyVR . L.map fst+  deriving (Eq, Show, Functor)  showCI :: CI QPN -> String showCI (Fixed i _)      = "==" ++ showI i@@ -89,30 +152,57 @@ merge c@(Constrained _)    d@(Fixed _ _)      = merge d c merge   (Constrained rs)     (Constrained ss) = Right (Constrained (rs ++ ss)) +{-------------------------------------------------------------------------------+  Flagged dependencies+-------------------------------------------------------------------------------} -type FlaggedDeps qpn = [FlaggedDep qpn]+-- | 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 qpn =+data FlaggedDep comp qpn =     Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)   | Stanza  (SN qpn)       (TrueFlaggedDeps qpn)-  | Simple (Dep qpn)-  deriving (Eq, Show)+  | Simple (Dep qpn) comp+  deriving (Eq, Show, Functor) -instance Functor FlaggedDep where-  fmap f (Flagged x y tt ff) = Flagged (fmap f x) y-                                       (fmap (fmap f) tt) (fmap (fmap f) ff)-  fmap f (Stanza x tt)       = Stanza (fmap f x) (fmap (fmap f) tt)-  fmap f (Simple d)          = Simple (fmap f d)+-- | 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 qpn-type FalseFlaggedDeps qpn = FlaggedDeps qpn+type TrueFlaggedDeps  qpn = FlaggedDeps Component qpn+type FalseFlaggedDeps qpn = FlaggedDeps Component qpn  -- | A dependency (constraint) associates a package name with a -- constrained instance. data Dep qpn = Dep qpn (CI qpn)-  deriving (Eq, Show)+  deriving (Eq, Show, Functor)  showDep :: Dep QPN -> String showDep (Dep qpn (Fixed i (Goal v _))          ) =@@ -123,34 +213,150 @@ showDep (Dep qpn ci                            ) =   showQPN qpn ++ showCI ci -instance Functor Dep where-  fmap f (Dep x y) = Dep (f x) (fmap f y)+-- | 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 -instance ResetGoal Dep where-  resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci)+    -- 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' pn) = go+  where+    -- The Base qualifier does not get inherited+    pp :: PP+    pp = (if qoBaseShim then stripBase else id) pp'++    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++    goD :: Dep PN -> Component -> Dep QPN+    goD dep comp+      | qBase  dep  = fmap (Q (Base  pn pp)) dep+      | qSetup comp = fmap (Q (Setup pn pp)) dep+      | otherwise   = fmap (Q           pp ) dep++    -- Should we qualify this goal with the 'Base' package path?+    qBase :: Dep PN -> Bool+    qBase (Dep dep _ci) = qoBaseShim && unPackageName dep == "base"++    -- Should we qualify this goal with the 'Setup' packaeg 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)++{-------------------------------------------------------------------------------+  Selecting FlaggedDeps subsets++  (Correspond to the functions with the same names in ComponentDeps).+-------------------------------------------------------------------------------}++nonSetupDeps :: FlaggedDeps Component a -> FlaggedDeps Component a+nonSetupDeps = select (/= ComponentSetup)++setupDeps :: FlaggedDeps Component a -> FlaggedDeps Component a+setupDeps = select (== ComponentSetup)++-- | Select the dependencies of a given component+--+-- The modular solver kind of flattens the dependency trees from the .cabal+-- file, putting the component of each dependency at the leaves, rather than+-- indexing per component. For instance, package C might have flagged deps that+-- look something like+--+-- > Flagged <flagName> ..+-- >   [Simple <package A> ComponentLib]+-- >   [Simple <package B> ComponentLib]+--+-- indicating that the library component of C relies on either A or B, depending+-- on the flag. This makes it somewhat awkward however to extract certain kinds+-- of dependencies. In particular, extracting, say, the setup dependencies from+-- the above set of dependencies could either return the empty list, or else+--+-- > Flagged <flagName> ..+-- >   []+-- >   []+--+-- Both answers are reasonable; we opt to return the empty list in this+-- case, as it results in simpler search trees in the builder.+--+-- (Note that the builder already introduces separate goals for all flags of a+-- package, independently of whether or not they are used in any component, so+-- we don't have to worry about preserving flags here.)+select :: (Component -> Bool) -> FlaggedDeps Component a -> FlaggedDeps Component a+select p = mapMaybe go+  where+    go :: FlaggedDep Component a -> Maybe (FlaggedDep Component a)+    go (Flagged fn nfo  t f) = let t' = mapMaybe go t+                                   f' = mapMaybe go f+                               in if null t' && null f'+                                     then Nothing+                                     else Just $ Flagged fn nfo t' f'+    go (Stanza  sn      t  ) = let t' = mapMaybe go t+                               in if null t'+                                     then Nothing+                                     else Just $ Stanza  sn     t'+    go (Simple  pn comp    ) = if p comp then Just $ Simple pn comp+                                         else Nothing++{-------------------------------------------------------------------------------+  Reverse dependency map+-------------------------------------------------------------------------------}+ -- | A map containing reverse dependencies between qualified -- package names.-type RevDepMap = Map QPN [QPN]+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)--instance Functor Goal where-  fmap f (Goal v grs) = Goal (fmap f v) (fmap (fmap f) grs)--class ResetGoal f where-  resetGoal :: Goal qpn -> f qpn -> f qpn--instance ResetGoal Goal where-  resetGoal = const---- | For open goals as they occur during the build phase, we need to store--- additional information about flags.-data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasonChain-  deriving (Eq, Show)+  deriving (Eq, Show, Functor)  -- | Reasons why a goal can be added to a goal set. data GoalReason qpn =@@ -158,13 +364,7 @@   | PDependency (PI qpn)   | FDependency (FN qpn) Bool   | SDependency (SN qpn)-  deriving (Eq, Show)--instance Functor GoalReason where-  fmap _ UserGoal           = UserGoal-  fmap f (PDependency pi)   = PDependency (fmap f pi)-  fmap f (FDependency fn b) = FDependency (fmap f fn) b-  fmap f (SDependency sn)   = SDependency (fmap f sn)+  deriving (Eq, Show, Functor)  -- | The first element is the immediate reason. The rest are the reasons -- for the reasons ...@@ -172,10 +372,28 @@  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)++instance ResetGoal Goal where+  resetGoal = const++-- | Compute a conflic 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)+ goalReasonToVars :: GoalReason qpn -> ConflictSet qpn goalReasonToVars UserGoal                 = S.empty goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn)-goalReasonToVars (FDependency qfn _)      = S.singleton (F qfn)+goalReasonToVars (FDependency qfn _)      = S.singleton (simplifyVar (F qfn)) goalReasonToVars (SDependency qsn)        = S.singleton (S qsn)  goalReasonChainToVars :: Ord qpn => GoalReasonChain qpn -> ConflictSet qpn@@ -184,14 +402,29 @@ goalReasonChainsToVars :: Ord qpn => [GoalReasonChain qpn] -> ConflictSet qpn goalReasonChainsToVars = S.unions . L.map goalReasonChainToVars +{-------------------------------------------------------------------------------+  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 -> Goal QPN-close (OpenGoal (Simple (Dep qpn _)) gr) = Goal (P qpn) gr-close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr-close (OpenGoal (Stanza  qsn _)      gr) = Goal (S qsn) gr+close :: OpenGoal comp -> Goal QPN+close (OpenGoal (Simple (Dep qpn _) _) gr) = Goal (P qpn) gr+close (OpenGoal (Flagged qfn _ _ _ )   gr) = Goal (F qfn) gr+close (OpenGoal (Stanza  qsn _)        gr) = Goal (S qsn) gr --- | Compute a conflic 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 g (goalReasonChainToVars grs)+{-------------------------------------------------------------------------------+  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 (.&&.) anyVR . L.map fst

cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs view

@@ -66,9 +66,9 @@ combine _   []                      c = (Just c, []) combine var ((k, (     d, v)) : xs) c = (\ ~(e, ys) -> (e, (k, v) : ys)) $                                         case d of-                                          Just e | not (var `S.member` e) -> (Just e, [])-                                                 | otherwise              -> combine var xs (e `S.union` c)-                                          Nothing                         -> (Nothing, snd $ combine var xs S.empty)+                                          Just e | not (simplifyVar var `S.member` e) -> (Just e, [])+                                                 | otherwise                          -> combine var xs (e `S.union` c)+                                          Nothing                                     -> (Nothing, snd $ combine var xs S.empty)  -- | Naive backtracking exploration of the search tree. This will yield correct -- assignments only once the tree itself is validated.@@ -80,7 +80,7 @@     go (PChoiceF qpn _     ts) (A pa fa sa)   =       asum $                                      -- try children in order,       P.mapWithKey                                -- when descending ...-        (\ k r -> r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice+        (\ (POption k _) r -> r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice       ts     go (FChoiceF qfn _ _ _ ts) (A pa fa sa)   =       asum $                                      -- try children in order,@@ -107,7 +107,7 @@       backjumpInfo c $       asum $                                      -- try children in order,       P.mapWithKey                                -- when descending ...-        (\ k r -> tryWith (TryP (PI qpn k)) $     -- log and ...+        (\ 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 c _ _ ts) (A pa fa sa)   =

cabal/cabal-install/Distribution/Client/Dependency/Modular/Flag.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor #-} module Distribution.Client.Dependency.Modular.Flag where  import Data.Map as M@@ -10,24 +11,25 @@  -- | Flag name. Consists of a package instance and the flag identifier itself. data FN qpn = FN (PI qpn) Flag-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Functor)  -- | Extract the package name from a flag name. getPN :: FN qpn -> qpn getPN (FN (PI qpn _) _) = qpn -instance Functor FN where-  fmap f (FN x y) = FN (fmap f x) y- -- | Flag identifier. Just a string. type Flag = FlagName  unFlag :: Flag -> String unFlag (FlagName fn) = fn --- | Flag info. Default value, and whether the flag is manual.--- Manual flags can only be set explicitly.-data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool }+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.@@ -38,10 +40,7 @@  -- | Stanza name. Paired with a package name, much like a flag. data SN qpn = SN (PI qpn) OptionalStanza-  deriving (Eq, Ord, Show)--instance Functor SN where-  fmap f (SN x y) = SN (fmap f x) y+  deriving (Eq, Ord, Show, Functor)  -- | Qualified stanza name. type QSN = SN QPN

cabal/cabal-install/Distribution/Client/Dependency/Modular/Index.hs view

@@ -9,25 +9,39 @@ 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, encapsulations and failure reasons.+-- 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 PN) FlagInfo Encaps (Maybe FailReason)+data PInfo = PInfo (FlaggedDeps Component PN) FlagInfo (Maybe FailReason)   deriving (Show) --- | Encapsulations. A list of package names.-type Encaps = [PN]- 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 view

@@ -1,4 +1,10 @@-module Distribution.Client.Dependency.Modular.IndexConversion where+module Distribution.Client.Dependency.Modular.IndexConversion (+    convPIs+    -- * TODO: The following don't actually seem to be used anywhere?+  , convIPI+  , convSPI+  , convPI+  ) where  import Data.List as L import Data.Map as M@@ -7,6 +13,7 @@  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@@ -32,16 +39,16 @@ -- 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 -> CompilerId -> Bool ->-           SI.PackageIndex -> CI.PackageIndex SourcePackage -> Index-convPIs os arch cid sip iidx sidx =-  mkIndex (convIPI' sip iidx ++ convSPI' os arch cid sidx)+convPIs :: OS -> Arch -> CompilerInfo -> Bool -> Bool ->+           SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage -> 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.PackageIndex -> [(PN, I, PInfo)]+convIPI' :: Bool -> SI.InstalledPackageIndex -> [(PN, I, PInfo)] convIPI' sip idx =-    -- apply shadowing whenever there are multple installed packages with+    -- apply shadowing whenever there are multiple installed packages with     -- the same version     [ maybeShadow (convIP idx pkg)     | (_pkgid, pkgs) <- SI.allPackagesBySourcePackageId idx@@ -49,21 +56,24 @@   where      -- shadowing is recorded in the package info-    shadow (pn, i, PInfo fdeps fds encs _) | sip = (pn, i, PInfo fdeps fds encs (Just Shadowed))-    shadow x                                     = x+    shadow (pn, i, PInfo fdeps fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed))+    shadow x                                = x -convIPI :: Bool -> SI.PackageIndex -> Index+convIPI :: Bool -> SI.InstalledPackageIndex -> Index convIPI sip = mkIndex . convIPI' sip  -- | Convert a single installed package into the solver-specific format.-convIP :: SI.PackageIndex -> InstalledPackageInfo -> (PN, I, PInfo)+convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) convIP idx ipi =-  let ipid = installedPackageId ipi+  let ipid = IPI.installedPackageId ipi       i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)       pn = pkgName (sourcePackageId ipi)   in  case mapM (convIPId pn idx) (IPI.depends ipi) of-        Nothing  -> (pn, i, PInfo [] M.empty [] (Just Broken))-        Just fds -> (pn, i, PInfo fds M.empty [] Nothing)+        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+  setComp = setCompFlaggedDeps ComponentLib -- TODO: Installed packages should also store their encapsulations!  -- | Convert dependencies specified by an installed package id into@@ -72,71 +82,71 @@ -- 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.PackageIndex -> InstalledPackageId -> Maybe (FlaggedDep PN)+convIPId :: PN -> SI.InstalledPackageIndex -> InstalledPackageId -> Maybe (FlaggedDep () PN) convIPId pn' idx ipid =   case SI.lookupInstalledPackageId 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') []))))+                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 -> CompilerId ->+convSPI' :: OS -> Arch -> CompilerInfo -> Bool ->             CI.PackageIndex SourcePackage -> [(PN, I, PInfo)]-convSPI' os arch cid = L.map (convSP os arch cid) . CI.allPackages+convSPI' os arch cinfo strfl = L.map (convSP os arch cinfo strfl) . CI.allPackages -convSPI :: OS -> Arch -> CompilerId ->+convSPI :: OS -> Arch -> CompilerInfo -> Bool ->            CI.PackageIndex SourcePackage -> Index-convSPI os arch cid = mkIndex . convSPI' os arch cid+convSPI os arch cinfo strfl = mkIndex . convSPI' os arch cinfo strfl  -- | Convert a single source package into the solver-specific format.-convSP :: OS -> Arch -> CompilerId -> SourcePackage -> (PN, I, PInfo)-convSP os arch cid (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =+convSP :: OS -> Arch -> CompilerInfo -> Bool -> SourcePackage -> (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 cid (PI pn i) gpd)+  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'.------ TODO: We currently just take all dependencies from all specified library,--- executable and test components. This does not quite seem fair.-convGPD :: OS -> Arch -> CompilerId ->+convGPD :: OS -> Arch -> CompilerInfo -> Bool ->            PI PN -> GenericPackageDescription -> PInfo-convGPD os arch cid pi-        (GenericPackageDescription _ flags libs exes tests benchs) =+convGPD os arch comp strfl pi+        (GenericPackageDescription pkg flags libs exes tests benchs) =   let-    fds = flagInfo flags+    fds  = flagInfo strfl flags+    conv = convCondTree os arch comp pi fds (const True)   in     PInfo-      (maybe []    (convCondTree os arch cid pi fds (const True)          ) libs    ++-       concatMap   (convCondTree os arch cid pi fds (const True)     . snd) exes    +++      (maybe []    (conv ComponentLib                       ) libs    +++       maybe []    (convSetupBuildInfo pi)    (setupBuildInfo pkg)    +++       concatMap   (\(nm, ds) -> conv (ComponentExe nm)   ds) exes    ++       prefix (Stanza (SN pi TestStanzas))-        (L.map     (convCondTree os arch cid pi fds (const True)     . snd) tests)  +++        (L.map     (\(nm, ds) -> conv (ComponentTest nm)  ds) tests)  ++       prefix (Stanza (SN pi BenchStanzas))-        (L.map     (convCondTree os arch cid pi fds (const True)     . snd) benchs))+        (L.map     (\(nm, ds) -> conv (ComponentBench nm) ds) benchs))       fds-      [] -- TODO: add encaps       Nothing -prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> [FlaggedDeps qpn] -> FlaggedDeps qpn+prefix :: (FlaggedDeps comp qpn -> FlaggedDep comp' qpn) -> [FlaggedDeps comp qpn] -> FlaggedDeps comp' qpn prefix _ []  = [] prefix f fds = [f (concat fds)] --- | Convert flag information.-flagInfo :: [PD.Flag] -> FlagInfo-flagInfo = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m))+-- | 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))))  -- | Convert condition trees to flagged dependencies.-convCondTree :: OS -> Arch -> CompilerId -> PI PN -> FlagInfo ->+convCondTree :: OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo ->                 (a -> Bool) -> -- how to detect if a branch is active-                CondTree ConfVar [Dependency] a -> FlaggedDeps PN-convCondTree os arch cid pi@(PI pn _) fds p (CondNode info ds branches)-  | p info    = L.map (D.Simple . convDep pn) ds  -- unconditional dependencies-              ++ concatMap (convBranch os arch cid pi fds p) branches+                Component ->+                CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN+convCondTree os arch cinfo pi@(PI pn _) fds p comp (CondNode info ds branches)+  | p info    = L.map (\d -> D.Simple (convDep pn d) comp) ds  -- unconditional dependencies+              ++ concatMap (convBranch os arch cinfo pi fds p comp) branches   | otherwise = []  -- | Branch interpreter.@@ -147,34 +157,54 @@ -- 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.-convBranch :: OS -> Arch -> CompilerId ->+convBranch :: OS -> Arch -> CompilerInfo ->               PI PN -> FlagInfo ->               (a -> Bool) -> -- how to detect if a branch is active+              Component ->               (Condition ConfVar,                CondTree ConfVar [Dependency] a,-               Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps PN-convBranch os arch cid@(CompilerId cf cv) pi fds p (c', t', mf') =-  go c' (          convCondTree os arch cid pi fds p   t')-        (maybe [] (convCondTree os arch cid pi fds p) mf')+               Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps Component PN+convBranch os arch cinfo pi fds p comp (c', t', mf') =+  go c' (          convCondTree os arch cinfo pi fds p comp   t')+        (maybe [] (convCondTree os arch cinfo pi fds p comp) mf')   where     go :: Condition ConfVar ->-          FlaggedDeps PN -> FlaggedDeps PN -> FlaggedDeps PN+          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 = [Flagged (FN pi fn) (fds ! fn) 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-      | cf == cf' && checkVR cvr' cv = t+    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.+    extractCommon :: FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN+    extractCommon ps ps' = [ D.Simple (Dep pn (Constrained [])) comp+                           | D.Simple (Dep pn  _) _ <- ps+                           , D.Simple (Dep pn' _) _ <- ps'+                           , pn == pn'+                           ]+ -- | 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') [])])@@ -182,3 +212,8 @@ -- | Convert a Cabal package identifier to a solver-specific dependency. convPI :: PN -> PackageIdentifier -> Dep PN convPI pn' (PackageIdentifier pn v) = Dep pn (Constrained [(eqVR v, 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 view

@@ -0,0 +1,523 @@+{-# 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''+    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 view

@@ -85,7 +85,10 @@                                                      "Could not resolve dependencies:\n" ++                                                      unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms) ++                                                      (if exh then "Dependency tree exhaustively searched.\n"-                                                             else "Backjump limit reached (change with --max-backjumps).\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 _  _        []       _         (Just s) _   = Done s     go _  _        []       _         _        _   = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen

cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs view

@@ -1,4 +1,7 @@-module Distribution.Client.Dependency.Modular.Message where+module Distribution.Client.Dependency.Modular.Message (+    Message(..),+    showMessages+  ) where  import qualified Data.List as L import Prelude hiding (pi)@@ -9,11 +12,13 @@ import Distribution.Client.Dependency.Modular.Flag import Distribution.Client.Dependency.Modular.Package import Distribution.Client.Dependency.Modular.Tree+import Distribution.Client.Dependency.Types+         ( ConstraintSource(..), showConstraintSource )  data Message =     Enter           -- ^ increase indentation level   | Leave           -- ^ decrease indentation level-  | TryP (PI QPN)+  | TryP QPN POption   | TryF QFN Bool   | TryS QSN Bool   | Next (Goal QPN)@@ -38,26 +43,29 @@     go :: [Var QPN] -> Int -> [Message] -> [String]     go _ _ []                            = []     -- complex patterns-    go v l (TryP (PI qpn i) : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms-    go v l (TryF qfn b : Enter : Failure c fr : Leave : ms) = (atLevel (F qfn : v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)-    go v l (TryS qsn b : Enter : Failure c fr : Leave : ms) = (atLevel (S qsn : v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)-    go v l (Next (Goal (P qpn) gr) : TryP pi : ms@(Enter : Next _ : _)) = (atLevel (P qpn : v) l $ "trying: " ++ showPI pi ++ showGRs gr) (go (P qpn : v) l ms)+    go v l (TryP qpn i : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms+    go v l (TryF qfn b : Enter : Failure c fr : Leave : ms) = (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)+    go v l (TryS qsn b : Enter : Failure c fr : Leave : ms) = (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)+    go v l (Next (Goal (P qpn) gr) : TryP qpn' i : ms@(Enter : Next _ : _)) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGRs gr) (go (add (P qpn) v) l ms)     go v l (Failure c Backjump : ms@(Leave : Failure c' Backjump : _)) | c == c' = go v l ms     -- standard display     go v l (Enter                  : ms) = go v          (l+1) ms     go v l (Leave                  : ms) = go (drop 1 v) (l-1) ms-    go v l (TryP pi@(PI qpn _)     : ms) = (atLevel (P qpn : v) l $ "trying: " ++ showPI pi) (go (P qpn : v) l ms)-    go v l (TryF qfn b             : ms) = (atLevel (F qfn : v) l $ "trying: " ++ showQFNBool qfn b) (go (F qfn : v) l ms)-    go v l (TryS qsn b             : ms) = (atLevel (S qsn : v) l $ "trying: " ++ showQSNBool qsn b) (go (S qsn : v) l ms)-    go v l (Next (Goal (P qpn) gr) : ms) = (atLevel (P qpn : v) l $ "next goal: " ++ showQPN qpn ++ showGRs gr) (go v l ms)+    go v l (TryP qpn i             : ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms)+    go v l (TryF qfn b             : ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms)+    go v l (TryS qsn b             : ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms)+    go v l (Next (Goal (P qpn) gr) : ms) = (atLevel (add (P qpn) v) l $ "next goal: " ++ showQPN qpn ++ showGRs gr) (go v l ms)     go v l (Next _                 : ms) = go v l ms -- ignore flag goals in the log     go v l (Success                : ms) = (atLevel v l $ "done") (go v l ms)     go v l (Failure c fr           : ms) = (atLevel v l $ "fail" ++ showFR c fr) (go v l ms) +    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 -> [I] -> ConflictSet QPN -> FailReason -> [Message] -> [String]-    goPReject v l qpn is c fr (TryP (PI qpn' i) : Enter : Failure _ fr' : 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: " ++ showQPN qpn ++ "-" ++ L.intercalate ", " (map showI (reverse is)) ++ showFR c fr) (go v l ms)+    goPReject :: [Var QPN] -> Int -> QPN -> [POption] -> ConflictSet QPN -> FailReason -> [Message] -> [String]+    goPReject v l qpn is c fr (TryP qpn' i : Enter : Failure _ fr' : 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 v l x xs@@ -66,6 +74,12 @@       | p v       = 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 []       = ""@@ -77,22 +91,27 @@ 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)   = " (global constraint requires " ++ display vr ++ ")"-showFR _ GlobalConstraintInstalled      = " (global constraint requires installed instance)"-showFR _ GlobalConstraintSource         = " (global constraint requires source instance)"-showFR _ GlobalConstraintFlag           = " (global constraint 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 _ 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 ++ ")" -- 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)"+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 view

@@ -1,13 +1,13 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveFoldable, DeriveTraversable #-} module Distribution.Client.Dependency.Modular.PSQ where  -- Priority search queues. ----- I am not yet sure what exactly is needed. But we need a datastructure with+-- 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.Applicative import Data.Foldable import Data.Function import Data.List as S hiding (foldr)@@ -15,16 +15,7 @@ import Prelude hiding (foldr)  newtype PSQ k v = PSQ [(k, v)]-  deriving (Eq, Show)--instance Functor (PSQ k) where-  fmap f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs)--instance Foldable (PSQ k) where-  foldr op e (PSQ xs) = foldr op e (fmap snd xs)--instance Traversable (PSQ k) where-  traverse f (PSQ xs) = PSQ <$> traverse (\ (k, v) -> (\ x -> (k, x)) <$> f v) xs+  deriving (Eq, Show, Functor, Foldable, Traversable)  keys :: PSQ k v -> [k] keys (PSQ xs) = fmap fst xs@@ -66,7 +57,7 @@     (k, v) : ys -> c k v (PSQ ys)  splits :: PSQ k a -> PSQ k (a, PSQ k a)-splits = go id +splits = go id   where     go f xs = casePSQ xs         (PSQ [])@@ -101,3 +92,6 @@  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 view

@@ -1,9 +1,9 @@+{-# LANGUAGE DeriveFunctor #-} module Distribution.Client.Dependency.Modular.Package   (module Distribution.Client.Dependency.Modular.Package,    module Distribution.Package) where  import Data.List as L-import Data.Map as M  import Distribution.Package -- from Cabal import Distribution.Text    -- from Cabal@@ -51,7 +51,7 @@  -- | Package instance. A package name and an instance. data PI qpn = PI qpn I-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Functor)  -- | String representation of a package instance. showPI :: PI QPN -> String@@ -66,16 +66,37 @@ instI (I _ (Inst _)) = True instI _              = False -instance Functor PI where-  fmap f (PI x y) = PI (f x) y+-- | Package path.+--+-- Stored in reverse order+data PP =+    -- User-specified independent goal+    Independent Int PP+    -- Setup dependencies are always considered independent from their package+  | Setup PN PP+    -- Any dependency on base is considered independent (allows for base shims)+  | Base PN PP+    -- Unqualified+  | None+  deriving (Eq, Ord, Show) --- | Package path. (Stored in "reverse" order.)-type PP = [PN]+-- | Strip any 'Base' qualifiers from a PP+--+-- (the Base qualifier does not get inherited)+stripBase :: PP -> PP+stripBase (Independent i pp) = Independent i (stripBase pp)+stripBase (Setup pn      pp) = Setup pn      (stripBase pp)+stripBase (Base _pn      pp) =                stripBase pp+stripBase None               = None  -- | String representation of a package path.+--+-- NOTE: This always ends in a period showPP :: PP -> String-showPP = intercalate "." . L.map display . reverse-+showPP (Independent i pp) = show i                 ++ "." ++ showPP pp+showPP (Setup pn      pp) = display pn ++ "-setup" ++ "." ++ showPP pp+showPP (Base  pn      pp) = display pn             ++ "." ++ showPP pp+showPP None               = ""  -- | A qualified entity. Pairs a package path with the entity. data Q a = Q PP a@@ -83,8 +104,8 @@  -- | Standard string representation of a qualified entity. showQ :: (a -> String) -> (Q a -> String)-showQ showa (Q [] x) = showa x-showQ showa (Q pp x) = showPP pp ++ "." ++ showa x+showQ showa (Q None x) = showa x+showQ showa (Q pp   x) = showPP pp ++ showa x  -- | Qualified package name. type QPN = Q PN@@ -93,21 +114,12 @@ showQPN :: QPN -> String showQPN = showQ display --- | The scope associates every package with a path. The convention is that packages--- not in the data structure have an empty path associated with them.-type Scope = Map PN PP---- | An empty scope structure, for initialization.-emptyScope :: Scope-emptyScope = M.empty- -- | Create artificial parents for each of the package names, making -- them all independent.-makeIndependent :: [PN] -> Scope-makeIndependent ps = L.foldl (\ sc (n, p) -> M.insert p [PackageName (show n)] sc) emptyScope (zip ([0..] :: [Int]) ps)--qualify :: Scope -> PN -> QPN-qualify sc pn = Q (findWithDefault [] pn sc) pn+makeIndependent :: [PN] -> [QPN]+makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]+                               , let pp = Independent i None+                     ]  unQualify :: Q a -> a unQualify (Q _ x) = x

cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs view

@@ -1,14 +1,24 @@+{-# LANGUAGE CPP #-} module Distribution.Client.Dependency.Modular.Preference 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.Ord+import Data.Map (Map)+import Data.Traversable (sequence)  import Distribution.Client.Dependency.Types-  ( PackageConstraint(..), PackagePreferences(..), InstalledPreference(..) )+  ( PackageConstraint(..), LabeledPackageConstraint(..)+  , PackagePreferences(..), InstalledPreference(..) ) import Distribution.Client.Types   ( OptionalStanza(..) ) @@ -22,13 +32,31 @@ -- | 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+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 preferred versions as greater than non-preferred -- versions. preferredVersionsOrdering :: VR -> Ver -> Ver -> Ordering@@ -68,50 +96,72 @@ -- 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 :: ConflictSet QPN -> I -> PackageConstraint -> Tree a -> Tree a-processPackageConstraintP c (I v _) (PackageConstraintVersion _ vr) r-  | checkVR vr v  = r-  | otherwise     = Fail c (GlobalConstraintVersion vr)-processPackageConstraintP c i       (PackageConstraintInstalled _)  r-  | instI i       = r-  | otherwise     = Fail c GlobalConstraintInstalled-processPackageConstraintP c i       (PackageConstraintSource    _)  r-  | not (instI i) = r-  | otherwise     = Fail c GlobalConstraintSource-processPackageConstraintP _ _       _                               r = r+processPackageConstraintP :: ConflictSet QPN+                          -> I+                          -> LabeledPackageConstraint+                          -> Tree a+                          -> Tree a+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 -> PackageConstraint -> Tree a -> Tree a-processPackageConstraintF f c b' (PackageConstraintFlags _ fa) r =-  case L.lookup f fa of-    Nothing            -> r-    Just b | b == b'   -> r-           | otherwise -> Fail c GlobalConstraintFlag-processPackageConstraintF _ _ _  _                             r = r+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 -> PackageConstraint -> Tree a -> Tree a-processPackageConstraintS s c b' (PackageConstraintStanzas _ ss) r =-  if not b' && s `elem` ss then Fail c GlobalConstraintFlag-                           else r-processPackageConstraintS _ _ _  _                             r = r+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 [PackageConstraint] -> Tree QGoalReasonChain -> Tree QGoalReasonChain+enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]+                          -> Tree QGoalReasonChain+                          -> Tree QGoalReasonChain enforcePackageConstraints pcs = trav go   where     go (PChoiceF qpn@(Q _ pn)               gr      ts) =       let c = toConflictSet (Goal (P qpn) gr)           -- compose the transformation functions for each of the relevant constraint-          g = \ i -> foldl (\ h pc -> h . processPackageConstraintP   c i pc) id+          g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP   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) =@@ -131,18 +181,19 @@ -- | 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 disables all but the first non-disabled choice.+-- 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-            (_ , [])     -> P.fromList []-            (xs, y : ys) -> P.fromList (xs ++ y : L.map (\ (b, _) -> (b, Fail c ManualFlag)) ys)+            ([], 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 _ _) = True-        isDisabled _             = False+        isDisabled (_, Fail _ (GlobalConstraintFlag _)) = True+        isDisabled _                                    = False     go x                                                   = x  -- | Prefer installed packages over non-installed packages, generally.@@ -162,15 +213,15 @@ preferLatest = preferLatestFor (const True)  -- | Require installed packages.-requireInstalled :: (PN -> Bool) -> Tree (QGoalReasonChain, a) -> Tree (QGoalReasonChain, a)+requireInstalled :: (PN -> Bool) -> Tree QGoalReasonChain -> Tree QGoalReasonChain requireInstalled p = trav go   where-    go (PChoiceF v@(Q _ pn) i@(gr, _) cs)-      | p pn      = PChoiceF v i (P.mapWithKey installed cs)-      | otherwise = PChoiceF v i                         cs+    go (PChoiceF v@(Q _ pn) gr cs)+      | p pn      = PChoiceF v gr (P.mapWithKey installed cs)+      | otherwise = PChoiceF v gr                         cs       where-        installed (I _ (Inst _)) x = x-        installed _              _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall+        installed (POption (I _ (Inst _)) _) x = x+        installed _ _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall     go x          = x  -- | Avoid reinstalls.@@ -186,20 +237,21 @@ -- 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, a) -> Tree (QGoalReasonChain, a)+avoidReinstalls :: (PN -> Bool) -> Tree QGoalReasonChain -> Tree QGoalReasonChain avoidReinstalls p = trav go   where-    go (PChoiceF qpn@(Q _ pn) i@(gr, _) cs)-      | p pn      = PChoiceF qpn i disableReinstalls-      | otherwise = PChoiceF qpn i cs+    go (PChoiceF qpn@(Q _ pn) gr cs)+      | p pn      = PChoiceF qpn gr disableReinstalls+      | otherwise = PChoiceF qpn gr cs       where         disableReinstalls =-          let installed = [ v | (I v (Inst _), _) <- toList cs ]+          let installed = [ v | (POption (I v (Inst _)) _, _) <- toList cs ]           in  P.mapWithKey (notReinstall installed) cs -        notReinstall vs (I v InRepo) _-          | v `elem` vs                = Fail (toConflictSet (Goal (P qpn) gr)) CannotReinstall-        notReinstall _  _            x = x+        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@@ -225,11 +277,24 @@     go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys preferBase xs)     go x                = x -    preferBase :: OpenGoal -> OpenGoal -> Ordering-    preferBase (OpenGoal (Simple (Dep (Q [] pn) _)) _) _ | unPN pn == "base" = LT-    preferBase _ (OpenGoal (Simple (Dep (Q [] pn) _)) _) | unPN pn == "base" = GT-    preferBase _ _                                                           = EQ+    preferBase :: OpenGoal comp -> OpenGoal comp -> Ordering+    preferBase (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) _ | unPN pn == "base" = LT+    preferBase _ (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) | unPN pn == "base" = GT+    preferBase _ _                                                              = EQ +-- | 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.sortByKeys deferSetup xs)+    go x                = x++    deferSetup :: OpenGoal comp -> OpenGoal comp -> Ordering+    deferSetup (OpenGoal (Simple (Dep (Q (Setup _ _) _) _) _) _) _ = GT+    deferSetup _ (OpenGoal (Simple (Dep (Q (Setup _ _) _) _) _) _) = LT+    deferSetup _ _                                                 = EQ+ -- | Transformation that sorts choice nodes so that -- child nodes with a small branching degree are preferred. As a -- special case, choices with 0 branches will be preferred (as they@@ -241,10 +306,11 @@     go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing choices) xs)     go x                = x --- | Transformation that tries to avoid making inconsequential--- flag choices early.-deferDefaultFlagChoices :: Tree a -> Tree a-deferDefaultFlagChoices = trav go+-- | 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.sortBy defer xs)     go x                = x@@ -274,3 +340,38 @@     go (GoalChoiceF xs) = GoalChoiceF (P.map fst (P.sortBy (comparing (choices . snd)) xs))     go x                = fmap fst 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 view

@@ -14,6 +14,7 @@ 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 {@@ -21,14 +22,15 @@   independentGoals      :: Bool,   avoidReinstalls       :: Bool,   shadowPkgs            :: Bool,+  strongFlags           :: Bool,   maxBackjumps          :: Maybe Int } -solve :: SolverConfig ->   -- solver parameters-         Index ->          -- all available packages as an index-         (PN -> PackagePreferences) -> -- preferences-         Map PN [PackageConstraint] -> -- global constraints-         [PN] ->                       -- global goals+solve :: SolverConfig ->          -- solver parameters+         Index ->                 -- all available packages as an index+         (PN -> PackagePreferences) ->        -- preferences+         Map PN [LabeledPackageConstraint] -> -- global constraints+         [PN] ->                              -- global goals          Log Message (Assignment, RevDepMap) solve sc idx userPrefs userConstraints userGoals =   explorePhase     $@@ -40,15 +42,24 @@   where     explorePhase     = exploreTreeLog . backjump     heuristicsPhase  = P.firstGoal . -- after doing goal-choice heuristics, commit to the first choice (saves space)+                       P.deferSetupChoices .+                       P.deferWeakFlagChoices .+                       P.preferBaseGoalChoice .                        if preferEasyGoalChoices sc-                         then P.preferBaseGoalChoice . P.deferDefaultFlagChoices . P.lpreferEasyGoalChoices-                         else P.preferBaseGoalChoice+                         then P.lpreferEasyGoalChoices+                         else id .+                       P.preferLinked     preferencesPhase = P.preferPackagePreferences userPrefs     validationPhase  = P.enforceManualFlags . -- can only be done after user constraints                        P.enforcePackageConstraints userConstraints .+                       P.enforceSingleInstanceRestriction .+                       validateLinking idx .                        validateTree idx     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"])-    buildPhase       = buildTree idx (independentGoals sc) userGoals+                       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 view

@@ -1,37 +1,54 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module Distribution.Client.Dependency.Modular.Tree where -import Control.Applicative-import Control.Monad hiding (mapM)+import Control.Monad hiding (mapM, sequence) import Data.Foldable import Data.Traversable-import Prelude hiding (foldr, mapM)+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 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 I        (Tree a))-  | FChoice     QFN a Bool Bool (PSQ Bool     (Tree a)) -- Bool indicates whether it's 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+    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)+  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. -instance Functor Tree where-  fmap  f (PChoice qpn i     xs) = PChoice qpn (f i)     (fmap (fmap f) xs)-  fmap  f (FChoice qfn i b m xs) = FChoice qfn (f i) b m (fmap (fmap f) xs)-  fmap  f (SChoice qsn i b   xs) = SChoice qsn (f i) b   (fmap (fmap f) xs)-  fmap  f (GoalChoice        xs) = GoalChoice            (fmap (fmap f) xs)-  fmap _f (Done    rdm         ) = Done    rdm-  fmap _f (Fail    cs fr       ) = Fail    cs fr+-- | 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). Teans 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]@@ -39,26 +56,29 @@                 | CannotReinstall                 | Shadowed                 | Broken-                | GlobalConstraintVersion VR-                | GlobalConstraintInstalled-                | GlobalConstraintSource-                | GlobalConstraintFlag+                | GlobalConstraintVersion VR ConstraintSource+                | GlobalConstraintInstalled ConstraintSource+                | GlobalConstraintSource ConstraintSource+                | GlobalConstraintFlag ConstraintSource                 | ManualFlag                 | BuildFailureNotInIndex PN                 | MalformedFlagChoice QFN                 | MalformedStanzaChoice QSN                 | EmptyGoalChoice                 | Backjump+                | MultipleInstances+                | DependenciesNotLinked String   deriving (Eq, Show)  -- | Functor for the tree type. data TreeF a b =-    PChoiceF    QPN a           (PSQ I        b)-  | FChoiceF    QFN a Bool Bool (PSQ Bool     b)-  | SChoiceF    QSN a Bool      (PSQ Bool     b)-  | GoalChoiceF                 (PSQ OpenGoal 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@@ -76,29 +96,13 @@ inn (DoneF       x         ) = Done       x inn (FailF       c x       ) = Fail       c x -instance Functor (TreeF a) where-  fmap f (PChoiceF    p i     ts) = PChoiceF    p i     (fmap f ts)-  fmap f (FChoiceF    p i b m ts) = FChoiceF    p i b m (fmap f ts)-  fmap f (SChoiceF    p i b   ts) = SChoiceF    p i b   (fmap f ts)-  fmap f (GoalChoiceF         ts) = GoalChoiceF         (fmap f ts)-  fmap _ (DoneF       x         ) = DoneF       x-  fmap _ (FailF       c x       ) = FailF       c x--instance Foldable (TreeF a) where-  foldr op e (PChoiceF    _ _     ts) = foldr op e ts-  foldr op e (FChoiceF    _ _ _ _ ts) = foldr op e ts-  foldr op e (SChoiceF    _ _ _   ts) = foldr op e ts-  foldr op e (GoalChoiceF         ts) = foldr op e ts-  foldr _  e (DoneF       _         ) = e-  foldr _  e (FailF       _ _       ) = e--instance Traversable (TreeF a) where-  traverse f (PChoiceF    p i     ts) = PChoiceF    <$> pure p <*> pure i <*>                       traverse f ts-  traverse f (FChoiceF    p i b m ts) = FChoiceF    <$> pure p <*> pure i <*> pure b <*> pure m <*> traverse f ts-  traverse f (SChoiceF    p i b   ts) = SChoiceF    <$> pure p <*> pure i <*> pure b <*>            traverse f ts-  traverse f (GoalChoiceF         ts) = GoalChoiceF <$>                                             traverse f ts-  traverse _ (DoneF       x         ) = DoneF       <$> pure x-  traverse _ (FailF       c x       ) = FailF       <$> pure c <*> pure 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

cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs view

@@ -1,4 +1,4 @@-module Distribution.Client.Dependency.Modular.Validate where+module Distribution.Client.Dependency.Modular.Validate (validateTree) where  -- Validation of the tree. --@@ -21,9 +21,11 @@ import Distribution.Client.Dependency.Modular.PSQ as P import Distribution.Client.Dependency.Modular.Tree +import Distribution.Client.ComponentDeps (Component)+ -- 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 precondiditions are fulfilled ACTIVE. We maintain a set+-- 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.@@ -74,19 +76,20 @@ -- | The state needed during validation. data ValidateState = VS {   index :: Index,-  saved :: Map QPN (FlaggedDeps QPN), -- saved, scoped, dependencies-  pa    :: PreAssignment+  saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies+  pa    :: PreAssignment,+  qualifyOptions :: QualifyOptions }  type Validate = Reader ValidateState -validate :: Tree (QGoalReasonChain, Scope) -> Validate (Tree QGoalReasonChain)+validate :: Tree QGoalReasonChain -> Validate (Tree QGoalReasonChain) validate = cata go   where-    go :: TreeF (QGoalReasonChain, Scope) (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain)+    go :: TreeF QGoalReasonChain (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain) -    go (PChoiceF qpn (gr,  sc)     ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts)-    go (FChoiceF qfn (gr, _sc) b m ts) =+    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@@ -99,7 +102,7 @@                        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, _sc) b   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@@ -117,13 +120,16 @@     go (FailF    c fr              ) = pure (Fail c fr)      -- What to do for package nodes ...-    goP :: QPN -> QGoalReasonChain -> Scope -> I -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)-    goP qpn@(Q _pp pn) gr sc i r = do+    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       idx            <- asks index -- obtain the index       svd            <- asks saved -- obtain saved dependencies-      let (PInfo deps _ _ mfr) = idx ! pn ! i -- obtain dependencies and index-dictated exclusions introduced by the choice-      let qdeps = L.map (fmap (qualify sc)) deps -- qualify the deps in the current scope+      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@@ -188,11 +194,11 @@ -- | 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 QPN -> [Dep QPN]+extractDeps :: FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN] extractDeps fa sa deps = do   d <- deps   case d of-    Simple sd           -> return sd+    Simple sd _         -> return sd     Flagged qfn _ td fd -> case M.lookup qfn fa of                              Nothing    -> mzero                              Just True  -> extractDeps fa sa td@@ -205,13 +211,14 @@ -- | 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 QPN -> [Dep QPN]+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+        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@@ -228,5 +235,10 @@                                   Just False -> []  -- | Interface.-validateTree :: Index -> Tree (QGoalReasonChain, Scope) -> Tree QGoalReasonChain-validateTree idx t = runReader (validate t) (VS idx M.empty (PA M.empty M.empty M.empty))+validateTree :: Index -> Tree QGoalReasonChain -> Tree QGoalReasonChain+validateTree idx t = runReader (validate t) VS {+    index = idx+  , saved = M.empty+  , pa    = PA M.empty M.empty M.empty+  , qualifyOptions = defaultQualifyOptions idx+  }

cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Dependency.Types@@ -18,25 +19,29 @@ import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints import Distribution.Client.Dependency.TopDown.Constraints          ( Satisfiable(..) )-import Distribution.Client.IndexUtils-         ( convert )-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.InstallPlan-         ( PlanPackage(..) ) import Distribution.Client.Types-         ( SourcePackage(..), ConfiguredPackage(..), InstalledPackage(..)-         , enableStanzas )+         ( SourcePackage(..), ConfiguredPackage(..)+         , enableStanzas, ConfiguredId(..), fakeInstalledPackageId ) import Distribution.Client.Dependency.Types-         ( DependencyResolver, PackageConstraint(..)+         ( DependencyResolver, ResolverPackage(..)+         , PackageConstraint(..), unlabelPackageConstraint          , PackagePreferences(..), InstalledPreference(..)          , Progress(..), foldProgress )  import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (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, Package(..), packageVersion, packageName-         , Dependency(Dependency), thisPackageVersion-         , simplifyDependency, PackageFixedDeps(depends) )+         ( PackageName(..), PackageId, PackageIdentifier(..)+         , InstalledPackageId(..)+         , Package(..), packageVersion, packageName+         , Dependency(Dependency), thisPackageVersion, simplifyDependency ) import Distribution.PackageDescription          ( PackageDescription(buildDepends) ) import Distribution.Client.PackageUtils@@ -44,10 +49,10 @@ import Distribution.PackageDescription.Configuration          ( finalizePackageDescription, flattenPackageDescription ) import Distribution.Version-         ( VersionRange, withinRange, simplifyVersionRange+         ( Version(..), VersionRange, withinRange, simplifyVersionRange          , UpperBound(..), asVersionIntervals ) import Distribution.Compiler-         ( CompilerId )+         ( CompilerInfo ) import Distribution.System          ( Platform ) import Distribution.Simple.Utils@@ -59,8 +64,10 @@          ( 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@@ -242,34 +249,38 @@ -- the standard 'DependencyResolver' interface. -- topDownResolver :: DependencyResolver-topDownResolver platform comp installedPkgIndex sourcePkgIndex+topDownResolver platform cinfo installedPkgIndex sourcePkgIndex                 preferences constraints targets =-    mapMessages (topDownResolver' platform comp-                                  (convert installedPkgIndex) sourcePkgIndex-                                  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 -> CompilerId+topDownResolver' :: Platform -> CompilerInfo                  -> PackageIndex InstalledPackage                  -> PackageIndex SourcePackage                  -> (PackageName -> PackagePreferences)                  -> [PackageConstraint]                  -> [PackageName]-                 -> Progress Log Failure [PlanPackage]-topDownResolver' platform comp installedPkgIndex sourcePkgIndex+                 -> Progress Log Failure [ResolverPackage]+topDownResolver' platform cinfo installedPkgIndex sourcePkgIndex                  preferences constraints targets =       fmap (uncurry finalise)     . (\cs -> search configure preferences cs initialPkgNames)-  =<< pruneBottomUp platform comp+  =<< pruneBottomUp platform cinfo   =<< addTopLevelConstraints constraints   =<< addTopLevelTargets targets emptyConstraintSet    where-    configure   = configurePackage platform comp+    configure   = configurePackage platform cinfo     emptyConstraintSet :: Constraints     emptyConstraintSet = Constraints.empty       (annotateInstalledPackages          topSortNumber installedPkgIndex')@@ -281,11 +292,16 @@     initialPkgNames = Set.fromList targets      finalise selected' constraints' =-        PackageIndex.allPackages+        map toResolverPackage+      . PackageIndex.allPackages       . fst . improvePlan installedPkgIndex' constraints'       . PackageIndex.fromList       $ finaliseSelectedPackages preferences selected' constraints' +    toResolverPackage :: FinalSelectedPackage -> ResolverPackage+    toResolverPackage (SelectedInstalled (InstalledPackage pkg _))+                                              = PreExisting pkg+    toResolverPackage (SelectedSource    pkg) = Configured  pkg  addTopLevelTargets :: [PackageName]                    -> Constraints@@ -345,7 +361,7 @@  -- | Add exclusion on available packages that cannot be configured. ---pruneBottomUp :: Platform -> CompilerId+pruneBottomUp :: Platform -> CompilerInfo               -> Constraints -> Progress Log Failure Constraints pruneBottomUp platform comp constraints =     foldr prune Done (initialPackages constraints) constraints@@ -390,8 +406,8 @@     getSourcePkg (InstalledAndSource _ spkg) = Just spkg  -configurePackage :: Platform -> CompilerId -> ConfigurePackage-configurePackage platform comp available spkg = case spkg of+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)@@ -399,7 +415,8 @@   where   configure (UnconfiguredPackage apkg@(SourcePackage _ p _ _) _ flags stanzas) =     case finalizePackageDescription flags dependencySatisfiable-                                    platform comp [] (enableStanzas stanzas p) of+                                    platform cinfo []+                                    (enableStanzas stanzas p) of       Left missing        -> Left missing       Right (pkg, flags') -> Right $         SemiConfiguredPackage apkg flags' stanzas (externalBuildDepends pkg)@@ -419,7 +436,7 @@     transitiveDepends :: InstalledPackage -> [PackageId]     transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph                       . fromJust . toVertex . packageId-    (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed+    (graph, toPkg, toVertex) = dependencyGraph installed   -- | Annotate each available packages with its topological sort number and any@@ -477,7 +494,7 @@          | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installedPkgIndex          , let deps = [ packageName dep                       | pkg' <- pkgs-                      , dep  <- depends pkg' ] ]+                      , dep  <- sourceDeps pkg' ] ]       ++ [ ((), packageName pkg, nub deps)          | pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex          , let deps = [ depName@@ -515,7 +532,7 @@                         filter notAlreadyIncluded                       $ [ packageName dep                         | pkg <- moreInstalled-                        , dep <- depends pkg ]+                        , dep <- sourceDeps pkg ]                      ++ [ name                         | SourcePackage _ pkg _ _ <- moreSource                         , Dependency name _ <-@@ -530,6 +547,43 @@             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+    -- InstalledPackageId, which means we do not directly know the corresponding+    -- source dependency. The only way to find out is to lookup the+    -- InstalledPackageId 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.lookupInstalledPackageId index+      , (depid, mdep) <- zip depids (map getpkg depids) ]++    brokenPackageId (InstalledPackageId str) =+      PackageIdentifier (PackageName (str ++ "-broken")) (Version [] [])+ -- ------------------------------------------------------------ -- * Post processing the solution -- ------------------------------------------------------------@@ -537,7 +591,7 @@ finaliseSelectedPackages :: (PackageName -> PackagePreferences)                          -> SelectedPackages                          -> Constraints-                         -> [PlanPackage]+                         -> [FinalSelectedPackage] finaliseSelectedPackages pref selected constraints =   map finaliseSelected (PackageIndex.allPackages selected)   where@@ -553,12 +607,46 @@         Just (InstalledOnly _)        -> finaliseInstalled ipkg         Just (InstalledAndSource _ _) -> finaliseSource (Just ipkg) apkg -    finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg+    finaliseInstalled (InstalledPackageEx pkg _ _) = SelectedInstalled pkg     finaliseSource mipkg (SemiConfiguredPackage pkg flags stanzas deps) =-      InstallPlan.Configured (ConfiguredPackage pkg flags stanzas deps')+        SelectedSource (ConfiguredPackage pkg flags stanzas deps')       where-        deps' = map (packageId . pickRemaining mipkg) deps+        -- We cheat in the cabal solver, and classify all dependencies as+        -- library dependencies.+        deps' :: ComponentDeps [ConfiguredId]+        deps' = CD.fromLibraryDeps $ 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 = fakeInstalledPackageId (packageId pkg)+      }+     pickRemaining mipkg dep@(Dependency _name versionRange) =           case PackageIndex.lookupDependency remainingChoices dep of             []        -> impossible "pickRemaining no pkg"@@ -575,7 +663,7 @@         -- silly things like deciding to rebuild haskell98 against base 3.         isCurrent = case mipkg :: Maybe InstalledPackageEx of           Nothing   -> \_ -> False-          Just ipkg -> \p -> packageId p `elem` depends ipkg+          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@@ -607,8 +695,8 @@ -- improvePlan :: PackageIndex InstalledPackage             -> Constraints-            -> PackageIndex PlanPackage-            -> (PackageIndex PlanPackage, Constraints)+            -> PackageIndex FinalSelectedPackage+            -> (PackageIndex FinalSelectedPackage, Constraints) improvePlan installed constraints0 selected0 =   foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0)   where@@ -621,27 +709,27 @@     -- 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-      Configured pkg  <- PackageIndex.lookupPackageId selected  pkgid-      ipkg            <- PackageIndex.lookupPackageId installed pkgid-      guard $ all (isInstalled selected) (depends pkg)+      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 (PreExisting _) -> True-        _                    -> False+        Just (SelectedInstalled _) -> True+        _                          -> False -    tryInstalled :: PackageIndex PlanPackage -> Constraints+    tryInstalled :: PackageIndex FinalSelectedPackage -> Constraints                  -> [InstalledPackage]-                 -> Maybe (PackageIndex PlanPackage, Constraints)+                 -> Maybe (PackageIndex FinalSelectedPackage, Constraints)     tryInstalled selected constraints [] = Just (selected, constraints)     tryInstalled selected constraints (pkg:pkgs) =-      case constraintsOk (packageId pkg) (depends pkg) constraints of+      case constraintsOk (packageId pkg) (sourceDeps pkg) constraints of         Nothing           -> Nothing         Just constraints' -> tryInstalled selected' constraints' pkgs'           where-            selected' = PackageIndex.insert (PreExisting pkg) selected-            pkgs'      = catMaybes (map notSelected (depends pkg)) ++ pkgs+            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@@ -656,13 +744,12 @@       where         dep = thisPackageVersion pkgid' -    reverseTopologicalOrder :: PackageFixedDeps pkg-                            => PackageIndex pkg -> [PackageId]+    reverseTopologicalOrder :: PackageIndex FinalSelectedPackage -> [PackageId]     reverseTopologicalOrder index = map (packageId . toPkg)                                   . Graph.topSort                                   . Graph.transposeG                                   $ graph-      where (graph, toPkg, _) = PackageIndex.dependencyGraph index+      where (graph, toPkg, _) = dependencyGraph index  -- ------------------------------------------------------------ -- * Adding and recording constraints@@ -846,7 +933,7 @@      "applying constraint " ++ display (Dependency pkgname ver)   ++ if null pkgids        then ""-       else "which excludes " ++ listOf display pkgids+       else " which excludes " ++ listOf display pkgids showLog (AppliedInstalledConstraint pkgname inst pkgids) =      "applying constraint " ++ display pkgname ++ " '"   ++ (case inst of InstalledConstraint -> "installed"; _ -> "source") ++ "' "@@ -940,3 +1027,49 @@ 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 view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Dependency.TopDown.Constraints@@ -25,18 +26,21 @@  import Distribution.Client.Dependency.TopDown.Types import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)+import Distribution.Client.PackageIndex+        ( PackageIndex ) import Distribution.Package          ( PackageName, PackageId, PackageIdentifier(..)          , Package(packageId), packageName, packageVersion-         , Dependency, PackageFixedDeps(depends) )+         , 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@@ -221,14 +225,12 @@       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 :: (PackageFixedDeps installed, Package source)-      => PackageIndex installed-      -> PackageIndex source-      -> Constraints installed source reason+empty :: PackageIndex InstalledPackageEx+      -> PackageIndex UnconfiguredPackage+      -> Constraints InstalledPackageEx UnconfiguredPackage reason empty installed source =     Constraints targets pkgs excluded pairs pkgs   where@@ -250,27 +252,24 @@       , let name   = packageName pkg1             pkgid1 = packageId pkg1             pkgid2 = packageId pkg2-      ,    any ((pkgid1==) . packageId) (depends pkg2)-        || any ((pkgid2==) . packageId) (depends pkg1) ]+      ,    any ((pkgid1==) . packageId) (sourceDeps pkg2)+        || any ((pkgid2==) . packageId) (sourceDeps pkg1) ]   -- | The package targets. ---packages :: (Package installed, Package source)-         => Constraints installed source reason+packages :: Constraints installed source reason          -> Set PackageName packages (Constraints ts _ _ _ _) = ts   -- | The package choices that are still available. ---choices :: (Package installed, Package source)-        => Constraints installed source reason+choices :: Constraints installed source reason         -> PackageIndex (InstalledOrSource installed source) choices (Constraints _ available _ _ _) = available -isPaired :: (Package installed, Package source)-         => Constraints installed source reason+isPaired :: Constraints installed source reason          -> PackageId -> Maybe PackageId isPaired (Constraints _ _ _ pairs _) (PackageIdentifier name version) =   case Map.lookup name pairs of

cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs view

@@ -10,14 +10,19 @@ -- -- Types for the top-down dependency resolver. -----------------------------------------------------------------------------+{-# LANGUAGE CPP #-} module Distribution.Client.Dependency.TopDown.Types where  import Distribution.Client.Types-         ( SourcePackage(..), InstalledPackage, OptionalStanza )+         ( SourcePackage(..), ConfiguredPackage(..)+         , OptionalStanza, ConfiguredId(..) )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import qualified Distribution.Client.ComponentDeps as CD  import Distribution.Package-         ( PackageIdentifier, Dependency-         , Package(packageId), PackageFixedDeps(depends) )+         ( PackageId, PackageIdentifier, Dependency+         , Package(packageId) ) import Distribution.PackageDescription          ( FlagAssignment ) @@ -37,8 +42,18 @@    | InstalledAndSource installed source   deriving Eq +data FinalSelectedPackage+   = SelectedInstalled InstalledPackage+   | SelectedSource    ConfiguredPackage+ type TopologicalSortNumber = Int +-- | InstalledPackage caches its dependencies as source package IDs.+data InstalledPackage+   = InstalledPackage+       InstalledPackageInfo+       [PackageId]+ data InstalledPackageEx    = InstalledPackageEx        InstalledPackage@@ -60,12 +75,12 @@        [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 PackageFixedDeps InstalledPackageEx where-  depends (InstalledPackageEx _ _ deps) = deps- instance Package UnconfiguredPackage where   packageId (UnconfiguredPackage p _ _ _) = packageId p @@ -78,7 +93,11 @@   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. --@@ -89,3 +108,36 @@ 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+-- InstalledPackageIds (so it cannot use PackageFixedDeps).+--+-- Ideally we would switch the top-down solver over to use InstalledPackageIds+-- 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 where+  sourceDeps (ConfiguredPackage _ _ _ deps) = map confSrcId $ CD.nonSetupDeps deps++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,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Dependency.Types@@ -11,72 +13,70 @@ -- Common types for dependency resolution. ----------------------------------------------------------------------------- module Distribution.Client.Dependency.Types (-    ExtDependency(..),-     PreSolver(..),     Solver(..),     DependencyResolver,+    ResolverPackage(..),      AllowNewer(..), isAllowNewer,     PackageConstraint(..),+    showPackageConstraint,     PackagePreferences(..),     InstalledPreference(..),     PackagesPreferenceDefault(..),      Progress(..),     foldProgress,++    LabeledPackageConstraint(..),+    ConstraintSource(..),+    unlabelPackageConstraint,+    showConstraintSource   ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative-         ( Applicative(..), Alternative(..) )+         ( 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.Types-         ( OptionalStanza, SourcePackage(..) )-import qualified Distribution.Client.InstallPlan as InstallPlan--import Distribution.Compat.ReadP-         ( (<++) )+         ( OptionalStanza(..), SourcePackage(..), ConfiguredPackage )  import qualified Distribution.Compat.ReadP as Parse          ( pfail, munch1 ) import Distribution.PackageDescription-         ( FlagAssignment )+         ( FlagAssignment, FlagName(..) )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo ) import qualified Distribution.Client.PackageIndex as PackageIndex          ( PackageIndex )-import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex-         ( PackageIndex )+import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) import Distribution.Package-         ( Dependency, PackageName, InstalledPackageId )+         ( PackageName ) import Distribution.Version-         ( VersionRange )+         ( VersionRange, simplifyVersionRange ) import Distribution.Compiler-         ( CompilerId )+         ( CompilerInfo ) import Distribution.System          ( Platform ) import Distribution.Text-         ( Text(..) )+         ( Text(..), display )  import Text.PrettyPrint          ( text )  import Prelude hiding (fail) --- | Covers source dependencies and installed dependencies in--- one type.-data ExtDependency = SourceDependency Dependency-                   | InstalledDependency InstalledPackageId -instance Text ExtDependency where-  disp (SourceDependency    dep) = disp dep-  disp (InstalledDependency dep) = disp dep--  parse = (SourceDependency `fmap` parse) <++ (InstalledDependency `fmap` parse)- -- | All the solvers that can be selected. data PreSolver = AlwaysTopDown | AlwaysModular | Choose   deriving (Eq, Ord, Show, Bounded, Enum)@@ -106,14 +106,22 @@ -- in alternatives. -- type DependencyResolver = Platform-                       -> CompilerId-                       -> InstalledPackageIndex.PackageIndex+                       -> CompilerInfo+                       -> InstalledPackageIndex                        ->          PackageIndex.PackageIndex SourcePackage                        -> (PackageName -> PackagePreferences)-                       -> [PackageConstraint]+                       -> [LabeledPackageConstraint]                        -> [PackageName]-                       -> Progress String String [InstallPlan.PlanPackage]+                       -> Progress String String [ResolverPackage] +-- | 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 = PreExisting InstalledPackageInfo+                     | Configured  ConfiguredPackage+ -- | 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@@ -127,10 +135,31 @@    | PackageConstraintStanzas   PackageName [OptionalStanza]   deriving (Show,Eq) +-- | 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"+ -- | A per-package preference on the version. It is a soft constraint that the -- 'DependencyResolver' should try to respect where possible. It consists of -- a 'InstalledPreference' which says if we prefer versions of packages--- that are already installed. It also hase a 'PackageVersionPreference' which+-- that are already installed. It also has a 'PackageVersionPreference' which -- is a suggested constraint on the version number. The resolver should try to -- use package versions that satisfy the suggested version constraint. --@@ -143,6 +172,7 @@ -- 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.@@ -167,6 +197,7 @@      -- * This is the standard policy for install.      --    | PreferLatestForSelected+  deriving Show  -- | Policy for relaxing upper bounds in dependencies. For example, given -- 'build-depends: array >= 0.3 && < 0.5', are we allowed to relax the upper@@ -192,11 +223,12 @@  -- | A type to represent the unfolding of an expensive long running -- calculation that may fail. We may get intermediate steps before the final--- retult which may be used to indicate progress and\/or logging messages.+-- 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.@@ -212,9 +244,6 @@         fold (Fail f)   = fail f         fold (Done r)   = done r -instance Functor (Progress step fail) where-  fmap f = foldProgress Step Fail (Done . f)- instance Monad (Progress step fail) where   return a = Done a   p >>= f  = foldProgress Step Fail f p@@ -226,3 +255,65 @@ 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++  -- | Sandbox config file, which is ./cabal.sandbox.config by default.+  | ConstraintSourceSandboxConfig FilePath++  -- | ./cabal.config.+  | ConstraintSourceUserConfig++  -- | 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)++-- | Description of a 'ConstraintSource'.+showConstraintSource :: ConstraintSource -> String+showConstraintSource (ConstraintSourceMainConfig path) =+    "main config " ++ path+showConstraintSource (ConstraintSourceSandboxConfig path) =+    "sandbox config " ++ path+showConstraintSource ConstraintSourceUserConfig = "cabal.config"+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/Exec.hs view

@@ -0,0 +1,133 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Exec+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Implementation of the 'exec' command. Runs an arbitrary executable in an+-- environment suitable for making use of the sandbox.+-----------------------------------------------------------------------------++module Distribution.Client.Exec ( exec+                                ) where++import Control.Monad (unless)++import Data.Foldable (forM_)++import qualified Distribution.Simple.GHC   as GHC+import qualified Distribution.Simple.GHCJS as GHCJS++import Distribution.Client.Sandbox (getSandboxConfigFilePath)+import Distribution.Client.Sandbox.PackageEnvironment (sandboxPackageDBPath)+import Distribution.Client.Sandbox.Types              (UseSandbox (..))++import Distribution.Simple.Compiler    (Compiler, CompilerFlavor(..), compilerFlavor)+import Distribution.Simple.Program     (ghcProgram, ghcjsProgram, lookupProgram)+import Distribution.Simple.Program.Db  (ProgramDb, requireProgram, modifyProgramSearchPath)+import Distribution.Simple.Program.Find (ProgramSearchPathEntry(..))+import Distribution.Simple.Program.Run (programInvocation, runProgramInvocation)+import Distribution.Simple.Program.Types ( simpleProgram, ConfiguredProgram(..) )+import Distribution.Simple.Utils       (die, warn)++import Distribution.System    (Platform)+import Distribution.Verbosity (Verbosity)++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.+--+-- The given command is executed with GHC configured to use the correct+-- package database and with the sandbox bin directory added to the PATH.+exec :: Verbosity+     -> UseSandbox+     -> Compiler+     -> Platform+     -> ProgramDb+     -> [String]+     -> IO ()+exec verbosity useSandbox comp platform programDb extraArgs =+    case extraArgs of+        (exe:args) -> do+            program <- requireProgram' verbosity useSandbox programDb exe+            env <- ((++) (programOverrideEnv program)) <$> environmentOverrides+            let invocation = programInvocation+                                 program { programOverrideEnv = env }+                                 args+            runProgramInvocation verbosity invocation++        [] -> die "Please specify an executable to run"+  where+    environmentOverrides = +        case useSandbox of+            NoSandbox -> return []+            (UseSandbox sandboxDir) ->+                sandboxEnvironment verbosity sandboxDir comp platform programDb+++-- | Return the package's sandbox environment.+--+-- The environment sets GHC_PACKAGE_PATH so that GHC will use the sandbox.+sandboxEnvironment :: Verbosity+                   -> FilePath+                   -> Compiler+                   -> Platform+                   -> ProgramDb+                   -> IO [(String, Maybe String)]+sandboxEnvironment verbosity sandboxDir comp platform programDb =+    case compilerFlavor comp of+      GHC   -> env GHC.getGlobalPackageDB   ghcProgram   "GHC_PACKAGE_PATH"+      GHCJS -> env GHCJS.getGlobalPackageDB ghcjsProgram "GHCJS_PACKAGE_PATH"+      _     -> die "exec only works with GHC and GHCJS"+  where+    env getGlobalPackageDB hcProgram packagePathEnvVar = do+        let Just program = lookupProgram hcProgram programDb+        gDb <- getGlobalPackageDB verbosity program+        sandboxConfigFilePath <- getSandboxConfigFilePath mempty+        let compilerPackagePath = hcPackagePath gDb+        -- Packages database must exist, otherwise things will start+        -- failing in mysterious ways.+        forM_ compilerPackagePath $ \fp -> do+          exists <- doesDirectoryExist fp+          unless exists $ warn verbosity $ "Package database is not a directory: " ++ fp+        -- Build the environment+        return [ (packagePathEnvVar, compilerPackagePath)+               , ("CABAL_SANDBOX_PACKAGE_PATH", compilerPackagePath)+               , ("CABAL_SANDBOX_CONFIG", Just sandboxConfigFilePath)+               ]++    hcPackagePath gDb =+        let s = sandboxPackageDBPath sandboxDir comp platform+            in Just $ prependToSearchPath gDb s++    prependToSearchPath path newValue =+        newValue ++ [searchPathSeparator] ++ path+++-- | Check that a program is configured and available to be run. If+-- a sandbox is available check in the sandbox's directory.+requireProgram' :: Verbosity+                -> UseSandbox+                -> ProgramDb+                -> String+                -> IO ConfiguredProgram+requireProgram' verbosity useSandbox programDb exe = do+    (program, _) <- requireProgram+                        verbosity+                        (simpleProgram exe)+                        updateSearchPath+    return program+  where+    updateSearchPath =+        flip modifyProgramSearchPath programDb $ \searchPath ->+            case useSandbox of+                NoSandbox -> searchPath+                UseSandbox sandboxDir ->+                    ProgramSearchPathDir (sandboxDir </> "bin") : searchPath

cabal/cabal-install/Distribution/Client/Fetch.hs view

@@ -21,6 +21,8 @@ import Distribution.Client.Dependency import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages )+import Distribution.Client.HttpUtils+         ( configureTransport, HttpTransport(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.Setup          ( GlobalFlags(..), FetchFlags(..) )@@ -28,12 +30,12 @@ import Distribution.Package          ( packageId ) import Distribution.Simple.Compiler-         ( Compiler(compilerId), PackageDBStack )-import Distribution.Simple.PackageIndex (PackageIndex)+         ( Compiler, compilerInfo, PackageDBStack )+import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Program          ( ProgramConfiguration ) import Distribution.Simple.Setup-         ( fromFlag )+         ( fromFlag, flagToMaybe ) import Distribution.Simple.Utils          ( die, notice, debug ) import Distribution.System@@ -83,7 +85,9 @@     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf     sourcePkgDb       <- getSourcePackages    verbosity repos -    pkgSpecifiers <- resolveUserTargets verbosity+    transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))++    pkgSpecifiers <- resolveUserTargets verbosity transport                        (fromFlag $ globalWorldFile globalFlags)                        (packageIndex sourcePkgDb)                        userTargets@@ -105,7 +109,7 @@                      "The following packages would be fetched:"                    : map (display . packageId) pkgs' -             else mapM_ (fetchPackage verbosity . packageSource) pkgs'+             else mapM_ (fetchPackage transport verbosity . packageSource) pkgs'    where     dryRun = fromFlag (fetchDryRun fetchFlags)@@ -114,7 +118,7 @@              -> Compiler              -> Platform              -> FetchFlags-             -> PackageIndex+             -> InstalledPackageIndex              -> SourcePackageDb              -> [PackageSpecifier SourcePackage]              -> IO [SourcePackage]@@ -123,11 +127,11 @@    | includeDependencies = do       solver <- chooseSolver verbosity-                (fromFlag (fetchSolver fetchFlags)) (compilerId comp)+                (fromFlag (fetchSolver fetchFlags)) (compilerInfo comp)       notice verbosity "Resolving dependencies..."       installPlan <- foldProgress logMsg die return $                        resolveDependencies-                         platform (compilerId comp)+                         platform (compilerInfo comp)                          solver                          resolverParams @@ -135,7 +139,7 @@       -- that are in the 'InstallPlan.Configured' state.       return         [ pkg-        | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _ _))+        | (InstallPlan.Configured (ConfiguredPackage pkg _ _ _))             <- InstallPlan.toList installPlan ]    | otherwise =@@ -154,6 +158,8 @@        . setShadowPkgs shadowPkgs +      . setStrongFlags strongFlags+         -- Reinstall the targets given on the command line so that the dep         -- resolver will decide that they need fetching, even if they're         -- already installed. Since we want to get the source packages of@@ -168,6 +174,7 @@     reorderGoals     = fromFlag (fetchReorderGoals     fetchFlags)     independentGoals = fromFlag (fetchIndependentGoals fetchFlags)     shadowPkgs       = fromFlag (fetchShadowPkgs       fetchFlags)+    strongFlags      = fromFlag (fetchStrongFlags      fetchFlags)     maxBackjumps     = fromFlag (fetchMaxBackjumps     fetchFlags)  @@ -178,8 +185,8 @@             ++ "In the meantime you can use the 'unpack' commands."     _ -> return () -fetchPackage :: Verbosity -> PackageLocation a -> IO ()-fetchPackage verbosity pkgsrc = case pkgsrc of+fetchPackage :: HttpTransport -> Verbosity -> PackageLocation a -> IO ()+fetchPackage transport verbosity pkgsrc = case pkgsrc of     LocalUnpackedPackage _dir  -> return ()     LocalTarballPackage  _file -> return () @@ -188,5 +195,5 @@          ++ "In the meantime you can use the 'unpack' commands."      RepoTarballPackage repo pkgid _ -> do-      _ <- fetchRepoTarball verbosity repo pkgid+      _ <- fetchRepoTarball transport verbosity repo pkgid       return ()

cabal/cabal-install/Distribution/Client/FetchUtils.hs view

@@ -27,7 +27,8 @@  import Distribution.Client.Types import Distribution.Client.HttpUtils-         ( downloadURI, isOldHackageURI, DownloadResult(..) )+         ( downloadURI, isOldHackageURI, DownloadResult(..)+         , HttpTransport(..), transportCheckHttps, remoteRepoCheckHttps )  import Distribution.Package          ( PackageId, packageName, packageVersion )@@ -88,10 +89,11 @@  -- | Fetch a package if we don't have it already. ---fetchPackage :: Verbosity+fetchPackage :: HttpTransport+             -> Verbosity              -> PackageLocation (Maybe FilePath)              -> IO (PackageLocation FilePath)-fetchPackage verbosity loc = case loc of+fetchPackage transport verbosity loc = case loc of     LocalUnpackedPackage dir  ->       return (LocalUnpackedPackage dir)     LocalTarballPackage  file ->@@ -105,22 +107,23 @@       path <- downloadTarballPackage uri       return (RemoteTarballPackage uri path)     RepoTarballPackage repo pkgid Nothing -> do-      local <- fetchRepoTarball verbosity repo pkgid+      local <- fetchRepoTarball transport verbosity repo pkgid       return (RepoTarballPackage repo pkgid local)   where     downloadTarballPackage uri = do+      transportCheckHttps transport uri       notice verbosity ("Downloading " ++ show uri)       tmpdir <- getTemporaryDirectory       (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz"       hClose hnd-      _ <- downloadURI verbosity uri path+      _ <- downloadURI transport verbosity uri path       return path   -- | Fetch a repo package if we don't have it already. ---fetchRepoTarball :: Verbosity -> Repo -> PackageId -> IO FilePath-fetchRepoTarball verbosity repo pkgid = do+fetchRepoTarball :: HttpTransport -> Verbosity -> Repo -> PackageId -> IO FilePath+fetchRepoTarball transport verbosity repo pkgid = do   fetched <- doesFileExist (packageFile repo pkgid)   if fetched     then do info verbosity $ display pkgid ++ " has already been downloaded."@@ -132,24 +135,26 @@       Right LocalRepo -> return (packageFile repo pkgid)        Left remoteRepo -> do+        remoteRepoCheckHttps transport remoteRepo         let uri  = packageURI remoteRepo pkgid             dir  = packageDir       repo pkgid             path = packageFile      repo pkgid         createDirectoryIfMissing True dir-        _ <- downloadURI verbosity uri path+        _ <- downloadURI transport verbosity uri path         return path  -- | Downloads an index file to [config-dir/packages/serv-id]. ---downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult-downloadIndex verbosity repo cacheDir = do-  let uri = (remoteRepoURI repo) {-              uriPath = uriPath (remoteRepoURI repo)+downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult+downloadIndex transport verbosity remoteRepo cacheDir = do+  remoteRepoCheckHttps transport remoteRepo+  let uri = (remoteRepoURI remoteRepo) {+              uriPath = uriPath (remoteRepoURI remoteRepo)                           `FilePath.Posix.combine` "00-index.tar.gz"             }       path = cacheDir </> "00-index" <.> "tar.gz"   createDirectoryIfMissing True cacheDir-  downloadURI verbosity uri path+  downloadURI transport verbosity uri path   -- ------------------------------------------------------------

cabal/cabal-install/Distribution/Client/Freeze.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Freeze@@ -15,32 +16,39 @@     freeze,   ) where +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-         ( PlanPackage )+         ( InstallPlan, PlanPackage ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.Setup-         ( GlobalFlags(..), FreezeFlags(..) )+         ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) )+import Distribution.Client.HttpUtils+         ( configureTransport ) import Distribution.Client.Sandbox.PackageEnvironment-         ( userPackageEnvironmentFile )+         ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment,+           userPackageEnvironmentFile ) import Distribution.Client.Sandbox.Types          ( SandboxPackageInfo(..) )  import Distribution.Package-         ( packageId, packageName, packageVersion )+         ( Package, packageId, packageName, packageVersion ) import Distribution.Simple.Compiler-         ( Compiler(compilerId), PackageDBStack )-import Distribution.Simple.PackageIndex (PackageIndex)+         ( Compiler, compilerInfo, PackageDBStack )+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.Program          ( ProgramConfiguration ) import Distribution.Simple.Setup-         ( fromFlag )+         ( fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils-         ( die, notice, debug, intercalate, writeFileAtomic )+         ( die, notice, debug, writeFileAtomic ) import Distribution.System          ( Platform ) import Distribution.Text@@ -48,20 +56,22 @@ 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 )  -- ------------------------------------------------------------ -- * The freeze command -- ------------------------------------------------------------ ---TODO:--- * Don't overwrite all of `cabal.config`, just the constaints section.--- * Should the package represented by `UserTargetLocalDir "."` be---   constrained too? What about `base`?-- -- | Freeze all of the dependencies by writing a constraints section -- constraining each dependency to an exact version. --@@ -81,11 +91,15 @@     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf     sourcePkgDb       <- getSourcePackages    verbosity repos -    pkgSpecifiers <- resolveUserTargets verbosity+    transport <- configureTransport verbosity+                 (flagToMaybe (globalHttpTransport globalFlags))++    pkgSpecifiers <- resolveUserTargets verbosity transport                        (fromFlag $ globalWorldFile globalFlags)                        (packageIndex sourcePkgDb)                        [UserTargetLocalDir "."] +    sanityCheck pkgSpecifiers     pkgs  <- planPackages                verbosity comp platform mSandboxPkgInfo freezeFlags                installedPkgIndex sourcePkgDb pkgSpecifiers@@ -98,18 +112,25 @@                      "The following packages would be frozen:"                    : formatPkgs pkgs -             else freezePackages pkgs+             else freezePackages verbosity pkgs    where     dryRun = fromFlag (freezeDryRun freezeFlags) +    sanityCheck pkgSpecifiers = do+      when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $+        die $ "internal error: 'resolveUserTargets' returned "+           ++ "unexpected named package specifiers!"+      when (length pkgSpecifiers /= 1) $+        die $ "internal error: 'resolveUserTargets' returned "+           ++ "unexpected source package specifiers!"  planPackages :: Verbosity              -> Compiler              -> Platform              -> Maybe SandboxPackageInfo              -> FreezeFlags-             -> PackageIndex+             -> InstalledPackageIndex              -> SourcePackageDb              -> [PackageSpecifier SourcePackage]              -> IO [PlanPackage]@@ -117,16 +138,16 @@              installedPkgIndex sourcePkgDb pkgSpecifiers = do    solver <- chooseSolver verbosity-            (fromFlag (freezeSolver freezeFlags)) (compilerId comp)+            (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp)   notice verbosity "Resolving dependencies..."    installPlan <- foldProgress logMsg die return $                    resolveDependencies-                     platform (compilerId comp)+                     platform (compilerInfo comp)                      solver                      resolverParams -  return $ InstallPlan.toList installPlan+  return $ pruneInstallPlan installPlan pkgSpecifiers    where     resolverParams =@@ -140,31 +161,81 @@        . setShadowPkgs shadowPkgs +      . setStrongFlags strongFlags++      . addConstraints+          [ let pkg = pkgSpecifierTarget pkgSpecifier+                pc = PackageConstraintStanzas pkg stanzas+            in LabeledPackageConstraint pc ConstraintSourceFreeze+          | pkgSpecifier <- pkgSpecifiers ]+       . maybe id applySandboxInstallPolicy mSandboxPkgInfo        $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers      logMsg message rest = debug verbosity message >> rest +    stanzas = concat+        [ if testsEnabled      then [TestStanzas]  else []+        , if benchmarksEnabled then [BenchStanzas] else []+        ]+    testsEnabled      = fromFlagOrDefault False $ freezeTests freezeFlags+    benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags+     reorderGoals     = fromFlag (freezeReorderGoals     freezeFlags)     independentGoals = fromFlag (freezeIndependentGoals freezeFlags)     shadowPkgs       = fromFlag (freezeShadowPkgs       freezeFlags)+    strongFlags      = fromFlag (freezeStrongFlags      freezeFlags)     maxBackjumps     = fromFlag (freezeMaxBackjumps     freezeFlags) -freezePackages :: [PlanPackage] -> IO ()-freezePackages pkgs =-    writeFileAtomic userPackageEnvironmentFile $ constraints pkgs++-- | Remove all unneeded packages from an install plan.+--+-- A package is unneeded if it is either+--+-- 1) the package that we are freezing, or+--+-- 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+                 -> [PackageSpecifier SourcePackage]+                 -> [PlanPackage]+pruneInstallPlan installPlan pkgSpecifiers =+    either (const brokenPkgsErr)+           (removeSelf pkgIds . PackageIndex.allPackages) $+    InstallPlan.dependencyClosure installPlan pkgIds   where-    constraints = BS.Char8.pack-                . (++ "\n")-                . (prefix' ++)-                . intercalate separator-                . formatPkgs-    prefix' = "constraints: "-    separator = "\n" ++ (replicate (length prefix' - 2) ' ') ++ ", "+    pkgIds = [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]+    removeSelf [thisPkg] = filter (\pp -> packageId pp /= thisPkg)+    removeSelf _  = error $ "internal error: 'pruneInstallPlan' given "+                         ++ "unexpected package specifiers!"+    brokenPkgsErr = error "planPackages: installPlan contains broken packages"  -formatPkgs :: [PlanPackage] -> [String]+freezePackages :: Package pkg => Verbosity -> [pkg] -> IO ()+freezePackages verbosity pkgs = do+    pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $+                   loadUserConfig verbosity ""+    writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv+  where+    addFrozenConstraints config =+        config {+            savedConfigureExFlags = (savedConfigureExFlags config) {+                configExConstraints = map constraint pkgs+            }+        }+    constraint pkg =+        (pkgIdToConstraint $ packageId pkg, ConstraintSourceUserConfig)+      where+        pkgIdToConstraint pkgId =+            UserConstraintVersion (packageName pkgId)+                                  (thisVersion $ packageVersion pkgId)+    createPkgEnv config = mempty { pkgEnvSavedConfig = config }+    showPkgEnv = BS.Char8.pack . showPackageEnvironment+++formatPkgs :: Package pkg => [pkg] -> [String] formatPkgs = map $ showPkg . packageId   where     showPkg pid = name pid ++ " == " ++ version pid

cabal/cabal-install/Distribution/Client/GZipUtils.hs view

@@ -1,3 +1,6 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.GZipUtils@@ -15,11 +18,16 @@     maybeDecompress,   ) where -import qualified Data.ByteString.Lazy.Internal as BS (ByteString(..))-import Data.ByteString.Lazy (ByteString)-import Codec.Compression.GZip import Codec.Compression.Zlib.Internal+import Data.ByteString.Lazy.Internal as BS (ByteString(Empty, Chunk)) +#if MIN_VERSION_zlib(0,6,0)+import Control.Exception (throw)+import Control.Monad (liftM)+import Control.Monad.ST.Lazy (ST, runST)+import qualified Data.ByteString as Strict+#endif+ -- | Attempts to decompress the `bytes' under the assumption that -- "data format" error at the very beginning of the stream means -- that it is already decompressed. Caller should make sanity checks@@ -30,15 +38,49 @@ -- <https://github.com/haskell/cabal/issues/678> -- maybeDecompress :: ByteString -> ByteString+#if MIN_VERSION_zlib(0,6,0)+maybeDecompress bytes = runST (go bytes decompressor)+  where+    decompressor :: DecompressStream (ST s)+    decompressor = decompressST gzipOrZlibFormat defaultDecompressParams++    -- DataError at the beginning of the stream probably means that stream is+    -- not compressed, so we return it as-is.+    -- TODO: alternatively, we might consider looking for the two magic bytes+    -- at the beginning of the gzip header.  (not an option for zlib, though.)+    go :: Monad m => ByteString -> DecompressStream m -> m ByteString+    go cs (DecompressOutputAvailable bs k) = liftM (Chunk bs) $ go' cs =<< k+    go _  (DecompressStreamEnd       _bs ) = return Empty+    go _  (DecompressStreamError _err    ) = return bytes+    go cs (DecompressInputRequired      k) = go cs' =<< k c+      where+        (c, cs') = uncons cs++    -- Once we have received any output though we regard errors as actual errors+    -- and we throw them (as pure exceptions).+    -- TODO: We could (and should) avoid these pure exceptions.+    go' :: Monad m => ByteString -> DecompressStream m -> m ByteString+    go' cs (DecompressOutputAvailable bs k) = liftM (Chunk bs) $ go' cs =<< k+    go' _  (DecompressStreamEnd       _bs ) = return Empty+    go' _  (DecompressStreamError err     ) = throw err+    go' cs (DecompressInputRequired      k) = go' cs' =<< k c+      where+        (c, cs') = uncons cs++    uncons :: ByteString -> (Strict.ByteString, ByteString)+    uncons Empty        = (Strict.empty, Empty)+    uncons (Chunk c cs) = (c, cs)+#else maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes   where     -- DataError at the beginning of the stream probably means that stream is not compressed.     -- Returning it as-is.     -- TODO: alternatively, we might consider looking for the two magic bytes     -- at the beginning of the gzip header.-    foldStream (StreamError DataError _) = bytes+    foldStream (StreamError _ _) = bytes     foldStream somethingElse = doFold somethingElse      doFold StreamEnd               = BS.Empty     doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream)     doFold (StreamError _ msg)  = error $ "Codec.Compression.Zlib: " ++ msg+#endif

cabal/cabal-install/Distribution/Client/Get.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Get@@ -20,7 +21,7 @@ import Distribution.Package          ( PackageId, packageId, packageName ) import Distribution.Simple.Setup-         ( Flag(..), fromFlag, fromFlagOrDefault )+         ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils          ( notice, die, info, writeFileAtomic ) import Distribution.Verbosity@@ -34,6 +35,8 @@ import Distribution.Client.Targets import Distribution.Client.Dependency import Distribution.Client.FetchUtils+import Distribution.Client.HttpUtils+        ( configureTransport, HttpTransport(..) ) import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils as IndexUtils         ( getSourcePackages )@@ -51,8 +54,10 @@ 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@@ -87,7 +92,9 @@    sourcePkgDb <- getSourcePackages verbosity repos -  pkgSpecifiers <- resolveUserTargets verbosity+  transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))++  pkgSpecifiers <- resolveUserTargets verbosity transport                    (fromFlag $ globalWorldFile globalFlags)                    (packageIndex sourcePkgDb)                    userTargets@@ -101,11 +108,11 @@    if useFork     then fork pkgs-    else unpack pkgs+    else unpack transport pkgs    where     resolverParams sourcePkgDb pkgSpecifiers =-        --TODO: add commandline constraint and preference args for unpack+        --TODO: add command-line constraint and preference args for unpack         standardInstallPolicy mempty sourcePkgDb pkgSpecifiers      prefix = fromFlagOrDefault "" (getDestDir getFlags)@@ -116,10 +123,10 @@       branchers <- findUsableBranchers       mapM_ (forkPackage verbosity branchers prefix kind) pkgs -    unpack :: [SourcePackage] -> IO ()-    unpack pkgs = do+    unpack :: HttpTransport -> [SourcePackage] -> IO ()+    unpack transport pkgs = do       forM_ pkgs $ \pkg -> do-        location <- fetchPackage verbosity (packageSource pkg)+        location <- fetchPackage transport verbosity (packageSource pkg)         let pkgid = packageId pkg             descOverride | usePristine = Nothing                          | otherwise   = packageDescrOverride pkg@@ -214,7 +221,7 @@     return (Data.Map.fromList pairs)  -- | Fork a single package from a remote source repository to the local--- filesystem.+-- file system. forkPackage :: Verbosity             -> Data.Map.Map PD.RepoType Brancher                -- ^ Branchers supported by the local machine.

cabal/cabal-install/Distribution/Client/Haddock.hs view

@@ -16,31 +16,30 @@     )     where -import Data.Maybe (listToMaybe) import Data.List (maximumBy)-import Control.Monad (guard)-import System.Directory (createDirectoryIfMissing, doesFileExist,-                         renameFile)-import System.FilePath ((</>), splitFileName, isAbsolute)+import System.Directory (createDirectoryIfMissing, renameFile)+import System.FilePath ((</>), splitFileName) import Distribution.Package-         ( Package(..), packageVersion )+         ( packageVersion )+import Distribution.Simple.Haddock (haddockPackagePaths) import Distribution.Simple.Program (haddockProgram, ProgramConfiguration                                    , rawSystemProgram, requireProgramVersion) import Distribution.Version (Version(Version), orLaterVersion) import Distribution.Verbosity (Verbosity)-import Distribution.Text (display) import Distribution.Simple.PackageIndex-         ( PackageIndex, allPackagesByName )+         ( InstalledPackageIndex, allPackagesByName ) import Distribution.Simple.Utils-         ( comparing, intercalate, debug-         , installDirectoryContents, withTempDirectory )+         ( comparing, debug, installDirectoryContents, withTempDirectory ) import Distribution.InstalledPackageInfo as InstalledPackageInfo-         ( InstalledPackageInfo-         , InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) )+         ( InstalledPackageInfo(exposed) ) -regenerateHaddockIndex :: Verbosity -> PackageIndex -> ProgramConfiguration -> FilePath -> IO ()+regenerateHaddockIndex :: Verbosity+                       -> InstalledPackageIndex -> ProgramConfiguration+                       -> FilePath+                       -> IO () regenerateHaddockIndex verbosity pkgs conf index = do-      (paths,warns) <- haddockPackagePaths pkgs'+      (paths, warns) <- haddockPackagePaths pkgs' Nothing+      let paths' = [ (interface, html) | (interface, Just html) <- paths]       case warns of         Nothing -> return ()         Just m  -> debug verbosity m@@ -58,7 +57,7 @@                     , "--odir=" ++ tempDir                     , "--title=Haskell modules on this system" ]                  ++ [ "--read-interface=" ++ html ++ "," ++ interface-                    | (interface, html) <- paths ]+                    | (interface, html) <- paths' ]         rawSystemProgram verbosity confHaddock flags         renameFile (tempDir </> "index.html") (tempDir </> destFile)         installDirectoryContents verbosity tempDir destDir@@ -69,41 +68,3 @@             | (_pname, pkgvers) <- allPackagesByName pkgs             , let pkgvers' = filter exposed pkgvers             , not (null pkgvers') ]--haddockPackagePaths :: [InstalledPackageInfo]-                       -> IO ([(FilePath, FilePath)], Maybe String)-haddockPackagePaths pkgs = do-  interfaces <- sequence-    [ case interfaceAndHtmlPath pkg of-        Just (interface, html) -> do-          exists <- doesFileExist interface-          if exists-            then return (pkgid, Just (interface, html))-            else return (pkgid, Nothing)-        Nothing -> return (pkgid, Nothing)-    | pkg <- pkgs, let pkgid = packageId pkg ]--  let missing = [ pkgid | (pkgid, Nothing) <- interfaces ]--      warning = "The documentation for the following packages are not "-             ++ "installed. No links will be generated to these packages: "-             ++ intercalate ", " (map display missing)--      flags = [ x | (_, Just x) <- interfaces ]--  return (flags, if null missing then Nothing else Just warning)--  where-    interfaceAndHtmlPath pkg = do-      interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)-      html <- fmap fixFileUrl-                   (listToMaybe (InstalledPackageInfo.haddockHTMLs pkg))-      guard (not . null $ html)-      return (interface, html)-    -    -- the 'haddock-html' field in the hc-pkg output is often set as a-    -- native path, but we need it as a URL.-    -- See https://github.com/haskell/cabal/issues/1064-    fixFileUrl f | isAbsolute f = "file://" ++ f-                 | otherwise    = f-

cabal/cabal-install/Distribution/Client/HttpUtils.hs view

@@ -1,12 +1,15 @@+{-# LANGUAGE CPP, BangPatterns #-} ----------------------------------------------------------------------------- -- | Separate module for HTTP actions, using a proxy server if one exists ----------------------------------------------------------------------------- module Distribution.Client.HttpUtils (     DownloadResult(..),+    configureTransport,+    HttpTransport(..),     downloadURI,-    getHTTP,-    cabalBrowse,-    proxy,+    transportCheckHttps,+    remoteRepoCheckHttps,+    remoteRepoTryUpgradeToHttps,     isOldHackageURI   ) where @@ -17,139 +20,665 @@ import Network.URI          ( URI (..), URIAuth (..) ) import Network.Browser-         ( BrowserAction, browse-         , setOutHandler, setErrHandler, setProxy, setAuthorityGen, request)-import Network.Stream-         ( Result, ConnError(..) )+         ( 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.Monad-         ( liftM )-import qualified Data.ByteString.Lazy.Char8 as ByteString-import Data.ByteString.Lazy (ByteString)-+         ( when, guard )+import qualified Data.ByteString.Lazy.Char8 as BS+import Data.List+         ( isPrefixOf, find, intercalate )+import Data.Maybe+         ( listToMaybe, maybeToList ) import qualified Paths_cabal_install (version) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils-         ( die, info, warn, debug, notice-         , copyFileVerbose, writeFileAtomic )+         ( die, info, warn, debug, notice, writeFileAtomic+         , copyFileVerbose,  withTempFile+         , rawSystemStdInOut, toUTF8, fromUTF8, normaliseLineEndings )+import Distribution.Client.Utils+         ( readMaybe, withTempFileName )+import Distribution.Client.Types+         ( RemoteRepo(..) )+import Distribution.System+         ( buildOS, buildArch ) import Distribution.Text          ( display )-import Data.Char ( isSpace )+import Data.Char+         ( isSpace ) import qualified System.FilePath.Posix as FilePath.Posix          ( splitDirectories ) import System.FilePath          ( (<.>) ) import System.Directory-         ( doesFileExist )+         ( doesFileExist, renameFile )+import System.IO.Error+         ( isDoesNotExistError )+import Distribution.Simple.Program+         ( Program, simpleProgram, ConfiguredProgram, programPath+         , ProgramInvocation(..), programInvocation+         , getProgramInvocationOutput )+import Distribution.Simple.Program.Db+         ( ProgramDb, emptyProgramDb, addKnownPrograms+         , configureAllKnownPrograms+         , requireProgram, lookupProgram )+import Distribution.Simple.Program.Run+        ( IOEncoding(..), getEffectiveEnvironment )+import Numeric (showHex)+import System.Directory (canonicalizePath)+import System.IO (hClose, hPutStr)+import System.FilePath (takeFileName, takeDirectory)+import System.Random (randomRIO)+import System.Exit (ExitCode(..)) -data DownloadResult = FileAlreadyInCache | FileDownloaded FilePath deriving (Eq) --- Trime-trim :: String -> String-trim = f . f-      where f = reverse . dropWhile isSpace---- |Get the local proxy settings---TODO: print info message when we're using a proxy based on verbosity-proxy :: Verbosity -> IO Proxy-proxy _verbosity = do-  p <- fetchProxy True-  -- Handle empty proxy strings-  return $ case p of-    Proxy uri auth ->-      let uri' = trim uri in-      if uri' == "" then NoProxy else Proxy uri' auth-    _ -> p--mkRequest :: URI-          -> Maybe String -- ^ Optional etag to be set in the If-None-Match HTTP header.-          -> Request ByteString-mkRequest uri etag = Request{ rqURI     = uri-                            , rqMethod  = GET-                            , rqHeaders = Header HdrUserAgent userAgent : ifNoneMatchHdr-                            , rqBody    = ByteString.empty }-  where userAgent = "cabal-install/" ++ display Paths_cabal_install.version-        ifNoneMatchHdr = maybe [] (\t -> [Header HdrIfNoneMatch t]) etag---- |Carry out a GET request, using the local proxy settings-getHTTP :: Verbosity-        -> URI-        -> Maybe String -- ^ Optional etag to check if we already have the latest file.-        -> IO (Result (Response ByteString))-getHTTP verbosity uri etag = liftM (\(_, resp) -> Right resp) $-                                   cabalBrowse verbosity (return ()) (request (mkRequest uri etag))+------------------------------------------------------------------------------+-- Downloading a URI, given an HttpTransport+-- -cabalBrowse :: Verbosity-            -> BrowserAction s ()-            -> BrowserAction s a-            -> IO a-cabalBrowse verbosity auth act = do-    p   <- proxy verbosity-    browse $ do-        setProxy p-        setErrHandler (warn verbosity . ("http error: "++))-        setOutHandler (debug verbosity)-        auth-        setAuthorityGen (\_ _ -> return Nothing)-        act+data DownloadResult = FileAlreadyInCache+                    | FileDownloaded FilePath+  deriving (Eq) -downloadURI :: Verbosity+downloadURI :: HttpTransport+            -> Verbosity             -> URI      -- ^ What to download             -> FilePath -- ^ Where to put it             -> IO DownloadResult-downloadURI verbosity uri path | uriScheme uri == "file:" = do+downloadURI _transport verbosity uri path | uriScheme uri == "file:" = do   copyFileVerbose verbosity (uriPath uri) path   return (FileDownloaded path)   -- Can we store the hash of the file so we can safely return path when the   -- hash matches to avoid unnecessary computation?-downloadURI verbosity uri path = do-  let etagPath = path <.> "etag"-  targetExists   <- doesFileExist path-  etagPathExists <- doesFileExist etagPath-  -- In rare cases the target file doesn't exist, but the etag does.-  etag <- if targetExists && etagPathExists-            then liftM Just $ readFile etagPath-            else return Nothing -  result <- getHTTP verbosity uri etag-  let result' = case result of-        Left  err -> Left err-        Right rsp -> case rspCode rsp of-          (2,0,0) -> Right rsp-          (3,0,4) -> Right rsp-          (a,b,c) -> Left err-            where-              err = ErrorMisc $ "Error HTTP code: "-                                ++ concatMap show [a,b,c]+downloadURI transport verbosity uri path = do -  -- Only write the etag if we get a 200 response code.-  -- A 304 still sends us an etag header.-  case result' of-    Left _ -> return ()-    Right rsp -> case rspCode rsp of-      (2,0,0) -> case lookupHeader HdrETag (rspHeaders rsp) of-        Nothing -> return ()-        Just newEtag -> writeFile etagPath newEtag-      (_,_,_) -> return ()+    let etagPath = path <.> "etag"+    targetExists   <- doesFileExist path+    etagPathExists <- doesFileExist etagPath+    -- In rare cases the target file doesn't exist, but the etag does.+    etag <- if targetExists && etagPathExists+              then Just <$> readFile etagPath+              else return Nothing -  case result' of-    Left err   -> die $ "Failed to download " ++ show uri ++ " : " ++ show err-    Right rsp -> case rspCode rsp of-      (2,0,0) -> do-        info verbosity ("Downloaded to " ++ path)-        writeFileAtomic path $ rspBody rsp-        return (FileDownloaded path)-      (3,0,4) -> do-        notice verbosity "Skipping download: Local and remote files match."-        return FileAlreadyInCache-      (_,_,_) -> return (FileDownloaded path)-      --FIXME: check the content-length header matches the body length.-      --TODO: stream the download into the file rather than buffering the whole-      --      thing in memory.+    -- Only use the external http transports if we actually have to+    -- (or have been told to do so)+    let transport'+          | uriScheme uri == "http:"+          , not (transportManuallySelected transport)+          = plainHttpTransport --- Utility function for legacy support.+          | otherwise+          = transport++    withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do+      result <- getHttp transport' verbosity uri etag tmpFile++      -- Only write the etag if we get a 200 response code.+      -- A 304 still sends us an etag header.+      case result of+        (200, Just newEtag) -> writeFile etagPath newEtag+        _ -> return ()++      case fst result of+        200 -> do+            info verbosity ("Downloaded to " ++ path)+            renameFile tmpFile path+            return (FileDownloaded path)+        304 -> do+            notice verbosity "Skipping download: local and remote files match."+            return FileAlreadyInCache+        errCode ->  die $ "Failed to download " ++ show uri+                       ++ " : HTTP code " ++ show errCode++------------------------------------------------------------------------------+-- Utilities for repo url management+--++remoteRepoCheckHttps :: HttpTransport -> RemoteRepo -> IO ()+remoteRepoCheckHttps transport repo+  | uriScheme (remoteRepoURI repo) == "https:"+  , not (transportSupportsHttps transport)+              = die $ "The remote repository '" ++ remoteRepoName repo+                   ++ "' specifies a URL that " ++ requiresHttpsErrorMessage+  | otherwise = return ()++transportCheckHttps :: HttpTransport -> URI -> IO ()+transportCheckHttps transport uri+  | uriScheme uri == "https:"+  , not (transportSupportsHttps transport)+              = die $ "The URL " ++ show uri+                   ++ " " ++ requiresHttpsErrorMessage+  | otherwise = return ()++requiresHttpsErrorMessage :: String+requiresHttpsErrorMessage =+      "requires HTTPS however the built-in HTTP implementation "+   ++ "does not support HTTPS. The transport implementations with HTTPS "+   ++ "support are " ++ intercalate ", "+      [ name | (name, _, True, _ ) <- supportedTransports ]+   ++ ". One of these will be selected automatically if the corresponding "+   ++ "external program is available, or one can be selected specifically "+   ++ "with the global flag --http-transport="++remoteRepoTryUpgradeToHttps :: HttpTransport -> RemoteRepo -> IO RemoteRepo+remoteRepoTryUpgradeToHttps transport repo+  | remoteRepoShouldTryHttps repo+  , uriScheme (remoteRepoURI repo) == "http:"+  , not (transportSupportsHttps transport)+  , not (transportManuallySelected transport)+  = die $ "The builtin HTTP implementation does not support HTTPS, but using "+       ++ "HTTPS for authenticated uploads is recommended. "+       ++ "The transport implementations with HTTPS support are "+       ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ]+       ++ "but they require the corresponding external program to be "+       ++ "available. You can either make one available or use plain HTTP by "+       ++ "using the global flag --http-transport=plain-http (or putting the "+       ++ "equivalent in the config file). With plain HTTP, your password "+       ++ "is sent using HTTP digest authentication so it cannot be easily "+       ++ "intercepted, but it is not as secure as using HTTPS."++  | remoteRepoShouldTryHttps repo+  , uriScheme (remoteRepoURI repo) == "http:"+  , transportSupportsHttps transport+  = return repo {+      remoteRepoURI = (remoteRepoURI repo) { uriScheme = "https:" }+    }++  | otherwise+  = return repo++-- | Utility function for legacy support. isOldHackageURI :: URI -> Bool isOldHackageURI uri     = case uriAuthority uri of         Just (URIAuth {uriRegName = "hackage.haskell.org"}) ->             FilePath.Posix.splitDirectories (uriPath uri) == ["/","packages","archive"]         _ -> False+++------------------------------------------------------------------------------+-- Setting up a HttpTransport+--++data HttpTransport = HttpTransport {+      -- | GET a URI, with an optional ETag (to do a conditional fetch),+      -- write the resource to the given file and return the HTTP status code,+      -- and optional ETag.+      getHttp  :: Verbosity -> URI -> Maybe ETag -> FilePath+               -> IO (HttpCode, Maybe ETag),++      -- | POST a resource to a URI, with optional auth (username, password)+      -- and return the HTTP status code and any redirect URL.+      postHttp :: Verbosity -> URI -> String -> Maybe Auth+               -> IO (HttpCode, String),++      -- | POST a file resource to a URI using multipart\/form-data encoding,+      -- with optional auth (username, password) and return the HTTP status+      -- code and any error string.+      postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth+                   -> IO (HttpCode, String),++      -- | Whether this transport supports https or just http.+      transportSupportsHttps :: Bool,++      -- | Whether this transport implementation was specifically chosen by+      -- the user via configuration, or whether it was automatically selected. +      -- Strictly speaking this is not a property of the transport itself but+      -- about how it was chosen. Nevertheless it's convenient to keep here.+      transportManuallySelected :: Bool+    }+    --TODO: why does postHttp return a redirect, but postHttpFile return errors?++type HttpCode = Int+type ETag     = String+type Auth     = (String, String)++noPostYet :: Verbosity -> URI -> String -> Maybe (String, String)+          -> IO (Int, String)+noPostYet _ _ _ _ = die "Posting (for report upload) is not implemented yet"++supportedTransports :: [(String, Maybe Program, Bool,+                         ProgramDb -> Maybe HttpTransport)]+supportedTransports =+    [ let prog = simpleProgram "curl" in+      ( "curl", Just prog, True+      , \db -> curlTransport <$> lookupProgram prog db )++    , let prog = simpleProgram "wget" in+      ( "wget", Just prog, True+      , \db -> wgetTransport <$> lookupProgram prog db )++    , let prog = simpleProgram "powershell" in+      ( "powershell", Just prog, True+      , \db -> powershellTransport <$> lookupProgram prog db )++    , ( "plain-http", Nothing, False+      , \_ -> Just plainHttpTransport )+    ]++configureTransport :: Verbosity -> Maybe String -> IO HttpTransport++configureTransport verbosity (Just name) =+    -- the user secifically selected a transport by name so we'll try and+    -- configure that one++    case find (\(name',_,_,_) -> name' == name) supportedTransports of+      Just (_, mprog, _tls, mkTrans) -> do++        progdb <- case mprog of+          Nothing   -> return emptyProgramDb+          Just prog -> snd <$> requireProgram verbosity prog emptyProgramDb+                       --      ^^ if it fails, it'll fail here++        let Just transport = mkTrans progdb+        return transport { transportManuallySelected = True }++      Nothing -> die $ "Unknown HTTP transport specified: " ++ name+                    ++ ". The supported transports are "+                    ++ intercalate ", "+                         [ name' | (name', _, _, _ ) <- supportedTransports ]++configureTransport verbosity Nothing = do+    -- the user hasn't selected a transport, so we'll pick the first one we+    -- can configure successfully, provided that it supports tls++    -- for all the transports except plain-http we need to try and find+    -- their external executable+    progdb <- configureAllKnownPrograms  verbosity $+                addKnownPrograms+                  [ prog | (_, Just prog, _, _) <- supportedTransports ]+                  emptyProgramDb++    let availableTransports =+          [ (name, transport)+          | (name, _, _, mkTrans) <- supportedTransports+          , transport <- maybeToList (mkTrans progdb) ]+        -- there's always one because the plain one is last and never fails+    let (name, transport) = head availableTransports+    debug verbosity $ "Selected http transport implementation: " ++ name++    return transport { transportManuallySelected = False }+++------------------------------------------------------------------------------+-- The HttpTransports based on external programs+--++curlTransport :: ConfiguredProgram -> HttpTransport+curlTransport prog =+    HttpTransport gethttp posthttp posthttpfile True False+  where+    gethttp verbosity uri etag destPath = do+        withTempFile (takeDirectory destPath)+                     "curl-headers.txt" $ \tmpFile tmpHandle -> do+          hClose tmpHandle+          let args = [ show uri+                   , "--output", destPath+                   , "--location"+                   , "--write-out", "%{http_code}"+                   , "--user-agent", userAgent+                   , "--silent", "--show-error"+                   , "--dump-header", tmpFile ]+                ++ concat+                   [ ["--header", "If-None-Match: " ++ t]+                   | t <- maybeToList etag ]++          resp <- getProgramInvocationOutput verbosity+                    (programInvocation prog args)+          headers <- readFile tmpFile+          (code, _err, etag') <- parseResponse uri resp headers+          return (code, etag')++    posthttp = noPostYet++    posthttpfile verbosity uri path auth = do+        let args = [ show uri+                   , "--form", "package=@"++path+                   , "--write-out", "%{http_code}"+                   , "--user-agent", userAgent+                   , "--silent", "--show-error"+                   , "--header", "Accept: text/plain" ]+                ++ concat+                   [ ["--digest", "--user", uname ++ ":" ++ passwd]+                   | (uname,passwd) <- maybeToList auth ]+        resp <- getProgramInvocationOutput verbosity+                  (programInvocation prog args)+        (code, err, _etag) <- parseResponse uri resp ""+        return (code, err)++    -- on success these curl involcations produces an output like "200"+    -- and on failure it has the server error response first+    parseResponse uri resp headers =+      let codeerr =+            case reverse (lines resp) of+              (codeLine:rerrLines) ->+                case readMaybe (trim codeLine) of+                  Just i  -> let errstr = unlines (reverse rerrLines)+                              in Just (i, errstr)+                  Nothing -> Nothing+              []          -> Nothing++          mb_etag :: Maybe ETag+          mb_etag  = listToMaybe $ reverse+                     [ etag+                     | ["ETag:", etag] <- map words (lines headers) ]++       in case codeerr of+            Just (i, err) -> return (i, err, mb_etag)+            _             -> statusParseFail uri resp+++wgetTransport :: ConfiguredProgram -> HttpTransport+wgetTransport prog =+    HttpTransport gethttp posthttp posthttpfile True False+  where+    gethttp verbosity uri etag destPath = do+        resp <- runWGet verbosity args+        (code, _err, etag') <- parseResponse uri resp+        return (code, etag')+      where+        args = [ show uri+               , "--output-document=" ++ destPath+               , "--user-agent=" ++ userAgent+               , "--tries=5"+               , "--timeout=15"+               , "--server-response" ]+            ++ concat+               [ ["--header", "If-None-Match: " ++ t]+               | t <- maybeToList etag ]++    posthttp = noPostYet++    posthttpfile verbosity  uri path auth =+        withTempFile (takeDirectory path)+                     (takeFileName path) $ \tmpFile tmpHandle -> do+          (body, boundary) <- generateMultipartBody path+          BS.hPut tmpHandle body+          BS.writeFile "wget.in" body+          hClose tmpHandle+          let args = [ show uri+                     , "--post-file=" ++ tmpFile+                     , "--user-agent=" ++ userAgent+                     , "--server-response"+                     , "--header=Content-type: multipart/form-data; " ++ +                                              "boundary=" ++ boundary ]+                  ++ concat+                     [ [ "--http-user=" ++ uname+                       , "--http-password=" ++ passwd ]+                     | (uname,passwd) <- maybeToList auth ]++          resp <- runWGet verbosity args+          (code, err, _etag) <- parseResponse uri resp+          return (code, err)++    runWGet verbosity args = do+        -- wget returns its output on stderr rather than stdout+        (_, resp, exitCode) <- getProgramInvocationOutputAndErrors verbosity+                                 (programInvocation prog args)+        -- wget returns exit code 8 for server "errors" like "304 not modified"+        if exitCode == ExitSuccess || exitCode == ExitFailure 8+          then return resp+          else die $ "'" ++ programPath prog+                  ++ "' exited with an error:\n" ++ resp++    -- With the --server-response flag, wget produces output with the full+    -- 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) ]+          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+++powershellTransport :: ConfiguredProgram -> HttpTransport+powershellTransport prog =+    HttpTransport gethttp posthttp posthttpfile True False+  where+    gethttp verbosity uri etag destPath =+        withTempFile (takeDirectory destPath)+                     "psScript.ps1" $ \tmpFile tmpHandle -> do+           hPutStr tmpHandle script+           hClose tmpHandle+           let args = ["-InputFormat", "None", "-File", tmpFile]+           resp <- getProgramInvocationOutput verbosity+                     (programInvocation prog args)+           parseResponse resp+      where+        script =+          concatMap (++";\n") $+            [ "$wc = new-object system.net.webclient"+            , "$wc.Headers.Add(\"user-agent\","++escape userAgent++")"]+         ++ [ "$wc.Headers.Add(\"If-None-Match\"," ++ t ++ ")"+            | t <- maybeToList etag ]+         ++ [ "Try {"+            ,  "$wc.DownloadFile("++ escape (show uri) +++                              "," ++ escape destPath ++ ")"+            , "} Catch {Write-Error $_; Exit(5);}"+            , "Write-Host \"200\""+            , "Write-Host $wc.ResponseHeaders.Item(\"ETag\")"+            , "Exit" ]++        escape x = '"' : x ++ "\"" --TODO write/find real escape.++        parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of+          Just i  -> return (i, Nothing) -- TODO extract real etag+          Nothing -> statusParseFail uri x++    posthttp = noPostYet++    posthttpfile verbosity uri path auth =+        withTempFile (takeDirectory path)+                     (takeFileName path) $ \tmpFile tmpHandle ->+        withTempFile (takeDirectory path)+                     "psScript.ps1" $ \tmpScriptFile tmpScriptHandle -> do+          (body, boundary) <- generateMultipartBody path+          BS.hPut tmpHandle body+          hClose tmpHandle++          fullPath <- canonicalizePath tmpFile+          hPutStr tmpScriptHandle (script fullPath boundary)+          hClose tmpScriptHandle+          let args = ["-InputFormat", "None", "-File", tmpScriptFile]+          resp <- getProgramInvocationOutput verbosity+                    (programInvocation prog args)+          parseResponse resp+      where+        script fullPath boundary = +          concatMap (++";\n") $+            [ "$wc = new-object system.net.webclient"+            , "$wc.Headers.Add(\"user-agent\","++escape userAgent++")"+            , "$wc.Headers.Add(\"Content-type\"," +++                              "\"multipart/form-data; " +++                              "boundary="++boundary++"\")" ]+         ++ [ "$wc.Credentials = new-object System.Net.NetworkCredential("+              ++ escape uname ++ "," ++ escape passwd ++ ",\"\")"+            | (uname,passwd) <- maybeToList auth ]+         ++ [ "Try {"+            , "$bytes = [System.IO.File]::ReadAllBytes("++escape fullPath++")"+            , "$wc.UploadData("++ escape (show uri) ++ ",$bytes)"+            , "} Catch {Write-Error $_; Exit(1);}"+            , "Write-Host \"200\""+            , "Exit" ]++        escape x = show x++        parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of+          Just i -> return (i, x) -- TODO extract real etag+          Nothing -> statusParseFail uri x+++------------------------------------------------------------------------------+-- The builtin plain HttpTransport+--++plainHttpTransport :: HttpTransport+plainHttpTransport =+    HttpTransport gethttp posthttp posthttpfile False False+  where+    gethttp verbosity uri etag destPath = do+      let req = Request{+                  rqURI     = uri,+                  rqMethod  = GET,+                  rqHeaders = [ Header HdrIfNoneMatch t+                              | t <- maybeToList etag ],+                  rqBody    = BS.empty+                }+      (_, resp) <- cabalBrowse verbosity Nothing (request req)+      let code  = convertRspCode (rspCode resp)+          etag' = lookupHeader HdrETag (rspHeaders resp)+      when (code==200) $+        writeFileAtomic destPath $ rspBody resp+      return (code, etag')++    posthttp = noPostYet++    posthttpfile verbosity uri path auth = do+      (body, boundary) <- generateMultipartBody path+      let headers = [ Header HdrContentType+                             ("multipart/form-data; boundary="++boundary)+                    , Header HdrContentLength (show (BS.length body))+                    , Header HdrAccept ("text/plain")+                    ]+          req = Request {+                  rqURI     = uri,+                  rqMethod  = POST,+                  rqHeaders = headers,+                  rqBody    = body+                }+      (_, resp) <- cabalBrowse verbosity auth (request req)+      return (convertRspCode (rspCode resp), rspErrorString resp)++    convertRspCode (a,b,c) = a*100 + b*10 + c++    rspErrorString resp =+      case lookupHeader HdrContentType (rspHeaders resp) of+        Just contenttype+           | takeWhile (/= ';') contenttype == "text/plain"+          -> BS.unpack (rspBody resp)+        _ -> rspReason resp++    cabalBrowse verbosity auth act = do+      p <- fixupEmptyProxy <$> fetchProxy True+      Exception.handleJust+        (guard . isDoesNotExistError)+        (const . die $ "Couldn't establish HTTP connection. "+                    ++ "Possible cause: HTTP proxy server is down.") $+        browse $ do+          setProxy p+          setErrHandler (warn verbosity . ("http error: "++))+          setOutHandler (debug verbosity)+          setUserAgent  userAgent+          setAllowBasicAuth False+          setAuthorityGen (\_ _ -> return auth)+          act++    fixupEmptyProxy (Proxy uri _) | null uri = NoProxy+    fixupEmptyProxy p = p+++------------------------------------------------------------------------------+-- Common stuff used by multiple transport impls+--++userAgent :: String+userAgent = concat [ "cabal-install/", display Paths_cabal_install.version+                   , " (", display buildOS, "; ", display buildArch, ")"+                   ]++statusParseFail :: URI -> String -> IO a+statusParseFail uri r =+    die $ "Failed to download " ++ show uri ++ " : "+       ++ "No Status Code could be parsed from response: " ++ r++-- Trim+trim :: String -> String+trim = f . f+      where f = reverse . dropWhile isSpace+++------------------------------------------------------------------------------+-- Multipart stuff partially taken from cgi package.+--++generateMultipartBody :: FilePath -> IO (BS.ByteString, String)+generateMultipartBody path = do+    content  <- BS.readFile path+    boundary <- genBoundary+    let !body = formatBody content (BS.pack boundary)+    return (body, boundary)+  where+    formatBody content boundary =+        BS.concat $+        [ crlf, dd, boundary, crlf ]+     ++ [ BS.pack (show header) | header <- headers ]+     ++ [ crlf+        , content+        , crlf, dd, boundary, dd, crlf ]++    headers =+      [ Header (HdrCustom "Content-disposition")+               ("form-data; name=package; " +++                "filename=\"" ++ takeFileName path ++ "\"")+      , Header HdrContentType "application/x-gzip"+      ]++    crlf = BS.pack "\r\n"+    dd   = BS.pack "--"++genBoundary :: IO String+genBoundary = do+    i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer+    return $ showHex i ""++------------------------------------------------------------------------------+-- Compat utils++-- TODO: This is only here temporarily so we can release without also requiring+-- the latest Cabal lib. The function is also included in Cabal now.++getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation+                                    -> IO (String, String, ExitCode)+getProgramInvocationOutputAndErrors verbosity+  ProgramInvocation {+    progInvokePath  = path,+    progInvokeArgs  = args,+    progInvokeEnv   = envOverrides,+    progInvokeCwd   = mcwd,+    progInvokeInput = minputStr,+    progInvokeOutputEncoding = encoding+  } = do+    let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False+        decode | utf8      = fromUTF8 . normaliseLineEndings+               | otherwise = id+    menv <- getEffectiveEnvironment envOverrides+    (output, errors, exitCode) <- rawSystemStdInOut verbosity+                                    path args+                                    mcwd menv+                                    input utf8+    return (decode output, decode errors, exitCode)+  where+    input =+      case minputStr of+        Nothing       -> Nothing+        Just inputStr -> Just $+          case encoding of+            IOEncodingText -> (inputStr, False)+            IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8

cabal/cabal-install/Distribution/Client/IndexUtils.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.IndexUtils@@ -11,15 +12,15 @@ -- Extra utils related to the package indexes. ----------------------------------------------------------------------------- module Distribution.Client.IndexUtils (+  getIndexFileAge,   getInstalledPackages,   getSourcePackages,   getSourcePackagesStrict,-  convert, -  readPackageIndexFile,   parsePackageIndex,   readRepoIndex,   updateRepoIndexCache,+  updatePackageIndexCacheFile,    BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType   ) where@@ -30,11 +31,10 @@ import Distribution.Package          ( PackageId, PackageIdentifier(..), PackageName(..)          , Package(..), packageVersion, packageName-         , Dependency(Dependency), InstalledPackageId(..) )+         , Dependency(Dependency) ) import Distribution.Client.PackageIndex (PackageIndex) import qualified Distribution.Client.PackageIndex      as PackageIndex-import qualified Distribution.Simple.PackageIndex      as InstalledPackageIndex-import qualified Distribution.InstalledPackageInfo     as InstalledPackageInfo+import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse import Distribution.PackageDescription          ( GenericPackageDescription )@@ -55,21 +55,24 @@ import Distribution.Verbosity          ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils-         ( die, warn, info, fromUTF8, tryFindPackageDesc )+         ( die, warn, info, fromUTF8, ignoreBOM )  import Data.Char   (isAlphaNum)-import Data.Maybe  (mapMaybe, fromMaybe)+import Data.Maybe  (mapMaybe) import Data.List   (isPrefixOf)+#if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid(..))+#endif import qualified Data.Map as Map-import Control.Monad (MonadPlus(mplus), when, liftM)+import Control.Monad (when, liftM) import Control.Exception (evaluate) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.ByteString.Char8 as BSS import Data.ByteString.Lazy (ByteString) import Distribution.Client.GZipUtils (maybeDecompress)-import Distribution.Client.Utils (byteStringToFilePath)+import Distribution.Client.Utils ( byteStringToFilePath+                                 , tryFindAddSourcePackageDesc ) import Distribution.Compat.Exception (catchIO) import Distribution.Client.Compat.Time (getFileAge, getModTime) import System.Directory (doesFileExist)@@ -83,42 +86,13 @@  getInstalledPackages :: Verbosity -> Compiler                      -> PackageDBStack -> ProgramConfiguration-                     -> IO InstalledPackageIndex.PackageIndex+                     -> IO InstalledPackageIndex getInstalledPackages verbosity comp packageDbs conf =     Configure.getInstalledPackages verbosity' comp packageDbs conf   where     --FIXME: make getInstalledPackages use sensible verbosity in the first place     verbosity'  = lessVerbose verbosity -convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage-convert 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 (sourceDeps index' ipkg)-    | (_,ipkg:_) <- InstalledPackageIndex.allPackagesBySourcePackageId index' ]-  where-    -- The InstalledPackageInfo only lists dependencies by the-    -- InstalledPackageId, which means we do not directly know the corresponding-    -- source dependency. The only way to find out is to lookup the-    -- InstalledPackageId 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-    -- non-existant package.-    sourceDeps index ipkg =-      [ maybe (brokenPackageId depid) packageId mdep-      | let depids = InstalledPackageInfo.depends ipkg-            getpkg = InstalledPackageIndex.lookupInstalledPackageId index-      , (depid, mdep) <- zip depids (map getpkg depids) ]--    brokenPackageId (InstalledPackageId str) =-      PackageIdentifier (PackageName (str ++ "-broken")) (Version [] [])- ------------------------------------------------------------------------ -- Reading the source package index --@@ -178,10 +152,9 @@   let indexFile = repoLocalDir repo </> "00-index.tar"       cacheFile = repoLocalDir repo </> "00-index.cache"   in handleNotFound $ do-    warnIfIndexIsOld indexFile+    warnIfIndexIsOld =<< getIndexFileAge repo     whenCacheOutOfDate indexFile cacheFile $ do-      info verbosity "Updating the index cache file..."-      updatePackageIndexCacheFile indexFile cacheFile+      updatePackageIndexCacheFile verbosity indexFile cacheFile     readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile mode    where@@ -212,23 +185,27 @@       else ioError e      isOldThreshold = 15 --days-    warnIfIndexIsOld indexFile = do-      dt <- getFileAge indexFile+    warnIfIndexIsOld dt = do       when (dt >= isOldThreshold) $ case repoKind repo of         Left  remoteRepo -> warn verbosity $              "The package list for '" ++ remoteRepoName remoteRepo-          ++ "' is " ++ show dt ++ " days old.\nRun "+          ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "           ++ "'hackport update' to get the latest list of available packages."         Right _localRepo -> return () ++-- | Return the age of the index file in days (as a Double).+getIndexFileAge :: Repo -> IO Double+getIndexFileAge repo = getFileAge $ repoLocalDir repo </> "00-index.tar"++ -- | 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. -- updateRepoIndexCache :: Verbosity -> Repo -> IO () updateRepoIndexCache verbosity repo =     whenCacheOutOfDate indexFile cacheFile $ do-      info verbosity "Updating the index cache file..."-      updatePackageIndexCacheFile indexFile cacheFile+      updatePackageIndexCacheFile verbosity indexFile cacheFile   where     indexFile = repoLocalDir repo </> "00-index.tar"     cacheFile = repoLocalDir repo </> "00-index.cache"@@ -241,7 +218,7 @@     else do       origTime  <- getModTime origFile       cacheTime <- getModTime cacheFile-      when (origTime >= cacheTime) action+      when (origTime > cacheTime) action  ------------------------------------------------------------------------ -- Reading the index file@@ -278,56 +255,36 @@ packageDesc (NormalPackage  _ descr _ _) = descr packageDesc (BuildTreeRef _ _ descr _ _) = descr --- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'.------ This is supposed to be an \"all in one\" way to easily get at the info in--- the hackage package index.------ It takes a function to map a 'GenericPackageDescription' into any more--- specific instance of 'Package' that you might want to use. In the simple--- case you can just use @\_ p -> p@ here.----readPackageIndexFile :: Package pkg-                     => (PackageEntry -> pkg)-                     -> FilePath-                     -> IO (PackageIndex pkg, [Dependency])-readPackageIndexFile mkPkg indexFile = do-  (mkPkgs, prefs) <- either fail return-                     . parsePackageIndex-                     . maybeDecompress-                     =<< BS.readFile indexFile--  pkgEntries  <- sequence mkPkgs-  pkgs <- evaluate $ PackageIndex.fromList (map mkPkg pkgEntries)-  return (pkgs, prefs)- -- | Parse an uncompressed \"00-index.tar\" repository index file represented -- as a 'ByteString'. --++data PackageOrDep = Pkg PackageEntry | Dep Dependency+ parsePackageIndex :: ByteString-                  -> Either String ([MkPackageEntry], [Dependency])-parsePackageIndex = accum 0 [] [] . Tar.read+                  -> [IO PackageOrDep]+parsePackageIndex = accum 0 . Tar.read   where-    accum blockNo pkgs prefs es = case es of-      Tar.Fail err   -> Left  err-      Tar.Done       -> Right (reverse pkgs, reverse prefs)-      Tar.Next e es' -> accum blockNo' pkgs' prefs' es'+    accum blockNo es = case es of+      Tar.Fail err   -> error ("parsePackageIndex: " ++ err)+      Tar.Done       -> []+      Tar.Next e es' -> ps ++ accum blockNo' es'         where-          (pkgs', prefs') = extract blockNo pkgs prefs e-          blockNo'        = blockNo + Tar.entrySizeInBlocks e+          ps       = extract blockNo e+          blockNo' = blockNo + Tar.entrySizeInBlocks e -    extract blockNo pkgs prefs entry =-       fromMaybe (pkgs, prefs) $-                 tryExtractPkg-         `mplus` tryExtractPrefs+    extract blockNo entry = tryExtractPkg ++ tryExtractPrefs       where+        maybeToList Nothing  = []+        maybeToList (Just a) = [a]+         tryExtractPkg = do-          mkPkgEntry <- extractPkg entry blockNo-          return (mkPkgEntry:pkgs, prefs)+          mkPkgEntry <- maybeToList $ extractPkg entry blockNo+          return (fmap Pkg mkPkgEntry)          tryExtractPrefs = do-          prefs' <- extractPrefs entry-          return (pkgs, prefs'++prefs)+          (_,prefs') <- maybeToList $ extractPrefs entry+          map (return . Dep) $ prefs'  extractPkg :: Tar.Entry -> BlockNo -> Maybe MkPackageEntry extractPkg entry blockNo = case Tar.entryContent entry of@@ -338,7 +295,7 @@           Just ver -> Just $ return (NormalPackage pkgid descr content blockNo)             where               pkgid  = PackageIdentifier (PackageName pkgname) ver-              parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack+              parsed = parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack                                                $ content               descr  = case parsed of                 ParseOk _ d -> d@@ -351,7 +308,8 @@     | Tar.isBuildTreeRefTypeCode typeCode ->       Just $ do         let path   = byteStringToFilePath content-        cabalFile <- tryFindPackageDesc path+            err = "Error reading package index."+        cabalFile <- tryFindAddSourcePackageDesc path err         descr     <- PackageDesc.Parse.readPackageDescription normal cabalFile         return $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr)                               descr path blockNo@@ -361,16 +319,18 @@   where     fileName = Tar.entryPath entry -extractPrefs :: Tar.Entry -> Maybe [Dependency]+extractPrefs :: Tar.Entry -> Maybe (FilePath, [Dependency]) extractPrefs entry = case Tar.entryContent entry of {-  -- get rid of hackage's preferred-versions  -- I'd like to have bleeding-edge packages in system and I don't fear of  -- broken packages with improper depends   Tar.NormalFile content _-     | takeFileName (Tar.entryPath entry) == "preferred-versions"-    -> Just . parsePreferredVersions-     . BS.Char8.unpack $ content+     | takeFileName entrypath == "preferred-versions"+    -> Just (entrypath, prefs)+    where+      entrypath = Tar.entryPath entry+      prefs     = parsePreferredVersions (BS.Char8.unpack content) -}   _ -> Nothing @@ -383,22 +343,27 @@ -- Reading and updating the index cache -- -updatePackageIndexCacheFile :: FilePath -> FilePath -> IO ()-updatePackageIndexCacheFile indexFile cacheFile = do-    (mkPkgs, prefs) <- either fail return-                       . parsePackageIndex-                       . maybeDecompress-                       =<< BS.readFile indexFile-    pkgEntries <- sequence mkPkgs-    let cache = mkCache pkgEntries prefs+lazySequence :: [IO a] -> IO [a]+lazySequence [] = return []+lazySequence (x:xs) = unsafeInterleaveIO $ do+    x'  <- unsafeInterleaveIO x+    xs' <- lazySequence xs+    return (x':xs')++updatePackageIndexCacheFile :: Verbosity -> FilePath -> FilePath -> IO ()+updatePackageIndexCacheFile verbosity indexFile cacheFile = do+    info verbosity ("Updating index cache file " ++ cacheFile)+    pkgsOrPrefs <- return+                 . parsePackageIndex+                 . maybeDecompress+               =<< BS.readFile indexFile+    entries <- lazySequence pkgsOrPrefs+    let cache = map toCache entries     writeFile cacheFile (showIndexCache cache)   where-    mkCache pkgs prefs =-        [ CachePreference pref          | pref <- prefs ]-     ++ [ CachePackageId pkgid blockNo-        | (NormalPackage pkgid _ _ blockNo) <- pkgs ]-     ++ [ CacheBuildTreeRef refType blockNo-        | (BuildTreeRef refType _ _ _ blockNo) <- pkgs]+    toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo+    toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo+    toCache (Dep d) = CachePreference d  data ReadPackageIndexMode = ReadPackageIndexStrict                           | ReadPackageIndexLazyIO@@ -457,8 +422,9 @@       -- package id for build tree references - the user might edit the .cabal       -- file after the reference was added to the index.       path <- liftM byteStringToFilePath . getEntryContent $ blockno-      pkg  <- do cabalFile <- tryFindPackageDesc path-                 PackageDesc.Parse.readPackageDescription normal cabalFile+      pkg  <- do let err = "Error reading package index from cache."+                 file <- tryFindAddSourcePackageDesc path err+                 PackageDesc.Parse.readPackageDescription normal file       let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)       accum (srcpkg:srcpkgs) prefs entries @@ -486,7 +452,7 @@      readPackageDescription :: ByteString -> IO GenericPackageDescription     readPackageDescription content =-      case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of+      case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of         ParseOk _ d -> return d         _           -> interror "failed to parse .cabal file" @@ -508,31 +474,32 @@                      | CachePreference Dependency   deriving (Eq) +packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String+packageKey = "pkg:"+blocknoKey = "b#"+buildTreeRefKey     = "build-tree-ref:"+preferredVersionKey = "pref-ver:"+ readIndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry readIndexCacheEntry = \line ->   case BSS.words line of     [key, pkgnamestr, pkgverstr, sep, blocknostr]-      | key == packageKey && sep == 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)         _ -> Nothing-    [key, typecodestr, blocknostr] | key == buildTreeRefKey ->+    [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey ->       case (parseRefType typecodestr, parseBlockNo blocknostr) of         (Just refType, Just blockno)           -> Just (CacheBuildTreeRef refType blockno)         _ -> Nothing -    (key: remainder) | key == preferredVersionKey ->+    (key: remainder) | key == BSS.pack preferredVersionKey ->       fmap CachePreference (simpleParse (BSS.unpack (BSS.unwords remainder)))     _  -> Nothing   where-    packageKey = BSS.pack "pkg:"-    blocknoKey = BSS.pack "b#"-    buildTreeRefKey     = BSS.pack "build-tree-ref:"-    preferredVersionKey = BSS.pack "pref-ver:"-     parseName str       | BSS.all (\c -> isAlphaNum c || c == '-') str                   = Just (PackageName (BSS.unpack str))@@ -559,13 +526,20 @@         _   -> Nothing  showIndexCacheEntry :: IndexCacheEntry -> String-showIndexCacheEntry entry = case entry of-   CachePackageId pkgid b -> "pkg: " ++ display (packageName pkgid)-                                  ++ " " ++ display (packageVersion pkgid)-                          ++ " b# " ++ show b-   CacheBuildTreeRef t b  -> "build-tree-ref: " ++ (typeCodeFromRefType t:" ")-                             ++ show b-   CachePreference dep    -> "pref-ver: " ++ display dep+showIndexCacheEntry entry = unwords $ case entry of+   CachePackageId pkgid b -> [ packageKey+                             , display (packageName pkgid)+                             , display (packageVersion pkgid)+                             , blocknoKey+                             , show b+                             ]+   CacheBuildTreeRef t b  -> [ buildTreeRefKey+                             , [typeCodeFromRefType t]+                             , show b+                             ]+   CachePreference dep    -> [ preferredVersionKey+                             , display dep+                             ]  readIndexCache :: BSS.ByteString -> [IndexCacheEntry] readIndexCache = mapMaybe readIndexCacheEntry . BSS.lines

cabal/cabal-install/Distribution/Client/Init.hs view

@@ -25,7 +25,7 @@   ( hSetBuffering, stdout, BufferMode(..) ) import System.Directory   ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile-  , getDirectoryContents )+  , getDirectoryContents, createDirectoryIfMissing ) import System.FilePath   ( (</>), (<.>), takeBaseName ) import Data.Time@@ -36,16 +36,18 @@ import Data.List   ( intercalate, nub, groupBy, (\\) ) import Data.Maybe-  ( fromMaybe, isJust, catMaybes )+  ( fromMaybe, isJust, catMaybes, listToMaybe ) import Data.Function   ( on ) import qualified Data.Map as M-import Data.Traversable-  ( traverse )+#if !MIN_VERSION_base(4,8,0) import Control.Applicative   ( (<$>) )+import Data.Traversable+  ( traverse )+#endif import Control.Monad-  ( when, unless, (>=>), join )+  ( when, unless, (>=>), join, forM_ ) import Control.Arrow   ( (&&&), (***) ) @@ -67,9 +69,10 @@ import Distribution.Client.Init.Types   ( InitFlags(..), PackageType(..), Category(..) ) import Distribution.Client.Init.Licenses-  ( bsd3, gplv2, gplv3, lgpl2, lgpl3, agplv3, apache20 )+  ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc ) import Distribution.Client.Init.Heuristics-  ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..),+  ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates,+    SourceFileEntry(..),     scanForModules, neededBuildPrograms )  import Distribution.License@@ -86,26 +89,40 @@ import Distribution.Simple.Program   ( ProgramConfiguration ) import Distribution.Simple.PackageIndex-  ( PackageIndex, moduleNameIndex )+  ( InstalledPackageIndex, moduleNameIndex ) import Distribution.Text   ( display, Text(..) ) +import Distribution.Client.PackageIndex+  ( elemByPackageName )+import Distribution.Client.IndexUtils+  ( getSourcePackages )+import Distribution.Client.Types+  ( SourcePackageDb(..), Repo )+ initCabal :: Verbosity           -> PackageDBStack+          -> [Repo]           -> Compiler           -> ProgramConfiguration           -> InitFlags           -> IO ()-initCabal verbosity packageDBs comp conf initFlags = do+initCabal verbosity packageDBs repos comp conf initFlags = do    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+  sourcePkgDb <- getSourcePackages verbosity repos    hSetBuffering stdout NoBuffering -  initFlags' <- extendFlags installedPkgIndex initFlags+  initFlags' <- extendFlags installedPkgIndex sourcePkgDb initFlags -  writeLicense initFlags'+  case license initFlags' of+    Flag PublicDomain -> return ()+    _                 -> writeLicense initFlags'   writeSetupFile initFlags'+  writeChangeLog initFlags'+  createSourceDirectories initFlags'+  createMainHs initFlags'   success <- writeCabalFile initFlags'    when success $ generateWarnings initFlags'@@ -116,9 +133,9 @@  -- | Fill in more details by guessing, discovering, or prompting the --   user.-extendFlags :: PackageIndex -> InitFlags -> IO InitFlags-extendFlags pkgIx =-      getPackageName+extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags+extendFlags pkgIx sourcePkgDb =+      getPackageName sourcePkgDb   >=> getVersion   >=> getLicense   >=> getAuthorInfo@@ -127,9 +144,9 @@   >=> getCategory   >=> getExtraSourceFiles   >=> getLibOrExec+  >=> getSrcDir   >=> getLanguage   >=> getGenComments-  >=> getSrcDir   >=> getModulesBuildToolsAndDeps pkgIx  -- | Combine two actions which may return a value, preferring the first. That@@ -147,23 +164,41 @@ maybeToFlag = maybe NoFlag Flag  -- | Get the package name: use the package directory (supplied, or the current---   directory by default) as a guess.-getPackageName :: InitFlags -> IO InitFlags-getPackageName flags = do+--   directory by default) as a guess. It looks at the SourcePackageDb to avoid+--   using an existing package name.+getPackageName :: SourcePackageDb -> InitFlags -> IO InitFlags+getPackageName sourcePkgDb flags = do   guess    <-     traverse guessPackageName (flagToMaybe $ packageDir flags)               ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName) +  let guess' | isPkgRegistered guess = Nothing+             | otherwise = guess+   pkgName' <-     return (flagToMaybe $ packageName flags)-              ?>> maybePrompt flags (promptStr "Package name" guess)-              ?>> return guess+              ?>> maybePrompt flags (prompt "Package name" guess')+              ?>> return guess' -  return $ flags { packageName = maybeToFlag pkgName' }+  chooseAgain <- if isPkgRegistered pkgName'+                    then promptYesNo promptOtherNameMsg (Just True)+                    else return False +  if chooseAgain+    then getPackageName sourcePkgDb flags+    else return $ flags { packageName = maybeToFlag pkgName' }++  where+    isPkgRegistered (Just pkg) = elemByPackageName (packageIndex sourcePkgDb) pkg+    isPkgRegistered Nothing    = False++    promptOtherNameMsg = "This package name is already used by another " +++                         "package on hackage. Do you want to choose a " +++                         "different name"+ -- | Package version: use 0.1.0.0 as a last resort, but try prompting the user --  if possible. getVersion :: InitFlags -> IO InitFlags getVersion flags = do-  let v = Just $ Version { versionBranch = [0,1,0,0], versionTags = [] }+  let v = Just $ Version [0,1,0,0] []   v' <-     return (flagToMaybe $ version flags)         ?>> maybePrompt flags (prompt "Package version" v)         ?>> return v@@ -173,9 +208,9 @@ getLicense :: InitFlags -> IO InitFlags getLicense flags = do   lic <-     return (flagToMaybe $ license flags)-         ?>> fmap (fmap (either UnknownLicense id) . join)+         ?>> fmap (fmap (either UnknownLicense id))                   (maybePrompt flags-                    (promptListOptional "Please choose a license" listedLicenses))+                    (promptList "Please choose a license" listedLicenses (Just BSD3) display True))   return $ flags { license = maybeToFlag lic }   where     listedLicenses =@@ -241,6 +276,9 @@    return $ flags { extraSrc = extraSrcFiles } +defaultChangeLog :: FilePath+defaultChangeLog = "ChangeLog.md"+ -- | Try to guess things to include in the extra-source-files field. --   For now, we just look for things in the root directory named --   'readme', 'changes', or 'changelog', with any sort of@@ -250,12 +288,16 @@   dir <-     maybe getCurrentDirectory return . flagToMaybe $ packageDir flags   files <- getDirectoryContents dir-  return $ filter isExtra files+  let extraFiles = filter isExtra files+  if any isLikeChangeLog extraFiles+    then return extraFiles+    else return (defaultChangeLog : extraFiles)    where-    isExtra = (`elem` ["README", "CHANGES", "CHANGELOG"])-            . map toUpper-            . takeBaseName+    isExtra = likeFileNameBase ("README" : changeLogLikeBases)+    isLikeChangeLog = likeFileNameBase changeLogLikeBases+    likeFileNameBase candidates = (`elem` candidates) . map toUpper . takeBaseName+    changeLogLikeBases = ["CHANGES", "CHANGELOG"]  -- | Ask whether the project builds a library or executable. getLibOrExec :: InitFlags -> IO InitFlags@@ -266,9 +308,29 @@                                    [Library, Executable]                                    Nothing display False)            ?>> return (Just Library)+  mainFile <- if isLib /= Just Executable then return Nothing else+                    getMainFile flags -  return $ flags { packageType = maybeToFlag isLib }+  return $ flags { packageType = maybeToFlag isLib+                 , mainIs = maybeToFlag mainFile+                 } +-- | Try to guess the main file of the executable, and prompt the user to choose+-- one of them. Top-level modules including the word 'Main' in the file name+-- will be candidates, and shorter filenames will be preferred.+getMainFile :: InitFlags -> IO (Maybe FilePath)+getMainFile flags =+  return (flagToMaybe $ mainIs flags)+  ?>> do+    candidates <- guessMainFileCandidates flags+    let showCandidate = either (++" (does not yet exist, but will be created)") id+        defaultFile = listToMaybe candidates+    maybePrompt flags (either id (either id id) `fmap`+                       promptList "What is the main module of the executable"+                       candidates+                       defaultFile showCandidate True)+      ?>> return (fmap (either id id) defaultFile)+ -- | Ask for the base language of the package. getLanguage :: InitFlags -> IO InitFlags getLanguage flags = do@@ -290,33 +352,36 @@                  ?>> return (Just False)   return $ flags { noComments = maybeToFlag (fmap not genComments) }   where-    promptMsg = "Include documentation on what each field means (y/n)"+    promptMsg = "Add informative comments to each field in the cabal file (y/n)" --- | Try to guess the source root directory (don't prompt the user).+-- | Ask for the source root directory. getSrcDir :: InitFlags -> IO InitFlags getSrcDir flags = do-  srcDirs <-     return (sourceDirs flags)-             ?>> Just `fmap` guessSourceDirs flags+  srcDirs <- return (sourceDirs flags)+             ?>> fmap (:[]) `fmap` guessSourceDir flags+             ?>> fmap (fmap ((:[]) . either id id) . join) (maybePrompt+                      flags+                      (promptListOptional' "Source directory" ["src"] id))    return $ flags { sourceDirs = srcDirs } --- | Try to guess source directories.  Could try harder; for the+-- | Try to guess source directory. Could try harder; for the --   moment just looks to see whether there is a directory called 'src'.-guessSourceDirs :: InitFlags -> IO [String]-guessSourceDirs flags = do+guessSourceDir :: InitFlags -> IO (Maybe String)+guessSourceDir flags = do   dir      <-     maybe getCurrentDirectory return . flagToMaybe $ packageDir flags   srcIsDir <- doesDirectoryExist (dir </> "src")-  if srcIsDir-    then return ["src"]-    else return []+  return $ if srcIsDir+             then Just "src"+             else Nothing  -- | Get the list of exposed modules and extra tools needed to build them.-getModulesBuildToolsAndDeps :: PackageIndex -> InitFlags -> IO InitFlags+getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags getModulesBuildToolsAndDeps pkgIx flags = do   dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags -  -- XXX really should use guessed source roots.+  -- TODO: really should use guessed source roots.   sourceFiles <- scanForModules dir    Just mods <-      return (exposedModules flags)@@ -346,7 +411,7 @@                  , otherExts      = exts                  } -importsToDeps :: InitFlags -> [ModuleName] -> PackageIndex -> IO [P.Dependency]+importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency] importsToDeps flags mods pkgIx = do    let modMap :: M.Map ModuleName [InstalledPackageInfo]@@ -477,10 +542,17 @@                    => String            -- ^ prompt                    -> [t]               -- ^ choices                    -> IO (Maybe (Either String t))-promptListOptional pr choices =+promptListOptional pr choices = promptListOptional' pr choices display++promptListOptional' :: Eq t+                   => String            -- ^ prompt+                   -> [t]               -- ^ choices+                   -> (t -> String)     -- ^ show an item+                   -> IO (Maybe (Either String t))+promptListOptional' pr choices displayItem =     fmap rearrange   $ promptList pr (Nothing : map Just choices) (Just Nothing)-               (maybe "(none)" display) True+               (maybe "(none)" displayItem) True   where     rearrange = either (Just . Left) (fmap Right) @@ -534,23 +606,24 @@ writeLicense :: InitFlags -> IO () writeLicense flags = do   message flags "\nGenerating LICENSE..."-  year <- getYear+  year <- show <$> getYear+  let authors = fromMaybe "???" . flagToMaybe . author $ flags   let licenseFile =         case license flags of-          Flag BSD3 -> Just $ bsd3 (fromMaybe "???"-                                  . flagToMaybe-                                  . author-                                  $ flags)-                              (show year)+          Flag BSD2+            -> Just $ bsd2 authors year +          Flag BSD3+            -> Just $ bsd3 authors year+           Flag (GPL (Just (Version {versionBranch = [2]})))             -> Just gplv2            Flag (GPL (Just (Version {versionBranch = [3]})))             -> Just gplv3 -          Flag (LGPL (Just (Version {versionBranch = [2]})))-            -> Just lgpl2+          Flag (LGPL (Just (Version {versionBranch = [2, 1]})))+            -> Just lgpl21            Flag (LGPL (Just (Version {versionBranch = [3]})))             -> Just lgpl3@@ -561,6 +634,15 @@           Flag (Apache (Just (Version {versionBranch = [2, 0]})))             -> Just apache20 +          Flag MIT+            -> Just $ mit authors year++          Flag (MPL (Version {versionBranch = [2, 0]}))+            -> Just mpl20++          Flag ISC+            -> Just $ isc authors year+           _ -> Nothing    case licenseFile of@@ -585,12 +667,29 @@     , "main = defaultMain"     ] +writeChangeLog :: InitFlags -> IO ()+writeChangeLog flags = when (any (== defaultChangeLog) $ maybe [] id (extraSrc flags)) $ do+  message flags ("Generating "++ defaultChangeLog ++"...")+  writeFileSafe flags defaultChangeLog changeLog+ where+  changeLog = unlines+    [ "# Revision history for " ++ pname+    , ""+    , "## " ++ pver ++ "  -- YYYY-mm-dd"+    , ""+    , "* First version. Released on an unsuspecting world."+    ]+  pname = maybe "" display $ flagToMaybe $ packageName flags+  pver = maybe "" display $ flagToMaybe $ version flags+++ writeCabalFile :: InitFlags -> IO Bool writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do   message flags "Error: no package name provided."   return False writeCabalFile flags@(InitFlags{packageName = Flag p}) = do-  let cabalFileName = p ++ ".cabal"+  let cabalFileName = display p ++ ".cabal"   message flags $ "Generating " ++ cabalFileName ++ "..."   writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags)   return True@@ -602,6 +701,44 @@   moveExistingFile flags fileName   writeFile fileName content +-- | Create source directories, if they were given.+createSourceDirectories :: InitFlags -> IO ()+createSourceDirectories flags = case sourceDirs flags of+                                  Just dirs -> forM_ dirs (createDirectoryIfMissing True)+                                  Nothing   -> return ()++-- | Create Main.hs, but only if we are init'ing an executable and+--   the mainIs flag has been provided.+createMainHs :: InitFlags -> IO ()+createMainHs flags@InitFlags{ sourceDirs = Just (srcPath:_)+                            , packageType = Flag Executable+                            , mainIs = Flag mainFile } =+  writeMainHs flags (srcPath </> mainFile)+createMainHs flags@InitFlags{ sourceDirs = _+                            , packageType = Flag Executable+                            , mainIs = Flag mainFile } =+  writeMainHs flags mainFile+createMainHs _ = return ()++-- | Write a main file if it doesn't already exist.+writeMainHs :: InitFlags -> FilePath -> IO ()+writeMainHs flags mainPath = do+  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)+  let mainFullPath = dir </> mainPath+  exists <- doesFileExist mainFullPath+  unless exists $ do+      message flags $ "Generating " ++ mainPath ++ "..."+      writeFileSafe flags mainFullPath mainHs++-- | Default Main.hs file.  Used when no Main.hs exists.+mainHs :: String+mainHs = unlines+  [ "module Main where"+  , ""+  , "main :: IO ()"+  , "main = putStrLn \"Hello, Haskell!\""+  ]+ -- | Move an existing file, if there is one, and the overwrite flag is --   not set. moveExistingFile :: InitFlags -> FilePath -> IO ()@@ -632,6 +769,7 @@ --   pretty-printing code to generate the file. generateCabalFile :: String -> InitFlags -> String generateCabalFile fileName c =+  (++ "\n") .   renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $   (if minimal c /= Flag True     then showComment (Just $ "Initial " ++ fileName ++ " generated by cabal "@@ -640,12 +778,12 @@          $$ text ""     else empty)   $$-  vcat [ fieldS "name"          (packageName   c)+  vcat [ field  "name"          (packageName   c)                 (Just "The name of the package.")                 True         , field  "version"       (version       c)-                (Just $ "The package version.  See the Haskell package versioning policy (PVP) for standards guiding when and how versions should be incremented.\nhttp://www.haskell.org/haskellwiki/Package_versioning_policy\n"+                (Just $ "The package version.  See the Haskell package versioning policy (PVP) for standards guiding when and how versions should be incremented.\nhttps://wiki.haskell.org/Package_versioning_policy\n"                 ++ "PVP summary:      +-+------- breaking API changes\n"                 ++ "                  | | +----- non-breaking API additions\n"                 ++ "                  | | | +--- code changes with no API change")@@ -671,9 +809,11 @@                 (Just "The license under which the package is released.")                 True -       , fieldS "license-file" (Flag "LICENSE")-                (Just "The file containing the license text.")-                True+       , case (license c) of+           Flag PublicDomain -> empty+           _ -> fieldS "license-file" (Flag "LICENSE")+                       (Just "The file containing the license text.")+                       True         , fieldS "author"        (author       c)                 (Just "The package author(s).")@@ -683,9 +823,11 @@                 (Just "An email address to which users can send suggestions, bug reports, and patches.")                 True -       , fieldS "copyright"     NoFlag-                (Just "A copyright notice.")-                True+       , case (license c) of+           Flag PublicDomain -> empty+           _ -> fieldS "copyright"     NoFlag+                       (Just "A copyright notice.")+                       True         , fieldS "category"      (either id display `fmap` category c)                 Nothing@@ -705,8 +847,10 @@         , case packageType c of            Flag Executable ->-             text "\nexecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ nest 2 (vcat-             [ fieldS "main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True+             text "\nexecutable" <+>+             text (maybe "" display . flagToMaybe $ packageName c) $$+             nest 2 (vcat+             [ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True               , generateBuildInfo Executable c              ])

cabal/cabal-install/Distribution/Client/Init/Heuristics.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Init.Heuristics@@ -15,15 +16,17 @@     guessPackageName,     scanForModules,     SourceFileEntry(..),     neededBuildPrograms,+    guessMainFileCandidates,     guessAuthorNameMail,     knownCategories, ) where import Distribution.Text         (simpleParse)-import Distribution.Simple.Setup (Flag(..))+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@@ -33,27 +36,77 @@ 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   ( isUpper, isLower, isSpace )+import Data.Char   ( isAlphaNum, isNumber, isUpper, isLower, isSpace ) import Data.Either ( partitionEithers )-import Data.List   ( isPrefixOf )+import Data.List   ( isInfixOf, isPrefixOf, isSuffixOf, sortBy ) import Data.Maybe  ( mapMaybe, catMaybes, maybeToList )-import Data.Monoid ( mempty, mconcat )+import Data.Ord    ( comparing ) import qualified Data.Set as Set ( fromList, toList )-import System.Directory ( getDirectoryContents,+import System.Directory ( getCurrentDirectory, getDirectoryContents,                           doesDirectoryExist, doesFileExist, getHomeDirectory, ) import Distribution.Compat.Environment ( getEnvironment ) import System.FilePath ( takeExtension, takeBaseName, dropExtension,                          (</>), (<.>), splitDirectories, makeRelative ) +import Distribution.Client.Init.Types     ( InitFlags(..) ) import Distribution.Client.Compat.Process ( readProcessWithExitCode ) import System.Exit ( ExitCode(..) ) --- |Guess the package name based on the given root directory-guessPackageName :: FilePath -> IO String-guessPackageName = liftM (last . splitDirectories) . tryCanonicalizePath+-- | Return a list of candidate main files for this executable: top-level+-- modules including the word 'Main' in the file name. The list is sorted in+-- order of preference, shorter file names are preferred. 'Right's are existing+-- candidates and 'Left's are those that do not yet exist.+guessMainFileCandidates :: InitFlags -> IO [Either FilePath FilePath]+guessMainFileCandidates flags = do+  dir <-+    maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)+  files <- getDirectoryContents dir+  let existingCandidates = filter isMain files+      -- We always want to give the user at least one default choice.  If either+      -- Main.hs or Main.lhs has already been created, then we don't want to+      -- suggest the other; however, if neither has been created, then we+      -- suggest both.+      newCandidates =+        if any (`elem` existingCandidates) ["Main.hs", "Main.lhs"]+        then []+        else ["Main.hs", "Main.lhs"]+      candidates =+        sortBy (\x y -> comparing (length . either id id) x y+                        `mappend` compare x y)+               (map Left newCandidates ++ map Right existingCandidates)+  return candidates +  where+    isMain f =    (isInfixOf "Main" f || isInfixOf  "main" f)+               && (isSuffixOf ".hs" f || isSuffixOf ".lhs" f)++-- | Guess the package name based on the given root directory.+guessPackageName :: FilePath -> IO P.PackageName+guessPackageName = liftM (P.PackageName . repair . last . splitDirectories)+                 . tryCanonicalizePath+  where+    -- Treat each span of non-alphanumeric characters as a hyphen. Each+    -- hyphenated component of a package name must contain at least one+    -- alphabetic character. An arbitrary character ('x') will be prepended if+    -- this is not the case for the first component, and subsequent components+    -- will simply be run together. For example, "1+2_foo-3" will become+    -- "x12-foo3".+    repair = repair' ('x' :) id+    repair' invalid valid x = case dropWhile (not . isAlphaNum) x of+        "" -> repairComponent ""+        x' -> let (c, r) = first repairComponent $ break (not . isAlphaNum) x'+              in c ++ repairRest r+      where+        repairComponent c | all isNumber c = invalid c+                          | otherwise      = valid c+    repairRest = repair' id ('-' :)+ -- |Data type of source files found in the working directory data SourceFileEntry = SourceFileEntry     { relativeSourcePath :: FilePath@@ -68,7 +121,7 @@   = projectRoot </> relPath </> toFilePath m <.> ext  -- |Search for source files in the given directory--- and return pairs of guessed haskell source path and+-- and return pairs of guessed Haskell source path and -- module names. scanForModules :: FilePath -> IO [SourceFileEntry] scanForModules rootDir = scanForModulesIn rootDir rootDir@@ -122,7 +175,7 @@               . lines               $ s -      -- XXX we should probably make a better attempt at parsing+      -- TODO: We should probably make a better attempt at parsing       -- comments above.  Unfortunately we can't use a full-fledged       -- Haskell parser since cabal's dependencies must be kept at a       -- minimum.@@ -233,18 +286,18 @@ darcsEnv = maybe mempty nameAndMail . lookup "DARCS_EMAIL"  gitEnv :: Enviro -> AuthorGuess-gitEnv env = (name, email)+gitEnv env = (name, mail)   where-    name  = maybeFlag "GIT_AUTHOR_NAME" env-    email = maybeFlag "GIT_AUTHOR_EMAIL" env+    name = maybeFlag "GIT_AUTHOR_NAME" env+    mail = maybeFlag "GIT_AUTHOR_EMAIL" env  darcsCfg :: Maybe String -> AuthorGuess darcsCfg = maybe mempty nameAndMail  emailEnv :: Enviro -> AuthorGuess-emailEnv env = (mempty, email)+emailEnv env = (mempty, mail)   where-    email = maybeFlag "EMAIL" env+    mail = maybeFlag "EMAIL" env  gitCfg :: GitLoc -> IO AuthorGuess gitCfg which = do@@ -272,14 +325,21 @@ maybeFlag :: String -> Enviro -> Flag String maybeFlag k = maybe mempty Flag . lookup k +-- | Read the first non-comment, non-trivial line of a file, if it exists maybeReadFile :: String -> IO (Maybe String) maybeReadFile f = do     exists <- doesFileExist f     if exists-        then fmap Just $ readFile f+        then fmap getFirstLine $ readFile f         else return Nothing+  where+    getFirstLine content =+      let nontrivialLines = dropWhile (\l -> (null l) || ("#" `isPrefixOf` l)) . lines $ content+      in case nontrivialLines of+           [] -> Nothing+           (l:_) -> Just l --- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached+-- |Get list of categories used in Hackage. NOTE: Very slow, needs to be cached knownCategories :: SourcePackageDb -> [String] knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet     [ cat | pkg <- map head (allPackagesByName sourcePkgIndex)@@ -292,17 +352,17 @@ nameAndMail str   | all isSpace nameOrEmail = mempty   | null erest = (mempty, Flag $ trim nameOrEmail)-  | otherwise  = (Flag $ trim nameOrEmail, Flag email)+  | otherwise  = (Flag $ trim nameOrEmail, Flag mail)   where     (nameOrEmail,erest) = break (== '<') str-    (email,_)           = break (== '>') (tail erest)+    (mail,_)            = break (== '>') (tail erest)  trim :: String -> String trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse   where     removeLeadingSpace  = dropWhile isSpace --- split string at given character, and remove whitespaces+-- split string at given character, and remove whitespace splitString :: Char -> String -> [String] splitString sep str = go str where     go s = if null s' then [] else tok : go rest where

cabal/cabal-install/Distribution/Client/Init/Licenses.hs view

@@ -1,17 +1,50 @@ module Distribution.Client.Init.Licenses   ( License+  , bsd2   , bsd3   , gplv2   , gplv3-  , lgpl2+  , lgpl21   , lgpl3   , agplv3   , apache20-+  , mit+  , mpl20+  , isc   ) where  type License = String +bsd2 :: String -> String -> License+bsd2 authors year = unlines+    [ "Copyright (c) " ++ year ++ ", " ++ authors+    , "All rights reserved."+    , ""+    , "Redistribution and use in source and binary forms, with or without"+    , "modification, are permitted provided that the following conditions are"+    , "met:"+    , ""+    , "1. Redistributions of source code must retain the above copyright"+    , "   notice, this list of conditions and the following disclaimer."+    , ""+    , "2. 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."+    , ""+    , "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."+    ]+ bsd3 :: String -> String -> License bsd3 authors year = unlines     [ "Copyright (c) " ++ year ++ ", " ++ authors@@ -469,7 +502,7 @@     , ""     , "  \"Copyright\" also means copyright-like laws that apply to other kinds of"     , "works, such as semiconductor masks."-    , " "+    , ""     , "  \"The Program\" refers to any copyrightable work licensed under this"     , "License.  Each licensee is addressed as \"you\".  \"Licensees\" and"     , "\"recipients\" may be individuals or organizations."@@ -902,7 +935,7 @@     , "covered work in a country, or your recipient's use of the covered work"     , "in a country, would infringe one or more identifiable patents in that"     , "country that you have reason to believe are valid."-    , "  "+    , ""     , "  If, pursuant to or in connection with a single transaction or"     , "arrangement, you convey, or propagate by procuring conveyance of, a"     , "covered work, and grant a patent license to some of the parties"@@ -1065,7 +1098,6 @@     , "the library.  If this is what you want to do, use the GNU Lesser General"     , "Public License instead of this License.  But first, please read"     , "<http://www.gnu.org/philosophy/why-not-lgpl.html>."-    , ""     ]  agplv3 :: License@@ -1733,117 +1765,130 @@     , "<http://www.gnu.org/licenses/>."     ] -lgpl2 :: License-lgpl2 = unlines-    [ "           GNU LIBRARY GENERAL PUBLIC LICENSE"-    , "                 Version 2, June 1991"+lgpl21 :: License+lgpl21 = unlines+    [ "                  GNU LESSER GENERAL PUBLIC LICENSE"+    , "                       Version 2.1, February 1999"     , ""-    , " Copyright (C) 1991 Free Software Foundation, Inc."+    , " Copyright (C) 1991, 1999 Free Software Foundation, Inc."     , " 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA"     , " Everyone is permitted to copy and distribute verbatim copies"     , " of this license document, but changing it is not allowed."     , ""-    , "[This is the first released version of the library GPL.  It is"-    , " numbered 2 because it goes with version 2 of the ordinary GPL.]"+    , "[This is the first released version of the Lesser GPL.  It also counts"+    , " as the successor of the GNU Library Public License, version 2, hence"+    , " the version number 2.1.]"     , ""-    , "                     Preamble"+    , "                            Preamble"     , ""     , "  The licenses for most software are designed to take away your"     , "freedom to share and change it.  By contrast, the GNU General Public"     , "Licenses are intended to guarantee your freedom to share and change"     , "free software--to make sure the software is free for all its users."     , ""-    , "  This license, the Library General Public License, applies to some"-    , "specially designated Free Software Foundation software, and to any"-    , "other libraries whose authors decide to use it.  You can use it for"-    , "your libraries, too."+    , "  This license, the Lesser General Public License, applies to some"+    , "specially designated software packages--typically libraries--of the"+    , "Free Software Foundation and other authors who decide to use it.  You"+    , "can use it too, but we suggest you first think carefully about whether"+    , "this license or the ordinary General Public License is the better"+    , "strategy to use in any particular case, based on the explanations below."     , ""-    , "  When we speak of free software, we are referring to freedom, not"-    , "price.  Our General Public Licenses are designed to make sure that you"-    , "have the freedom to distribute copies of free software (and charge for"-    , "this service if you wish), that you receive source code or can get it"-    , "if you want it, that you can change the software or use pieces of it"-    , "in new free programs; and that you know you can do these things."+    , "  When we speak of free software, we are referring to freedom of use,"+    , "not price.  Our General Public Licenses are designed to make sure that"+    , "you have the freedom to distribute copies of free software (and charge"+    , "for this service if you wish); that you receive source code or can get"+    , "it if you want it; that you can change the software and use pieces of"+    , "it in new free programs; and that you are informed that you can do"+    , "these things."     , ""     , "  To protect your rights, we need to make restrictions that forbid"-    , "anyone to deny you these rights or to ask you to surrender the rights."-    , "These restrictions translate to certain responsibilities for you if"-    , "you distribute copies of the library, or if you modify it."+    , "distributors to deny you these rights or to ask you to surrender these"+    , "rights.  These restrictions translate to certain responsibilities for"+    , "you if you distribute copies of the library or if you modify it."     , ""     , "  For example, if you distribute copies of the library, whether gratis"     , "or for a fee, you must give the recipients all the rights that we gave"     , "you.  You must make sure that they, too, receive or can get the source"-    , "code.  If you link a program with the library, you must provide"-    , "complete object files to the recipients so that they can relink them"-    , "with the library, after making changes to the library and recompiling"+    , "code.  If you link other code with the library, you must provide"+    , "complete object files to the recipients, so that they can relink them"+    , "with the library after making changes to the library and recompiling"     , "it.  And you must show them these terms so they know their rights."     , ""-    , "  Our method of protecting your rights has two steps: (1) copyright"-    , "the library, and (2) offer you this license which gives you legal"+    , "  We protect your rights with a two-step method: (1) we copyright the"+    , "library, and (2) we offer you this license, which gives you legal"     , "permission to copy, distribute and/or modify the library."     , ""-    , "  Also, for each distributor's protection, we want to make certain"-    , "that everyone understands that there is no warranty for this free"-    , "library.  If the library is modified by someone else and passed on, we"-    , "want its recipients to know that what they have is not the original"-    , "version, so that any problems introduced by others will not reflect on"-    , "the original authors' reputations."+    , "  To protect each distributor, we want to make it very clear that"+    , "there is no warranty for the free library.  Also, if the library is"+    , "modified by someone else and passed on, the recipients should know"+    , "that what they have is not the original version, so that the original"+    , "author's reputation will not be affected by problems that might be"+    , "introduced by others."     , ""-    , "  Finally, any free program is threatened constantly by software"-    , "patents.  We wish to avoid the danger that companies distributing free"-    , "software will individually obtain patent licenses, thus in effect"-    , "transforming the program into proprietary software.  To prevent this,"-    , "we have made it clear that any patent must be licensed for everyone's"-    , "free use or not licensed at all."+    , "  Finally, software patents pose a constant threat to the existence of"+    , "any free program.  We wish to make sure that a company cannot"+    , "effectively restrict the users of a free program by obtaining a"+    , "restrictive license from a patent holder.  Therefore, we insist that"+    , "any patent license obtained for a version of the library must be"+    , "consistent with the full freedom of use specified in this license."     , ""-    , "  Most GNU software, including some libraries, is covered by the ordinary"-    , "GNU General Public License, which was designed for utility programs.  This"-    , "license, the GNU Library General Public License, applies to certain"-    , "designated libraries.  This license is quite different from the ordinary"-    , "one; be sure to read it in full, and don't assume that anything in it is"-    , "the same as in the ordinary license."+    , "  Most GNU software, including some libraries, is covered by the"+    , "ordinary GNU General Public License.  This license, the GNU Lesser"+    , "General Public License, applies to certain designated libraries, and"+    , "is quite different from the ordinary General Public License.  We use"+    , "this license for certain libraries in order to permit linking those"+    , "libraries into non-free programs."     , ""-    , "  The reason we have a separate public license for some libraries is that"-    , "they blur the distinction we usually make between modifying or adding to a"-    , "program and simply using it.  Linking a program with a library, without"-    , "changing the library, is in some sense simply using the library, and is"-    , "analogous to running a utility program or application program.  However, in"-    , "a textual and legal sense, the linked executable is a combined work, a"-    , "derivative of the original library, and the ordinary General Public License"-    , "treats it as such."+    , "  When a program is linked with a library, whether statically or using"+    , "a shared library, the combination of the two is legally speaking a"+    , "combined work, a derivative of the original library.  The ordinary"+    , "General Public License therefore permits such linking only if the"+    , "entire combination fits its criteria of freedom.  The Lesser General"+    , "Public License permits more lax criteria for linking other code with"+    , "the library."     , ""-    , "  Because of this blurred distinction, using the ordinary General"-    , "Public License for libraries did not effectively promote software"-    , "sharing, because most developers did not use the libraries.  We"-    , "concluded that weaker conditions might promote sharing better."+    , "  We call this license the \"Lesser\" General Public License because it"+    , "does Less to protect the user's freedom than the ordinary General"+    , "Public License.  It also provides other free software developers Less"+    , "of an advantage over competing non-free programs.  These disadvantages"+    , "are the reason we use the ordinary General Public License for many"+    , "libraries.  However, the Lesser license provides advantages in certain"+    , "special circumstances."     , ""-    , "  However, unrestricted linking of non-free programs would deprive the"-    , "users of those programs of all benefit from the free status of the"-    , "libraries themselves.  This Library General Public License is intended to"-    , "permit developers of non-free programs to use free libraries, while"-    , "preserving your freedom as a user of such programs to change the free"-    , "libraries that are incorporated in them.  (We have not seen how to achieve"-    , "this as regards changes in header files, but we have achieved it as regards"-    , "changes in the actual functions of the Library.)  The hope is that this"-    , "will lead to faster development of free libraries."+    , "  For example, on rare occasions, there may be a special need to"+    , "encourage the widest possible use of a certain library, so that it becomes"+    , "a de-facto standard.  To achieve this, non-free programs must be"+    , "allowed to use the library.  A more frequent case is that a free"+    , "library does the same job as widely used non-free libraries.  In this"+    , "case, there is little to gain by limiting the free library to free"+    , "software only, so we use the Lesser General Public License."     , ""+    , "  In other cases, permission to use a particular library in non-free"+    , "programs enables a greater number of people to use a large body of"+    , "free software.  For example, permission to use the GNU C Library in"+    , "non-free programs enables many more people to use the whole GNU"+    , "operating system, as well as its variant, the GNU/Linux operating"+    , "system."+    , ""+    , "  Although the Lesser General Public License is Less protective of the"+    , "users' freedom, it does ensure that the user of a program that is"+    , "linked with the Library has the freedom and the wherewithal to run"+    , "that program using a modified version of the Library."+    , ""     , "  The precise terms and conditions for copying, distribution and"     , "modification follow.  Pay close attention to the difference between a"     , "\"work based on the library\" and a \"work that uses the library\".  The"-    , "former contains code derived from the library, while the latter only"-    , "works together with the library."-    , ""-    , "  Note that it is possible for a library to be covered by the ordinary"-    , "General Public License rather than by this special one."+    , "former contains code derived from the library, whereas the latter must"+    , "be combined with the library in order to run."     , ""-    , "              GNU LIBRARY GENERAL PUBLIC LICENSE"+    , "                  GNU LESSER GENERAL PUBLIC LICENSE"     , "   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION"     , ""-    , "  0. This License Agreement applies to any software library which"-    , "contains a notice placed by the copyright holder or other authorized"-    , "party saying it may be distributed under the terms of this Library"-    , "General Public License (also called \"this License\").  Each licensee is"-    , "addressed as \"you\"."+    , "  0. This License Agreement applies to any software library or other"+    , "program which contains a notice placed by the copyright holder or"+    , "other authorized party saying it may be distributed under the terms of"+    , "this Lesser General Public License (also called \"this License\")."+    , "Each licensee is addressed as \"you\"."     , ""     , "  A \"library\" means a collection of software functions and/or data"     , "prepared so as to be conveniently linked with application programs"@@ -1870,7 +1915,7 @@     , "on the Library (independent of the use of the Library in a tool for"     , "writing it).  Whether that is true depends on what the Library does"     , "and what the program that uses the Library does."-    , "  "+    , ""     , "  1. You may copy and distribute verbatim copies of the Library's"     , "complete source code as you receive it, in any medium, provided that"     , "you conspicuously and appropriately publish on each copy an"@@ -1992,7 +2037,7 @@     , "Any executables containing that work also fall under Section 6,"     , "whether or not they are linked directly with the Library itself."     , ""-    , "  6. As an exception to the Sections above, you may also compile or"+    , "  6. As an exception to the Sections above, you may also combine or"     , "link a \"work that uses the Library\" with the Library to produce a"     , "work containing portions of the Library, and distribute that work"     , "under terms of your choice, provided that the terms permit"@@ -2019,23 +2064,31 @@     , "    Library will not necessarily be able to recompile the application"     , "    to use the modified definitions.)"     , ""-    , "    b) Accompany the work with a written offer, valid for at"+    , "    b) Use a suitable shared library mechanism for linking with the"+    , "    Library.  A suitable mechanism is one that (1) uses at run time a"+    , "    copy of the library already present on the user's computer system,"+    , "    rather than copying library functions into the executable, and (2)"+    , "    will operate properly with a modified version of the library, if"+    , "    the user installs one, as long as the modified version is"+    , "    interface-compatible with the version that the work was made with."+    , ""+    , "    c) Accompany the work with a written offer, valid for at"     , "    least three years, to give the same user the materials"     , "    specified in Subsection 6a, above, for a charge no more"     , "    than the cost of performing this distribution."     , ""-    , "    c) If distribution of the work is made by offering access to copy"+    , "    d) If distribution of the work is made by offering access to copy"     , "    from a designated place, offer equivalent access to copy the above"     , "    specified materials from the same place."     , ""-    , "    d) Verify that the user has already received a copy of these"+    , "    e) Verify that the user has already received a copy of these"     , "    materials or that you have already sent this user a copy."     , ""     , "  For an executable, the required form of the \"work that uses the"     , "Library\" must include any data and utility programs needed for"     , "reproducing the executable from it.  However, as a special exception,"-    , "the source code distributed need not include anything that is normally"-    , "distributed (in either source or binary form) with the major"+    , "the materials to be distributed need not include anything that is"+    , "normally distributed (in either source or binary form) with the major"     , "components (compiler, kernel, and so on) of the operating system on"     , "which the executable runs, unless that component itself accompanies"     , "the executable."@@ -2084,7 +2137,7 @@     , "original licensor to copy, distribute, link with or modify the Library"     , "subject to these terms and conditions.  You may not impose any further"     , "restrictions on the recipients' exercise of the rights granted herein."-    , "You are not responsible for enforcing compliance by third parties to"+    , "You are not responsible for enforcing compliance by third parties with"     , "this License."     , ""     , "  11. If, as a consequence of a court judgment or allegation of patent"@@ -2127,7 +2180,7 @@     , "written in the body of this License."     , ""     , "  13. The Free Software Foundation may publish revised and/or new"-    , "versions of the Library General Public License from time to time."+    , "versions of the Lesser General Public License from time to time."     , "Such new versions will be similar in spirit to the present version,"     , "but may differ in detail to address new problems or concerns."     , ""@@ -2148,7 +2201,7 @@     , "of all derivatives of our free software and of promoting the sharing"     , "and reuse of software generally."     , ""-    , "                     NO WARRANTY"+    , "                            NO WARRANTY"     , ""     , "  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO"     , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW."@@ -2171,7 +2224,7 @@     , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH"     , "DAMAGES."     , ""-    , "              END OF TERMS AND CONDITIONS"+    , "                     END OF TERMS AND CONDITIONS"     , ""     , "           How to Apply These Terms to Your New Libraries"     , ""@@ -2190,17 +2243,17 @@     , "    Copyright (C) <year>  <name of author>"     , ""     , "    This library is free software; you can redistribute it and/or"-    , "    modify it under the terms of the GNU Library General Public"+    , "    modify it under the terms of the GNU Lesser General Public"     , "    License as published by the Free Software Foundation; either"-    , "    version 2 of the License, or (at your option) any later version."+    , "    version 2.1 of the License, or (at your option) any later version."     , ""     , "    This library is distributed in the hope that it will be useful,"     , "    but WITHOUT ANY WARRANTY; without even the implied warranty of"     , "    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU"-    , "    Library General Public License for more details."+    , "    Lesser General Public License for more details."     , ""-    , "    You should have received a copy of the GNU Library General Public"-    , "    License along with this library; if not, write to the Free"+    , "    You should have received a copy of the GNU Lesser General Public"+    , "    License along with this library; if not, write to the Free Software"     , "    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA"     , ""     , "Also add information on how to contact you by electronic and paper mail."@@ -2232,7 +2285,7 @@     , "the terms and conditions of version 3 of the GNU General Public"     , "License, supplemented by the additional permissions listed below."     , ""-    , "  0. Additional Definitions. "+    , "  0. Additional Definitions."     , ""     , "  As used herein, \"this License\" refers to version 3 of the GNU Lesser"     , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU"@@ -2333,7 +2386,7 @@     , "       a copy of the Library already present on the user's computer"     , "       system, and (b) will operate properly with a modified version"     , "       of the Library that is interface-compatible with the Linked"-    , "       Version. "+    , "       Version."     , ""     , "   e) Provide Installation Information, but only if you would otherwise"     , "   be required to provide such information under section 6 of the"@@ -2591,4 +2644,422 @@     , "   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied."     , "   See the License for the specific language governing permissions and"     , "   limitations under the License."+    ]++mit :: String -> String -> License+mit authors year = unlines+    [ "Copyright (c) " ++ year ++ " " ++ authors+    , ""+    , "Permission is hereby granted, free of charge, to any person obtaining"+    , "a copy of this software and associated documentation files (the"+    , "\"Software\"), to deal in the Software without restriction, including"+    , "without limitation the rights to use, copy, modify, merge, publish,"+    , "distribute, sublicense, and/or sell copies of the Software, and to"+    , "permit persons to whom the Software is furnished to do so, subject to"+    , "the following conditions:"+    , ""+    , "The above copyright notice and this permission notice shall be included"+    , "in all copies or substantial portions of the Software."+    , ""+    , "THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,"+    , "EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF"+    , "MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT."+    , "IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY"+    , "CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,"+    , "TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE"+    , "SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE."+    ]++mpl20 :: License+mpl20 = unlines+    [ "Mozilla Public License Version 2.0"+    , "=================================="+    , ""+    , "1. Definitions"+    , "--------------"+    , ""+    , "1.1. \"Contributor\""+    , "    means each individual or legal entity that creates, contributes to"+    , "    the creation of, or owns Covered Software."+    , ""+    , "1.2. \"Contributor Version\""+    , "    means the combination of the Contributions of others (if any) used"+    , "    by a Contributor and that particular Contributor's Contribution."+    , ""+    , "1.3. \"Contribution\""+    , "    means Covered Software of a particular Contributor."+    , ""+    , "1.4. \"Covered Software\""+    , "    means Source Code Form to which the initial Contributor has attached"+    , "    the notice in Exhibit A, the Executable Form of such Source Code"+    , "    Form, and Modifications of such Source Code Form, in each case"+    , "    including portions thereof."+    , ""+    , "1.5. \"Incompatible With Secondary Licenses\""+    , "    means"+    , ""+    , "    (a) that the initial Contributor has attached the notice described"+    , "        in Exhibit B to the Covered Software; or"+    , ""+    , "    (b) that the Covered Software was made available under the terms of"+    , "        version 1.1 or earlier of the License, but not also under the"+    , "        terms of a Secondary License."+    , ""+    , "1.6. \"Executable Form\""+    , "    means any form of the work other than Source Code Form."+    , ""+    , "1.7. \"Larger Work\""+    , "    means a work that combines Covered Software with other material, in"+    , "    a separate file or files, that is not Covered Software."+    , ""+    , "1.8. \"License\""+    , "    means this document."+    , ""+    , "1.9. \"Licensable\""+    , "    means having the right to grant, to the maximum extent possible,"+    , "    whether at the time of the initial grant or subsequently, any and"+    , "    all of the rights conveyed by this License."+    , ""+    , "1.10. \"Modifications\""+    , "    means any of the following:"+    , ""+    , "    (a) any file in Source Code Form that results from an addition to,"+    , "        deletion from, or modification of the contents of Covered"+    , "        Software; or"+    , ""+    , "    (b) any new file in Source Code Form that contains any Covered"+    , "        Software."+    , ""+    , "1.11. \"Patent Claims\" of a Contributor"+    , "    means any patent claim(s), including without limitation, method,"+    , "    process, and apparatus claims, in any patent Licensable by such"+    , "    Contributor that would be infringed, but for the grant of the"+    , "    License, by the making, using, selling, offering for sale, having"+    , "    made, import, or transfer of either its Contributions or its"+    , "    Contributor Version."+    , ""+    , "1.12. \"Secondary License\""+    , "    means either the GNU General Public License, Version 2.0, the GNU"+    , "    Lesser General Public License, Version 2.1, the GNU Affero General"+    , "    Public License, Version 3.0, or any later versions of those"+    , "    licenses."+    , ""+    , "1.13. \"Source Code Form\""+    , "    means the form of the work preferred for making modifications."+    , ""+    , "1.14. \"You\" (or \"Your\")"+    , "    means an individual or a legal entity exercising rights under this"+    , "    License. For legal entities, \"You\" includes any entity that"+    , "    controls, is controlled by, or is under common control with You. For"+    , "    purposes of this definition, \"control\" means (a) the power, direct"+    , "    or indirect, to cause the direction or management of such entity,"+    , "    whether by contract or otherwise, or (b) ownership of more than"+    , "    fifty percent (50%) of the outstanding shares or beneficial"+    , "    ownership of such entity."+    , ""+    , "2. License Grants and Conditions"+    , "--------------------------------"+    , ""+    , "2.1. Grants"+    , ""+    , "Each Contributor hereby grants You a world-wide, royalty-free,"+    , "non-exclusive license:"+    , ""+    , "(a) under intellectual property rights (other than patent or trademark)"+    , "    Licensable by such Contributor to use, reproduce, make available,"+    , "    modify, display, perform, distribute, and otherwise exploit its"+    , "    Contributions, either on an unmodified basis, with Modifications, or"+    , "    as part of a Larger Work; and"+    , ""+    , "(b) under Patent Claims of such Contributor to make, use, sell, offer"+    , "    for sale, have made, import, and otherwise transfer either its"+    , "    Contributions or its Contributor Version."+    , ""+    , "2.2. Effective Date"+    , ""+    , "The licenses granted in Section 2.1 with respect to any Contribution"+    , "become effective for each Contribution on the date the Contributor first"+    , "distributes such Contribution."+    , ""+    , "2.3. Limitations on Grant Scope"+    , ""+    , "The licenses granted in this Section 2 are the only rights granted under"+    , "this License. No additional rights or licenses will be implied from the"+    , "distribution or licensing of Covered Software under this License."+    , "Notwithstanding Section 2.1(b) above, no patent license is granted by a"+    , "Contributor:"+    , ""+    , "(a) for any code that a Contributor has removed from Covered Software;"+    , "    or"+    , ""+    , "(b) for infringements caused by: (i) Your and any other third party's"+    , "    modifications of Covered Software, or (ii) the combination of its"+    , "    Contributions with other software (except as part of its Contributor"+    , "    Version); or"+    , ""+    , "(c) under Patent Claims infringed by Covered Software in the absence of"+    , "    its Contributions."+    , ""+    , "This License does not grant any rights in the trademarks, service marks,"+    , "or logos of any Contributor (except as may be necessary to comply with"+    , "the notice requirements in Section 3.4)."+    , ""+    , "2.4. Subsequent Licenses"+    , ""+    , "No Contributor makes additional grants as a result of Your choice to"+    , "distribute the Covered Software under a subsequent version of this"+    , "License (see Section 10.2) or under the terms of a Secondary License (if"+    , "permitted under the terms of Section 3.3)."+    , ""+    , "2.5. Representation"+    , ""+    , "Each Contributor represents that the Contributor believes its"+    , "Contributions are its original creation(s) or it has sufficient rights"+    , "to grant the rights to its Contributions conveyed by this License."+    , ""+    , "2.6. Fair Use"+    , ""+    , "This License is not intended to limit any rights You have under"+    , "applicable copyright doctrines of fair use, fair dealing, or other"+    , "equivalents."+    , ""+    , "2.7. Conditions"+    , ""+    , "Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted"+    , "in Section 2.1."+    , ""+    , "3. Responsibilities"+    , "-------------------"+    , ""+    , "3.1. Distribution of Source Form"+    , ""+    , "All distribution of Covered Software in Source Code Form, including any"+    , "Modifications that You create or to which You contribute, must be under"+    , "the terms of this License. You must inform recipients that the Source"+    , "Code Form of the Covered Software is governed by the terms of this"+    , "License, and how they can obtain a copy of this License. You may not"+    , "attempt to alter or restrict the recipients' rights in the Source Code"+    , "Form."+    , ""+    , "3.2. Distribution of Executable Form"+    , ""+    , "If You distribute Covered Software in Executable Form then:"+    , ""+    , "(a) such Covered Software must also be made available in Source Code"+    , "    Form, as described in Section 3.1, and You must inform recipients of"+    , "    the Executable Form how they can obtain a copy of such Source Code"+    , "    Form by reasonable means in a timely manner, at a charge no more"+    , "    than the cost of distribution to the recipient; and"+    , ""+    , "(b) You may distribute such Executable Form under the terms of this"+    , "    License, or sublicense it under different terms, provided that the"+    , "    license for the Executable Form does not attempt to limit or alter"+    , "    the recipients' rights in the Source Code Form under this License."+    , ""+    , "3.3. Distribution of a Larger Work"+    , ""+    , "You may create and distribute a Larger Work under terms of Your choice,"+    , "provided that You also comply with the requirements of this License for"+    , "the Covered Software. If the Larger Work is a combination of Covered"+    , "Software with a work governed by one or more Secondary Licenses, and the"+    , "Covered Software is not Incompatible With Secondary Licenses, this"+    , "License permits You to additionally distribute such Covered Software"+    , "under the terms of such Secondary License(s), so that the recipient of"+    , "the Larger Work may, at their option, further distribute the Covered"+    , "Software under the terms of either this License or such Secondary"+    , "License(s)."+    , ""+    , "3.4. Notices"+    , ""+    , "You may not remove or alter the substance of any license notices"+    , "(including copyright notices, patent notices, disclaimers of warranty,"+    , "or limitations of liability) contained within the Source Code Form of"+    , "the Covered Software, except that You may alter any license notices to"+    , "the extent required to remedy known factual inaccuracies."+    , ""+    , "3.5. Application of Additional Terms"+    , ""+    , "You may choose to offer, and to charge a fee for, warranty, support,"+    , "indemnity or liability obligations to one or more recipients of Covered"+    , "Software. However, You may do so only on Your own behalf, and not on"+    , "behalf of any Contributor. You must make it absolutely clear that any"+    , "such warranty, support, indemnity, or liability obligation is offered by"+    , "You alone, and You hereby agree to indemnify every Contributor for any"+    , "liability incurred by such Contributor as a result of warranty, support,"+    , "indemnity or liability terms You offer. You may include additional"+    , "disclaimers of warranty and limitations of liability specific to any"+    , "jurisdiction."+    , ""+    , "4. Inability to Comply Due to Statute or Regulation"+    , "---------------------------------------------------"+    , ""+    , "If it is impossible for You to comply with any of the terms of this"+    , "License with respect to some or all of the Covered Software due to"+    , "statute, judicial order, or regulation then You must: (a) comply with"+    , "the terms of this License to the maximum extent possible; and (b)"+    , "describe the limitations and the code they affect. Such description must"+    , "be placed in a text file included with all distributions of the Covered"+    , "Software under this License. Except to the extent prohibited by statute"+    , "or regulation, such description must be sufficiently detailed for a"+    , "recipient of ordinary skill to be able to understand it."+    , ""+    , "5. Termination"+    , "--------------"+    , ""+    , "5.1. The rights granted under this License will terminate automatically"+    , "if You fail to comply with any of its terms. However, if You become"+    , "compliant, then the rights granted under this License from a particular"+    , "Contributor are reinstated (a) provisionally, unless and until such"+    , "Contributor explicitly and finally terminates Your grants, and (b) on an"+    , "ongoing basis, if such Contributor fails to notify You of the"+    , "non-compliance by some reasonable means prior to 60 days after You have"+    , "come back into compliance. Moreover, Your grants from a particular"+    , "Contributor are reinstated on an ongoing basis if such Contributor"+    , "notifies You of the non-compliance by some reasonable means, this is the"+    , "first time You have received notice of non-compliance with this License"+    , "from such Contributor, and You become compliant prior to 30 days after"+    , "Your receipt of the notice."+    , ""+    , "5.2. If You initiate litigation against any entity by asserting a patent"+    , "infringement claim (excluding declaratory judgment actions,"+    , "counter-claims, and cross-claims) alleging that a Contributor Version"+    , "directly or indirectly infringes any patent, then the rights granted to"+    , "You by any and all Contributors for the Covered Software under Section"+    , "2.1 of this License shall terminate."+    , ""+    , "5.3. In the event of termination under Sections 5.1 or 5.2 above, all"+    , "end user license agreements (excluding distributors and resellers) which"+    , "have been validly granted by You or Your distributors under this License"+    , "prior to termination shall survive termination."+    , ""+    , "************************************************************************"+    , "*                                                                      *"+    , "*  6. Disclaimer of Warranty                                           *"+    , "*  -------------------------                                           *"+    , "*                                                                      *"+    , "*  Covered Software is provided under this License on an \"as is\"       *"+    , "*  basis, without warranty of any kind, either expressed, implied, or  *"+    , "*  statutory, including, without limitation, warranties that the       *"+    , "*  Covered Software is free of defects, merchantable, fit for a        *"+    , "*  particular purpose or non-infringing. The entire risk as to the     *"+    , "*  quality and performance of the Covered Software is with You.        *"+    , "*  Should any Covered Software prove defective in any respect, You     *"+    , "*  (not any Contributor) assume the cost of any necessary servicing,   *"+    , "*  repair, or correction. This disclaimer of warranty constitutes an   *"+    , "*  essential part of this License. No use of any Covered Software is   *"+    , "*  authorized under this License except under this disclaimer.         *"+    , "*                                                                      *"+    , "************************************************************************"+    , ""+    , "************************************************************************"+    , "*                                                                      *"+    , "*  7. Limitation of Liability                                          *"+    , "*  --------------------------                                          *"+    , "*                                                                      *"+    , "*  Under no circumstances and under no legal theory, whether tort      *"+    , "*  (including negligence), contract, or otherwise, shall any           *"+    , "*  Contributor, or anyone who distributes Covered Software as          *"+    , "*  permitted above, be liable to You for any direct, indirect,         *"+    , "*  special, incidental, or consequential damages of any character      *"+    , "*  including, without limitation, damages for lost profits, loss of    *"+    , "*  goodwill, work stoppage, computer failure or malfunction, or any    *"+    , "*  and all other commercial damages or losses, even if such party      *"+    , "*  shall have been informed of the possibility of such damages. This   *"+    , "*  limitation of liability shall not apply to liability for death or   *"+    , "*  personal injury resulting from such party's negligence to the       *"+    , "*  extent applicable law prohibits such limitation. Some               *"+    , "*  jurisdictions do not allow the exclusion or limitation of           *"+    , "*  incidental or consequential damages, so this exclusion and          *"+    , "*  limitation may not apply to You.                                    *"+    , "*                                                                      *"+    , "************************************************************************"+    , ""+    , "8. Litigation"+    , "-------------"+    , ""+    , "Any litigation relating to this License may be brought only in the"+    , "courts of a jurisdiction where the defendant maintains its principal"+    , "place of business and such litigation shall be governed by laws of that"+    , "jurisdiction, without reference to its conflict-of-law provisions."+    , "Nothing in this Section shall prevent a party's ability to bring"+    , "cross-claims or counter-claims."+    , ""+    , "9. Miscellaneous"+    , "----------------"+    , ""+    , "This License represents the complete agreement concerning the subject"+    , "matter hereof. If any provision of this License is held to be"+    , "unenforceable, such provision shall be reformed only to the extent"+    , "necessary to make it enforceable. Any law or regulation which provides"+    , "that the language of a contract shall be construed against the drafter"+    , "shall not be used to construe this License against a Contributor."+    , ""+    , "10. Versions of the License"+    , "---------------------------"+    , ""+    , "10.1. New Versions"+    , ""+    , "Mozilla Foundation is the license steward. Except as provided in Section"+    , "10.3, no one other than the license steward has the right to modify or"+    , "publish new versions of this License. Each version will be given a"+    , "distinguishing version number."+    , ""+    , "10.2. Effect of New Versions"+    , ""+    , "You may distribute the Covered Software under the terms of the version"+    , "of the License under which You originally received the Covered Software,"+    , "or under the terms of any subsequent version published by the license"+    , "steward."+    , ""+    , "10.3. Modified Versions"+    , ""+    , "If you create software not governed by this License, and you want to"+    , "create a new license for such software, you may create and use a"+    , "modified version of this License if you rename the license and remove"+    , "any references to the name of the license steward (except to note that"+    , "such modified license differs from this License)."+    , ""+    , "10.4. Distributing Source Code Form that is Incompatible With Secondary"+    , "Licenses"+    , ""+    , "If You choose to distribute Source Code Form that is Incompatible With"+    , "Secondary Licenses under the terms of this version of the License, the"+    , "notice described in Exhibit B of this License must be attached."+    , ""+    , "Exhibit A - Source Code Form License Notice"+    , "-------------------------------------------"+    , ""+    , "  This Source Code Form is subject to the terms of the Mozilla Public"+    , "  License, v. 2.0. If a copy of the MPL was not distributed with this"+    , "  file, You can obtain one at http://mozilla.org/MPL/2.0/."+    , ""+    , "If it is not possible or desirable to put the notice in a particular"+    , "file, then You may include the notice in a location (such as a LICENSE"+    , "file in a relevant directory) where a recipient would be likely to look"+    , "for such a notice."+    , ""+    , "You may add additional accurate notices of copyright ownership."+    , ""+    , "Exhibit B - \"Incompatible With Secondary Licenses\" Notice"+    , "---------------------------------------------------------"+    , ""+    , "  This Source Code Form is \"Incompatible With Secondary Licenses\", as"+    , "  defined by the Mozilla Public License, v. 2.0."+    ]++isc :: String -> String -> License+isc authors year = unlines+    [ "Copyright (c) " ++ year ++ " " ++ authors+    , ""+    , "Permission to use, copy, modify, and/or distribute this software for any purpose"+    , "with or without fee is hereby granted, provided that the above copyright notice"+    , "and this permission notice appear in all copies."+    , ""+    , "THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH"+    , "REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND"+    , "FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,"+    , "INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS"+    , "OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER"+    , "TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF"+    , "THIS SOFTWARE."     ]

cabal/cabal-install/Distribution/Client/Init/Types.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Init.Types@@ -27,7 +28,9 @@ import qualified Distribution.Compat.ReadP as Parse import Distribution.Text +#if !MIN_VERSION_base(4,8,0) import Data.Monoid+#endif  -- | InitFlags is really just a simple type to represent certain --   portions of a .cabal file.  Rather than have a flag for EVERY@@ -41,7 +44,7 @@               , noComments     :: Flag Bool               , minimal        :: Flag Bool -              , packageName  :: Flag String+              , packageName  :: Flag P.PackageName               , version      :: Flag Version               , cabalVersion :: Flag VersionRange               , license      :: Flag License@@ -54,6 +57,7 @@               , extraSrc     :: Maybe [String]                , packageType  :: Flag PackageType+              , mainIs       :: Flag FilePath               , language     :: Flag Language                , exposedModules :: Maybe [ModuleName]@@ -98,6 +102,7 @@     , category       = mempty     , extraSrc       = mempty     , packageType    = mempty+    , mainIs         = mempty     , language       = mempty     , exposedModules = mempty     , otherModules   = mempty@@ -125,6 +130,7 @@     , category       = combine category     , extraSrc       = combine extraSrc     , packageType    = combine packageType+    , mainIs         = combine mainIs     , language       = combine language     , exposedModules = combine exposedModules     , otherModules   = combine otherModules

cabal/cabal-install/Distribution/Client/Install.hs view

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Install@@ -28,11 +29,13 @@     pruneInstallPlan   ) where +import Data.Foldable+         ( traverse_ ) import Data.List-         ( unfoldr, nub, sort, (\\) )+         ( isPrefixOf, unfoldr, nub, sort, (\\) ) import qualified Data.Set as S import Data.Maybe-         ( isJust, fromMaybe, maybeToList )+         ( catMaybes, isJust, isNothing, fromMaybe, mapMaybe ) import Control.Exception as Exception          ( Exception(toException), bracket, catches          , Handler(Handler), handleJust, IOException, SomeException )@@ -44,13 +47,19 @@          ( ExitCode(..) ) import Distribution.Compat.Exception          ( catchIO, catchExit )+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+         ( (<$>) )+import Data.Traversable+         ( traverse )+#endif import Control.Monad-         ( when, unless )+         ( filterM, forM_, when, unless ) import System.Directory          ( getTemporaryDirectory, doesDirectoryExist, doesFileExist,            createDirectoryIfMissing, removeFile, renameDirectory ) import System.FilePath-         ( (</>), (<.>), takeDirectory )+         ( (</>), (<.>), equalFilePath, takeDirectory ) import System.IO          ( openFile, IOMode(AppendMode), hClose ) import System.IO.Error@@ -58,11 +67,13 @@  import Distribution.Client.Targets import Distribution.Client.Configure-         ( chooseCabalVersion )+         ( chooseCabalVersion, configureSetupScript, checkConfigExFlags ) import Distribution.Client.Dependency import Distribution.Client.Dependency.Types-         ( Solver(..) )+         ( Solver(..), ConstraintSource(..), LabeledPackageConstraint(..) ) import Distribution.Client.FetchUtils+import Distribution.Client.HttpUtils+         ( configureTransport, HttpTransport (..) ) import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages )@@ -87,7 +98,7 @@          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import qualified Distribution.Client.BuildReports.Anonymous as BuildReports import qualified Distribution.Client.BuildReports.Storage as BuildReports-         ( storeAnonymous, storeLocal, fromInstallPlan )+         ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure ) import qualified Distribution.Client.InstallSymlink as InstallSymlink          ( symlinkBinaries ) import qualified Distribution.Client.PackageIndex as SourcePackageIndex@@ -96,15 +107,17 @@ import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Client.Compat.ExecutablePath import Distribution.Client.JobControl+import qualified Distribution.Client.ComponentDeps as CD +import Distribution.Utils.NubList import Distribution.Simple.Compiler          ( CompilerId(..), Compiler(compilerId), compilerFlavor-         , PackageDB(..), PackageDBStack )+         , CompilerInfo(..), compilerInfo, PackageDB(..), PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration,                                     defaultProgramConfiguration) import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Setup          ( haddockCommand, HaddockFlags(..)          , buildCommand, BuildFlags(..), emptyBuildFlags@@ -116,14 +129,16 @@          , testCommand, TestFlags(..), emptyTestFlags ) import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, rawSystemExit, comparing-         , writeFileAtomic, withTempFile , withFileContents )+         , writeFileAtomic, withTempFile , withUTF8FileContents ) import Distribution.Simple.InstallDirs as InstallDirs          ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate          , initialPathTemplateEnv, installDirsTemplateEnv ) import Distribution.Package-         ( PackageIdentifier, PackageId, packageName, packageVersion-         , Package(..), PackageFixedDeps(..)-         , Dependency(..), thisPackageVersion, InstalledPackageId )+         ( PackageIdentifier(..), PackageId, packageName, packageVersion+         , Package(..), LibraryName+         , Dependency(..), thisPackageVersion+         , InstalledPackageId, installedPackageId+         , HasInstalledPackageId(..) ) import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription          ( PackageDescription, GenericPackageDescription(..), Flag(..)@@ -133,7 +148,7 @@ import Distribution.ParseUtils          ( showPWarning ) import Distribution.Version-         ( Version )+         ( Version, VersionRange, foldVersionRange ) import Distribution.Simple.Utils as Utils          ( notice, info, warn, debug, debugNoWrap, die          , intercalate, withTempDirectory )@@ -187,10 +202,15 @@   userTargets0 = do      installContext <- makeInstallContext verbosity args (Just userTargets0)-    installPlan    <- foldProgress logMsg die' return =<<+    planResult     <- foldProgress logMsg (return . Left) (return . Right) =<<                       makeInstallPlan verbosity args installContext -    processInstallPlan verbosity args installContext installPlan+    case planResult of+        Left message -> do+            reportPlanningFailure verbosity args installContext message+            die' message+        Right installPlan ->+            processInstallPlan verbosity args installContext installPlan   where     args :: InstallArgs     args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo,@@ -207,12 +227,13 @@       ++ "recreating the sandbox."     logMsg message rest = debugNoWrap verbosity message >> rest --- TODO: Make InstallContext a proper datatype with documented fields.+-- TODO: Make InstallContext a proper data type with documented fields. -- | Common context for makeInstallPlan and processInstallPlan.-type InstallContext = ( PackageIndex, SourcePackageDb-                      , [UserTarget], [PackageSpecifier SourcePackage] )+type InstallContext = ( InstalledPackageIndex, SourcePackageDb+                      , [UserTarget], [PackageSpecifier SourcePackage]+                      , HttpTransport ) --- TODO: Make InstallArgs a proper datatype with documented fields or just get+-- TODO: Make InstallArgs a proper data type with documented fields or just get -- rid of it completely. -- | Initial arguments given to 'install' or 'makeInstallContext'. type InstallArgs = ( PackageDBStack@@ -233,10 +254,14 @@                       -> IO InstallContext makeInstallContext verbosity   (packageDBs, repos, comp, _, conf,_,_,-   globalFlags, _, _, _, _) mUserTargets = do+   globalFlags, _, configExFlags, _, _) mUserTargets = do      installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf     sourcePkgDb       <- getSourcePackages    verbosity repos+    checkConfigExFlags verbosity installedPkgIndex+                       (packageIndex sourcePkgDb) configExFlags+    transport <- configureTransport verbosity+                 (flagToMaybe (globalHttpTransport globalFlags))      (userTargets, pkgSpecifiers) <- case mUserTargets of       Nothing           ->@@ -250,13 +275,14 @@         let userTargets | null userTargets0 = [UserTargetLocalDir "."]                         | otherwise         = userTargets0 -        pkgSpecifiers <- resolveUserTargets verbosity+        pkgSpecifiers <- resolveUserTargets verbosity transport                          (fromFlag $ globalWorldFile globalFlags)                          (packageIndex sourcePkgDb)                          userTargets         return (userTargets, pkgSpecifiers) -    return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers)+    return (installedPkgIndex, sourcePkgDb, userTargets+           ,pkgSpecifiers, transport)  -- | Make an install plan given install context and install arguments. makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext@@ -266,10 +292,10 @@    _, configFlags, configExFlags, installFlags,    _)   (installedPkgIndex, sourcePkgDb,-   _, pkgSpecifiers) = do+   _, pkgSpecifiers, _) = do      solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))-              (compilerId comp)+              (compilerInfo comp)     notice verbosity "Resolving dependencies..."     return $ planPackages comp platform mSandboxPkgInfo solver       configFlags configExFlags installFlags@@ -282,16 +308,17 @@ processInstallPlan verbosity   args@(_,_, _, _, _, _, _, _, _, _, installFlags, _)   (installedPkgIndex, sourcePkgDb,-   userTargets, pkgSpecifiers) installPlan = do+   userTargets, pkgSpecifiers, _) installPlan = do     checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb       installFlags pkgSpecifiers -    unless dryRun $ do+    unless (dryRun || nothingToInstall) $ do       installPlan' <- performInstallations verbosity                       args installedPkgIndex installPlan       postInstallActions verbosity args userTargets installPlan'   where     dryRun = fromFlag (installDryRun installFlags)+    nothingToInstall = null (InstallPlan.ready installPlan)  -- ------------------------------------------------------------ -- * Installation planning@@ -304,7 +331,7 @@              -> ConfigFlags              -> ConfigExFlags              -> InstallFlags-             -> PackageIndex+             -> InstalledPackageIndex              -> SourcePackageDb              -> [PackageSpecifier SourcePackage]              -> Progress String String InstallPlan@@ -313,7 +340,7 @@              installedPkgIndex sourcePkgDb pkgSpecifiers =          resolveDependencies-          platform (compilerId comp)+          platform (compilerInfo comp)           solver           resolverParams @@ -333,6 +360,8 @@        . setShadowPkgs shadowPkgs +      . setStrongFlags strongFlags+       . setPreferenceDefault (if upgradeDeps then PreferAllLatest                                              else PreferLatestForSelected) @@ -345,18 +374,23 @@        . addConstraints           -- version constraints from the config file or command line-            (map userToPackageConstraint (configExConstraints configExFlags))+            [ LabeledPackageConstraint (userToPackageConstraint pc) src+            | (pc, src) <- configExConstraints configExFlags ]        . addConstraints           --FIXME: this just applies all flags to all targets which           -- is silly. We should check if the flags are appropriate-          [ PackageConstraintFlags (pkgSpecifierTarget pkgSpecifier) flags+          [ let pc = PackageConstraintFlags+                     (pkgSpecifierTarget pkgSpecifier) flags+            in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget           | let flags = configConfigurationsFlags configFlags           , not (null flags)           , pkgSpecifier <- pkgSpecifiers ]        . addConstraints-          [ PackageConstraintStanzas (pkgSpecifierTarget pkgSpecifier) stanzas+          [ let pc = PackageConstraintStanzas+                     (pkgSpecifierTarget pkgSpecifier) stanzas+            in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget           | pkgSpecifier <- pkgSpecifiers ]        . maybe id applySandboxInstallPolicy mSandboxPkgInfo@@ -378,14 +412,17 @@     independentGoals = fromFlag (installIndependentGoals installFlags)     avoidReinstalls  = fromFlag (installAvoidReinstalls  installFlags)     shadowPkgs       = fromFlag (installShadowPkgs       installFlags)+    strongFlags      = fromFlag (installStrongFlags      installFlags)     maxBackjumps     = fromFlag (installMaxBackjumps     installFlags)     upgradeDeps      = fromFlag (installUpgradeDeps      installFlags)     onlyDeps         = fromFlag (installOnlyDeps         installFlags)     allowNewer       = fromFlag (configAllowNewer        configExFlags)  -- | Remove the provided targets from the install plan.-pruneInstallPlan :: Package pkg => [PackageSpecifier pkg] -> InstallPlan-                    -> Progress String String InstallPlan+pruneInstallPlan :: Package targetpkg+                 => [PackageSpecifier targetpkg]+                 -> InstallPlan+                 -> Progress String String InstallPlan 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@@ -393,7 +430,7 @@   either (Fail . explain) Done   . InstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)   where-    explain :: [InstallPlan.PlanProblem] -> String+    explain :: [InstallPlan.PlanProblem ipkg srcpkg iresult ifailure] -> String     explain problems =       "Cannot select only the dependencies (as requested by the "       ++ "'--only-dependencies' flag), "@@ -418,7 +455,7 @@ -- | Perform post-solver checks of the install plan and print it if -- either requested or needed. checkPrintPlan :: Verbosity-               -> PackageIndex+               -> InstalledPackageIndex                -> InstallPlan                -> SourcePackageDb                -> InstallFlags@@ -481,19 +518,37 @@           : map (display . Installed.sourcePackageId) newBrokenPkgs           ++ if overrideReinstall                then if dryRun then [] else-                 ["Continuing even though the plan contains dangerous reinstalls."]+                 ["Continuing even though " +++                  "the plan contains dangerous reinstalls."]                else                  ["Use --force-reinstalls if you want to install anyway."]       else unless dryRun $ warn verbosity              "Note that reinstalls are always dangerous. Continuing anyway..." +  -- If we are explicitly told to not download anything, check that all packages+  -- are already fetched.+  let offline = fromFlagOrDefault False (installOfflineMode installFlags)+  when offline $ do+    let pkgs = [ sourcePkg+               | InstallPlan.Configured (ConfiguredPackage sourcePkg _ _ _)+                 <- InstallPlan.toList installPlan ]+    notFetched <- fmap (map packageInfoId)+                  . filterM (fmap isNothing . checkFetched . packageSource)+                  $ pkgs+    unless (null notFetched) $+      die $ "Can't download packages in offline mode. "+      ++ "Must download the following packages to proceed:\n"+      ++ intercalate ", " (map display notFetched)+      ++ "\nTry using 'cabal fetch'."+   where     nothingToInstall = null (InstallPlan.ready installPlan)      dryRun            = fromFlag (installDryRun            installFlags)     overrideReinstall = fromFlag (installOverrideReinstall installFlags) -linearizeInstallPlan :: PackageIndex+--TODO: this type is too specific+linearizeInstallPlan :: InstalledPackageIndex                      -> InstallPlan                      -> [(ReadyPackage, PackageStatus)] linearizeInstallPlan installedPkgIndex plan =@@ -503,15 +558,19 @@       []      -> Nothing       (pkg:_) -> Just ((pkg, status), plan'')         where-          pkgid  = packageId pkg+          pkgid  = installedPackageId pkg           status = packageStatus installedPkgIndex pkg-          plan'' = InstallPlan.completed pkgid-                     (BuildOk DocsNotTried TestsNotTried-                              (Just $ Installed.emptyInstalledPackageInfo-                              { Installed.sourcePackageId = pkgid }))+          ipkg   = Installed.emptyInstalledPackageInfo {+                     Installed.sourcePackageId    = packageId pkg,+                     Installed.installedPackageId = 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...  data PackageStatus = NewPackage                    | NewVersion [Version]@@ -523,12 +582,14 @@ extractReinstalls (Reinstall ipids _) = ipids extractReinstalls _                   = [] -packageStatus :: PackageIndex -> ReadyPackage -> PackageStatus+packageStatus :: InstalledPackageIndex+              -> ReadyPackage+              -> PackageStatus packageStatus installedPkgIndex cpkg =   case PackageIndex.lookupPackageName installedPkgIndex                                       (packageName cpkg) of     [] -> NewPackage-    ps ->  case filter ((==packageId cpkg)+    ps ->  case filter ((== packageId cpkg)                         . Installed.sourcePackageId) (concatMap snd ps) of       []           -> NewVersion (map fst ps)       pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs)@@ -539,18 +600,22 @@     changes :: Installed.InstalledPackageInfo             -> ReadyPackage             -> [MergeResult PackageIdentifier PackageIdentifier]-    changes pkg pkg' =-      filter changed-      $ mergeBy (comparing packageName)-        -- get dependencies of installed package (convert to source pkg ids via-        -- index)-        (nub . sort . concatMap-         (maybeToList . fmap Installed.sourcePackageId .-          PackageIndex.lookupInstalledPackageId installedPkgIndex) .-         Installed.depends $ pkg)-        -- get dependencies of configured package-        (nub . sort . depends $ pkg')+    changes pkg pkg' = filter changed $+      mergeBy (comparing packageName)+        -- deps of installed pkg+        (resolveInstalledIds $ Installed.depends pkg)+        -- deps of configured pkg+        (resolveInstalledIds $ CD.nonSetupDeps (depends pkg')) +    -- convert to source pkg ids via index+    resolveInstalledIds :: [InstalledPackageId] -> [PackageIdentifier]+    resolveInstalledIds =+        nub+      . sort+      . map Installed.sourcePackageId+      . catMaybes+      . map (PackageIndex.lookupInstalledPackageId installedPkgIndex)+     changed (InBoth    pkgid pkgid') = pkgid /= pkgid'     changed _                        = True @@ -576,7 +641,7 @@     showPkg (pkg, _) = display (packageId pkg) ++                        showLatest (pkg) -    showPkgAndReason (pkg', pr) = display (packageId pkg') +++    showPkgAndReason (ReadyPackage pkg' _, pr) = display (packageId pkg') ++           showLatest pkg' ++           showFlagAssignment (nonDefaultFlags pkg') ++           showStanzas (stanzas pkg') ++ " " ++@@ -587,15 +652,14 @@                 []   -> ""                 diff -> " changes: "  ++ intercalate ", " (map change diff) -    showLatest :: ReadyPackage -> String+    showLatest :: Package srcpkg => srcpkg -> String     showLatest pkg = case mLatestVersion of         Just latestVersion ->-            if pkgVersion < latestVersion+            if packageVersion pkg < latestVersion             then (" (latest: " ++ display latestVersion ++ ")")             else ""         Nothing -> ""       where-        pkgVersion    = packageVersion pkg         mLatestVersion :: Maybe Version         mLatestVersion = case SourcePackageIndex.lookupPackageName                                 (packageIndex sourcePkgDb)@@ -606,15 +670,15 @@     toFlagAssignment :: [Flag] -> FlagAssignment     toFlagAssignment = map (\ f -> (flagName f, flagDefault f)) -    nonDefaultFlags :: ReadyPackage -> FlagAssignment-    nonDefaultFlags (ReadyPackage spkg fa _ _) =+    nonDefaultFlags :: ConfiguredPackage -> FlagAssignment+    nonDefaultFlags (ConfiguredPackage spkg fa _ _) =       let defaultAssignment =             toFlagAssignment              (genPackageFlags (Source.packageDescription spkg))       in  fa \\ defaultAssignment -    stanzas :: ReadyPackage -> [OptionalStanza]-    stanzas (ReadyPackage _ _ sts _) = sts+    stanzas :: ConfiguredPackage -> [OptionalStanza]+    stanzas (ConfiguredPackage _ _ sts _) = sts      showStanzas :: [OptionalStanza] -> String     showStanzas = concatMap ((' ' :) . showStanza)@@ -637,6 +701,75 @@ -- * Post installation stuff -- ------------------------------------------------------------ +-- | Report a solver failure. This works slightly differently to+-- 'postInstallActions', as (by definition) we don't have an install plan.+reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String+                      -> IO ()+reportPlanningFailure verbosity+  (_, _, comp, platform, _, _, _+  ,_, configFlags, _, installFlags, _)+  (_, sourcePkgDb, _, pkgSpecifiers, _)+  message = do++  when reportFailure $ do++    -- Only create reports for explicitly named packages+    let pkgids = filter+          (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $+          mapMaybe theSpecifiedPackage pkgSpecifiers++        buildReports = BuildReports.fromPlanningFailure platform+                       (compilerId comp) pkgids+                       (configConfigurationsFlags configFlags)++    when (not (null buildReports)) $+      info verbosity $+        "Solver failure will be reported for "+        ++ intercalate "," (map display pkgids)++    -- Save reports+    BuildReports.storeLocal (compilerInfo comp)+                            (fromNubList $ installSummaryFile installFlags)+                            buildReports platform++    -- Save solver log+    case logFile of+      Nothing -> return ()+      Just template -> forM_ pkgids $ \pkgid ->+        let env = initialPathTemplateEnv pkgid dummyLibraryName+                    (compilerInfo comp) platform+            path = fromPathTemplate $ substPathTemplate env template+        in  writeFile path message++  where+    reportFailure = fromFlag (installReportPlanningFailure installFlags)+    logFile = flagToMaybe (installLogFile installFlags)++    -- A LibraryName is calculated from the transitive closure of+    -- dependencies, but when the solver fails we don't have that.+    -- So we fail.+    dummyLibraryName = error "reportPlanningFailure: library name not available"++-- | If a 'PackageSpecifier' refers to a single package, return Just that+-- package.+theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId+theSpecifiedPackage pkgSpec =+  case pkgSpec of+    NamedPackage name [PackageConstraintVersion name' version]+      | name == name' -> PackageIdentifier name <$> trivialRange version+    NamedPackage _ _ -> Nothing+    SpecificSourcePackage pkg -> Just $ packageId pkg+  where+    -- | If a range includes only a single version, return Just that version.+    trivialRange :: VersionRange -> Maybe Version+    trivialRange = foldVersionRange+        Nothing+        Just     -- "== v"+        (\_ -> Nothing)+        (\_ -> Nothing)+        (\_ _ -> Nothing)+        (\_ _ -> Nothing)+ -- | Various stuff we do after successful or unsuccessfully installing a bunch -- of packages. This includes: --@@ -662,18 +795,21 @@       [ World.WorldPkgInfo dep []       | UserTargetNamed dep <- targets ] -  let buildReports = BuildReports.fromInstallPlan installPlan-  BuildReports.storeLocal (installSummaryFile installFlags) buildReports-    (InstallPlan.planPlatform installPlan)+  let buildReports = BuildReports.fromInstallPlan platform (compilerId comp)+                                                  installPlan+  BuildReports.storeLocal (compilerInfo comp)+                          (fromNubList $ installSummaryFile installFlags)+                          buildReports+                          platform   when (reportingLevel >= AnonymousReports) $     BuildReports.storeAnonymous buildReports   when (reportingLevel == DetailedReports) $     storeDetailedBuildReports verbosity logsDir buildReports -  regenerateHaddockIndex verbosity packageDBs comp platform conf+  regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox                          configFlags installFlags installPlan -  symlinkBinaries verbosity configFlags installFlags installPlan+  symlinkBinaries verbosity platform comp configFlags installFlags installPlan    printBuildFailures installPlan @@ -687,7 +823,7 @@     worldFile      = fromFlag $ globalWorldFile globalFlags  storeDetailedBuildReports :: Verbosity -> FilePath-                          -> [(BuildReports.BuildReport, Repo)] -> IO ()+                          -> [(BuildReports.BuildReport, Maybe Repo)] -> IO () storeDetailedBuildReports verbosity logsDir reports = sequence_   [ do dotCabal <- defaultCabalDir        let logFileName = display (BuildReports.package report) <.> "log"@@ -700,7 +836,7 @@          createDirectoryIfMissing True reportsDir -- FIXME          writeFile reportFile (show (BuildReports.show report, buildLog)) -  | (report, Repo { repoKind = Left remoteRepo }) <- reports+  | (report, Just Repo { repoKind = Left remoteRepo }) <- reports   , isLikelyToHaveLogFile (BuildReports.installOutcome report) ]    where@@ -724,11 +860,12 @@                        -> Compiler                        -> Platform                        -> ProgramConfiguration+                       -> UseSandbox                        -> ConfigFlags                        -> InstallFlags                        -> InstallPlan                        -> IO ()-regenerateHaddockIndex verbosity packageDBs comp platform conf+regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox                        configFlags installFlags installPlan   | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do @@ -753,17 +890,18 @@       && isJust (flagToMaybe (installHaddockIndex installFlags))      -- We want to regenerate the index if some new documentation was actually-    -- installed. Since the index is per-user, we don't do it for global-    -- installs or special cases where we're installing into a specific db.-    shouldRegenerateHaddockIndex = normalUserInstall+    -- installed. Since the index can be only per-user or per-sandbox (see+    -- #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       where         someDocsWereInstalled = any installedDocs . InstallPlan.toList         normalUserInstall     = (UserPackageDB `elem` packageDBs)                              && all (not . isSpecificPackageDB) packageDBs -        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _ _)) = True-        installedDocs _                                            = False+        installedDocs (InstallPlan.Installed _ _ (BuildOk DocsOk _ _)) = True+        installedDocs _                                                = False         isSpecificPackageDB (SpecificPackageDB _) = True         isSpecificPackageDB _                     = False @@ -771,8 +909,9 @@                                           . substPathTemplate env       where         env  = env0 ++ installDirsTemplateEnv absoluteDirs-        env0 = InstallDirs.compilerTemplateEnv (compilerId comp)+        env0 = InstallDirs.compilerTemplateEnv (compilerInfo comp)             ++ InstallDirs.platformTemplateEnv platform+            ++ InstallDirs.abiTemplateEnv (compilerInfo comp) platform         absoluteDirs = InstallDirs.substituteInstallDirTemplates                          env0 templateDirs         templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault@@ -780,11 +919,15 @@   symlinkBinaries :: Verbosity+                -> Platform -> Compiler                 -> ConfigFlags                 -> InstallFlags-                -> InstallPlan -> IO ()-symlinkBinaries verbosity configFlags installFlags plan = do-  failed <- InstallSymlink.symlinkBinaries configFlags installFlags plan+                -> InstallPlan+                -> IO ()+symlinkBinaries verbosity platform comp configFlags installFlags plan = do+  failed <- InstallSymlink.symlinkBinaries platform comp+                                           configFlags installFlags+                                           plan   case failed of     [] -> return ()     [(_, exe, path)] ->@@ -806,7 +949,8 @@     bindir = fromFlag (installSymlinkBinDir installFlags)  -printBuildFailures :: InstallPlan -> IO ()+printBuildFailures :: InstallPlan+                   -> IO () printBuildFailures plan =   case [ (pkg, reason)        | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of@@ -832,12 +976,16 @@       InstallFailed   e -> " failed during the final install step."                         ++ showException e +      -- This will never happen, but we include it for completeness+      PlanningFailed -> " failed during the planning phase."+     showException e   =  " The exception was:\n  " ++ show e ++ maybeOOM e #ifdef mingw32_HOST_OS     maybeOOM _        = "" #else     maybeOOM e                    = maybe "" onExitFailure (fromException e)-    onExitFailure (ExitFailure 9) =+    onExitFailure (ExitFailure n)+      | n == 9 || n == -9         =       "\nThis may be due to an out-of-memory condition."     onExitFailure _               = "" #endif@@ -846,15 +994,17 @@ -- | If we're working inside a sandbox and some add-source deps were installed, -- update the timestamps of those deps. updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo-                            -> Compiler -> Platform -> InstallPlan+                            -> Compiler -> Platform+                            -> InstallPlan                             -> IO () updateSandboxTimestampsFile (UseSandbox sandboxDir)                             (Just (SandboxPackageInfo _ _ _ allAddSourceDeps))                             comp platform installPlan =   withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do-    let allInstalled = [ pkg | InstallPlan.Installed pkg _+    let allInstalled = [ pkg | InstallPlan.Installed pkg _ _                             <- InstallPlan.toList installPlan ]-        allSrcPkgs   = [ pkg | ReadyPackage pkg _ _ _ <- allInstalled ]+        allSrcPkgs   = [ pkg | ReadyPackage (ConfiguredPackage pkg _ _ _) _+                            <- allInstalled ]         allPaths     = [ pth | LocalUnpackedPackage pth                             <- map packageSource allSrcPkgs]     allPathsCanonical <- mapM tryCanonicalizePath allPaths@@ -873,15 +1023,15 @@  -- | If logging is enabled, contains location of the log file and the verbosity -- level for logging.-type UseLogFile = Maybe (PackageIdentifier -> FilePath, Verbosity)+type UseLogFile = Maybe (PackageIdentifier -> LibraryName -> FilePath, Verbosity)  performInstallations :: Verbosity                      -> InstallArgs-                     -> PackageIndex+                     -> InstalledPackageIndex                      -> InstallPlan                      -> IO InstallPlan performInstallations verbosity-  (packageDBs, _, comp, _, conf, useSandbox, _,+  (packageDBs, _, comp, platform, conf, useSandbox, _,    globalFlags, configFlags, configExFlags, installFlags, haddockFlags)   installedPkgIndex installPlan = do @@ -898,20 +1048,26 @@   installLock  <- newLock -- serialise installation   cacheLock    <- newLock -- serialise access to setup exe cache -  executeInstallPlan verbosity jobControl useLogFile installPlan $ \rpkg ->-    installReadyPackage platform compid configFlags+  transport <- configureTransport verbosity+               (flagToMaybe (globalHttpTransport globalFlags))++  executeInstallPlan verbosity comp jobControl useLogFile installPlan $ \rpkg ->+    -- Calculate the package key (ToDo: Is this right for source install)+    let libname = readyLibraryName comp rpkg in+    installReadyPackage platform cinfo configFlags                         rpkg $ \configFlags' src pkg pkgoverride ->-      fetchSourcePackage verbosity fetchLimit src $ \src' ->+      fetchSourcePackage transport verbosity fetchLimit src $ \src' ->         installLocalPackage verbosity buildLimit                             (packageId pkg) src' distPref $ \mpath ->-          installUnpackedPackage verbosity buildLimit installLock numJobs-                                 (setupScriptOptions installedPkgIndex cacheLock)-                                 miscOptions configFlags' installFlags haddockFlags-                                 compid platform pkg pkgoverride mpath useLogFile+          installUnpackedPackage verbosity buildLimit installLock numJobs libname+                                 (setupScriptOptions installedPkgIndex+                                  cacheLock rpkg)+                                 miscOptions configFlags'+                                 installFlags haddockFlags+                                 cinfo platform pkg pkgoverride mpath useLogFile    where-    platform = InstallPlan.planPlatform installPlan-    compid   = InstallPlan.planCompiler installPlan+    cinfo = compilerInfo comp      numJobs         = determineNumJobs (installNumJobs installFlags)     numFetchJobs    = 2@@ -919,30 +1075,19 @@     distPref        = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)                       (configDistPref configFlags) -    setupScriptOptions index lock = SetupScriptOptions {-      useCabalVersion  = chooseCabalVersion configExFlags-                         (libVersion miscOptions),-      useCompiler      = Just comp,-      usePlatform      = Just platform,-      -- Hack: we typically want to allow the UserPackageDB for finding the-      -- Cabal lib when compiling any Setup.hs even if we're doing a global-      -- install. However we also allow looking in a specific package db.-      usePackageDB     = if UserPackageDB `elem` packageDBs-                           then packageDBs-                           else let (db@GlobalPackageDB:dbs) = packageDBs-                                 in db : UserPackageDB : dbs,-                                --TODO: use Ord instance:-                                -- insert UserPackageDB packageDBs-      usePackageIndex  = if UserPackageDB `elem` packageDBs-                           then Just index-                           else Nothing,-      useProgramConfig = conf,-      useDistPref      = distPref,-      useLoggingHandle = Nothing,-      useWorkingDir    = Nothing,-      forceExternalSetupMethod = parallelInstall,-      setupCacheLock   = Just lock-    }+    setupScriptOptions index lock rpkg =+      configureSetupScript+        packageDBs+        comp+        platform+        conf+        distPref+        (chooseCabalVersion configExFlags (libVersion miscOptions))+        (Just lock)+        parallelInstall+        index+        (Just rpkg)+     reportingLevel = fromFlag (installBuildReports installFlags)     logsDir        = fromFlag (globalLogsDir globalFlags) @@ -983,12 +1128,13 @@           | parallelInstall                   = False           | otherwise                         = False -    substLogFileName :: PathTemplate -> PackageIdentifier -> FilePath-    substLogFileName template pkg = fromPathTemplate-                                  . substPathTemplate env-                                  $ template-      where env = initialPathTemplateEnv (packageId pkg)-                  (compilerId comp) platform+    substLogFileName :: PathTemplate -> PackageIdentifier -> LibraryName+                     -> FilePath+    substLogFileName template pkg libname = fromPathTemplate+                                          . substPathTemplate env+                                          $ template+      where env = initialPathTemplateEnv (packageId pkg) libname+                  (compilerInfo comp) platform      miscOptions  = InstallMisc {       rootCmd    = if fromFlag (configUserInstall configFlags)@@ -1001,12 +1147,13 @@   executeInstallPlan :: Verbosity-                   -> JobControl IO (PackageId, BuildResult)+                   -> Compiler+                   -> JobControl IO (PackageId, LibraryName, BuildResult)                    -> UseLogFile                    -> InstallPlan                    -> (ReadyPackage -> IO BuildResult)                    -> IO InstallPlan-executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg =+executeInstallPlan verbosity comp jobCtl useLogFile plan0 installPkg =     tryNewTasks 0 plan0   where     tryNewTasks taskCount plan = do@@ -1018,9 +1165,10 @@             [ do info verbosity $ "Ready to install " ++ display pkgid                  spawnJob jobCtl $ do                    buildResult <- installPkg pkg-                   return (packageId pkg, buildResult)+                   return (packageId pkg, libname, buildResult)             | pkg <- pkgs-            , let pkgid = packageId pkg]+            , let pkgid = packageId pkg+                  libname = readyLibraryName comp pkg ]            let taskCount' = taskCount + length pkgs               plan'      = InstallPlan.processing pkgs plan@@ -1028,18 +1176,21 @@      waitForTasks taskCount plan = do       info verbosity $ "Waiting for install task to finish..."-      (pkgid, buildResult) <- collectJob jobCtl-      printBuildResult pkgid buildResult+      (pkgid, libname, buildResult) <- collectJob jobCtl+      printBuildResult pkgid libname buildResult       let taskCount' = taskCount-1           plan'      = updatePlan pkgid buildResult plan       tryNewTasks taskCount' plan' -    updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan -> InstallPlan-    updatePlan pkgid (Right buildSuccess) =-      InstallPlan.completed pkgid buildSuccess+    updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan+               -> InstallPlan+    updatePlan pkgid (Right buildSuccess@(BuildOk _ _ mipkg)) =+        InstallPlan.completed (Source.fakeInstalledPackageId pkgid)+                              mipkg buildSuccess      updatePlan pkgid (Left buildFailure) =-      InstallPlan.failed    pkgid buildFailure depsFailure+        InstallPlan.failed (Source.fakeInstalledPackageId pkgid)+                           buildFailure depsFailure       where         depsFailure = DependentFailed pkgid         -- So this first pkgid failed for whatever reason (buildFailure).@@ -1047,10 +1198,10 @@         -- now cannot build, we mark as failing due to 'DependentFailed'         -- which kind of means it was not their fault. -    -- Print last 10 lines of the build log if something went wrong, and-    -- 'Installed $PKGID' otherwise.-    printBuildResult :: PackageId -> BuildResult -> IO ()-    printBuildResult pkgid buildResult = case buildResult of+    -- Print build log if something went wrong, and 'Installed $PKGID'+    -- otherwise.+    printBuildResult :: PackageId -> LibraryName -> BuildResult -> IO ()+    printBuildResult pkgid libname buildResult = case buildResult of         (Right _) -> notice verbosity $ "Installed " ++ display pkgid         (Left _)  -> do           notice verbosity $ "Failed to install " ++ display pkgid@@ -1058,18 +1209,12 @@             case useLogFile of               Nothing                 -> return ()               Just (mkLogFileName, _) -> do-                let logName = mkLogFileName pkgid-                    n       = 10-                putStr $ "Last " ++ (show n)-                  ++ " lines of the build log ( " ++ logName ++ " ):\n"-                printLastNLines logName n+                let logName = mkLogFileName pkgid libname+                putStr $ "Build log ( " ++ logName ++ " ):\n"+                printFile logName -    printLastNLines :: FilePath -> Int -> IO ()-    printLastNLines path n = do-      lns <- fmap lines $ readFile path-      let len = length lns-      let toDrop = if (len > n && n > 0) then (len - n) else 0-      mapM_ putStrLn (drop toDrop lns)+    printFile :: FilePath -> IO ()+    printFile path = readFile path >>= putStr  -- | Call an installer for an 'SourcePackage' but override the configure -- flags with the ones given by the 'ReadyPackage'. In particular the@@ -1079,26 +1224,30 @@ -- -- NB: when updating this function, don't forget to also update -- 'configurePackage' in D.C.Configure.-installReadyPackage :: Platform -> CompilerId-                       -> ConfigFlags-                       -> ReadyPackage-                       -> (ConfigFlags -> PackageLocation (Maybe FilePath)-                                       -> PackageDescription-                                       -> PackageDescriptionOverride -> a)-                       -> a-installReadyPackage platform comp configFlags-  (ReadyPackage (SourcePackage _ gpkg source pkgoverride)-   flags stanzas deps)-  installPkg = installPkg configFlags {+installReadyPackage :: Platform -> CompilerInfo+                    -> ConfigFlags+                    -> ReadyPackage+                    -> (ConfigFlags -> PackageLocation (Maybe FilePath)+                                    -> PackageDescription+                                    -> PackageDescriptionOverride+                                    -> a)+                    -> a+installReadyPackage platform cinfo configFlags+                    (ReadyPackage (ConfiguredPackage+                                    (SourcePackage _ gpkg source pkgoverride)+                                    flags stanzas _)+                                   deps)+                    installPkg =+  installPkg configFlags {     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 (packageId deppkg)-                         | deppkg <- deps ],+                         | deppkg <- CD.nonSetupDeps deps ],     configDependencies = [ (packageName (Installed.sourcePackageId deppkg),                             Installed.installedPackageId deppkg)-                         | deppkg <- deps ],+                         | deppkg <- CD.nonSetupDeps deps ],     -- Use '--exact-configuration' if supported.     configExactConfiguration = toFlag True,     configBenchmarks         = toFlag False,@@ -1107,23 +1256,24 @@   where     pkg = case finalizePackageDescription flags            (const True)-           platform comp [] (enableStanzas stanzas gpkg) of+           platform cinfo [] (enableStanzas stanzas gpkg) of       Left _ -> error "finalizePackageDescription ReadyPackage failed"       Right (desc, _) -> desc  fetchSourcePackage-  :: Verbosity+  :: HttpTransport+  -> Verbosity   -> JobLimit   -> PackageLocation (Maybe FilePath)   -> (PackageLocation FilePath -> IO BuildResult)   -> IO BuildResult-fetchSourcePackage verbosity fetchLimit src installPkg = do+fetchSourcePackage transport verbosity fetchLimit src installPkg = do   fetched <- checkFetched src   case fetched of     Just src' -> installPkg src'     Nothing   -> onFailure DownloadFailed $ do                    loc <- withJobLimit fetchLimit $-                            fetchPackage verbosity src+                            fetchPackage transport verbosity src                    installPkg loc  @@ -1162,7 +1312,7 @@ installLocalTarballPackage verbosity jobLimit pkgid                            tarballPath distPref installPkg = do   tmp <- getTemporaryDirectory-  withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->+  withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath ->     onFailure UnpackFailed $ do       let relUnpackedPath = display pkgid           absUnpackedPath = tmpDirPath </> relUnpackedPath@@ -1180,9 +1330,10 @@       installPkg (Just absUnpackedPath)    where-    -- 'cabal sdist' puts pre-generated files in the 'dist' directory. This-    -- fails when we use a nonstandard build directory name (as is the case-    -- with sandboxes), so we need to rename the 'dist' dir here.+    -- 'cabal sdist' puts pre-generated files in the 'dist'+    -- directory. This fails when a nonstandard build directory name+    -- is used (as is the case with sandboxes), so we need to rename+    -- the 'dist' dir here.     --     -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still     -- fails even with this workaround. We probably can live with that.@@ -1192,13 +1343,16 @@           distDirPathTmp = absUnpackedPath </> (defaultDistPref ++ "-tmp")           distDirPathNew = absUnpackedPath </> distPref       distDirExists <- doesDirectoryExist distDirPath-      when distDirExists $ do+      when (distDirExists+            && (not $ distDirPath `equalFilePath` distDirPathNew)) $ do         -- NB: we need to handle the case when 'distDirPathNew' is a-        -- subdirectory of 'distDirPath' (e.g. 'dist/dist-sandbox-3688fbc2').+        -- subdirectory of 'distDirPath' (e.g. the former is+        -- 'dist/dist-sandbox-3688fbc2' and the latter is 'dist').         debug verbosity $ "Renaming '" ++ distDirPath ++ "' to '"           ++ distDirPathTmp ++ "'."         renameDirectory distDirPath distDirPathTmp-        createDirectoryIfMissingVerbose verbosity False distDirPath+        when (distDirPath `isPrefixOf` distDirPathNew) $+          createDirectoryIfMissingVerbose verbosity False distDirPath         debug verbosity $ "Renaming '" ++ distDirPathTmp ++ "' to '"           ++ distDirPathNew ++ "'."         renameDirectory distDirPathTmp distDirPathNew@@ -1208,22 +1362,23 @@   -> JobLimit   -> Lock   -> Int+  -> LibraryName   -> SetupScriptOptions   -> InstallMisc   -> ConfigFlags   -> InstallFlags   -> HaddockFlags-  -> CompilerId+  -> CompilerInfo   -> Platform   -> PackageDescription   -> 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+installUnpackedPackage verbosity buildLimit installLock numJobs libname                        scriptOptions miscOptions-                       configFlags installConfigFlags haddockFlags-                       compid platform pkg pkgoverride workingDir useLogFile = do+                       configFlags installFlags haddockFlags+                       cinfo platform pkg pkgoverride workingDir useLogFile = do    -- Override the .cabal file if necessary   case pkgoverride of@@ -1282,7 +1437,8 @@           maybePkgConf <- maybeGenPkgConf mLogPath            -- Actual installation-          withWin32SelfUpgrade verbosity configFlags compid platform pkg $ do+          withWin32SelfUpgrade verbosity libname configFlags+                               cinfo platform pkg $ do             case rootCmd miscOptions of               (Just cmd) -> reexec cmd               Nothing    -> do@@ -1298,12 +1454,13 @@       buildDistPref  = configDistPref configFlags,       buildVerbosity = toFlag verbosity'     }-    shouldHaddock    = fromFlag (installDocumentation installConfigFlags)+    shouldHaddock    = fromFlag (installDocumentation installFlags)     haddockFlags' _   = haddockFlags {       haddockVerbosity = toFlag verbosity',       haddockDistPref  = configDistPref configFlags     }     testsEnabled = fromFlag (configTests configFlags)+                   && fromFlagOrDefault False (installRunTests installFlags)     testFlags _ = Cabal.emptyTestFlags {       Cabal.testDistPref = configDistPref configFlags     }@@ -1330,8 +1487,8 @@                               defInstallDirs (configInstallDirs configFlags)           }         where-          CompilerId flavor _ = compid-          env         = initialPathTemplateEnv pkgid compid platform+          CompilerId flavor _ = compilerInfoId cinfo+          env         = initialPathTemplateEnv pkgid libname cinfo platform           userInstall = fromFlagOrDefault defaultUserInstall                         (configUserInstall configFlags') @@ -1346,7 +1503,7 @@                 Cabal.regGenPkgConf = toFlag (Just pkgConfFile)               }           setup Cabal.registerCommand registerFlags' mLogPath-          withFileContents pkgConfFile $ \pkgConfText ->+          withUTF8FileContents pkgConfFile $ \pkgConfText ->             case Installed.parseInstalledPackageInfo pkgConfText of               Installed.ParseFailed perror    -> pkgConfParseFailed perror               Installed.ParseOk warns pkgConf -> do@@ -1365,7 +1522,7 @@       case useLogFile of          Nothing                 -> return Nothing          Just (mkLogFileName, _) -> do-           let logFileName = mkLogFileName (packageId pkg)+           let logFileName = mkLogFileName (packageId pkg) libname                logDir      = takeDirectory logFileName            unless (null logDir) $ createDirectoryIfMissing True logDir            logFileExists <- doesFileExist logFileName@@ -1374,9 +1531,8 @@      setup cmd flags mLogPath =       Exception.bracket-      (maybe (return Nothing)-             (\path -> Just `fmap` openFile path AppendMode) mLogPath)-      (maybe (return ()) hClose)+      (traverse (\path -> openFile path AppendMode) mLogPath)+      (traverse_ hClose)       (\logFileHandle ->         setupWrapper verbosity           scriptOptions { useLoggingHandle = logFileHandle@@ -1386,7 +1542,7 @@      reexec cmd = do       -- look for our own executable file and re-exec ourselves using a helper-      -- program like sudo to elevate priviledges:+      -- program like sudo to elevate privileges:       self <- getExecutablePath       weExist <- doesFileExist self       if weExist@@ -1410,17 +1566,18 @@   -- --------------------------------------------------------------- * Wierd windows hacks+-- * Weird windows hacks -- ------------------------------------------------------------  withWin32SelfUpgrade :: Verbosity+                     -> LibraryName                      -> ConfigFlags-                     -> CompilerId+                     -> CompilerInfo                      -> Platform                      -> PackageDescription                      -> IO a -> IO a-withWin32SelfUpgrade _ _ _ _ _ action | buildOS /= Windows = action-withWin32SelfUpgrade verbosity configFlags compid platform pkg action = do+withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action+withWin32SelfUpgrade verbosity libname configFlags cinfo platform pkg action = do    defaultDirs <- InstallDirs.defaultInstallDirs                    compFlavor@@ -1432,7 +1589,7 @@    where     pkgid = packageId pkg-    (CompilerId compFlavor _) = compid+    (CompilerId compFlavor _) = compilerInfoId cinfo      exeInstallPaths defaultDirs =       [ InstallDirs.bindir absoluteDirs </> exeName <.> exeExtension@@ -1448,8 +1605,10 @@         templateDirs   = InstallDirs.combineInstallDirs fromFlagOrDefault                            defaultDirs (configInstallDirs configFlags)         absoluteDirs   = InstallDirs.absoluteInstallDirs-                           pkgid compid InstallDirs.NoCopyDest+                           pkgid libname+                           cinfo InstallDirs.NoCopyDest                            platform templateDirs         substTemplate  = InstallDirs.fromPathTemplate                        . InstallDirs.substPathTemplate env-          where env = InstallDirs.initialPathTemplateEnv pkgid compid platform+          where env = InstallDirs.initialPathTemplateEnv pkgid libname+                      cinfo platform

cabal/cabal-install/Distribution/Client/InstallPlan.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.InstallPlan@@ -13,8 +14,9 @@ ----------------------------------------------------------------------------- module Distribution.Client.InstallPlan (   InstallPlan,-  ConfiguredPackage(..),-  PlanPackage(..),+  GenericInstallPlan,+  PlanPackage,+  GenericPlanPackage(..),    -- * Operations on 'InstallPlan's   new,@@ -24,68 +26,59 @@   completed,   failed,   remove,--  -- ** Query functions-  planPlatform,-  planCompiler,+  showPlanIndex,+  showInstallPlan,    -- * Checking validity of plans   valid,   closed,   consistent,   acyclic,-  configuredPackageValid,    -- ** Details on invalid plans   PlanProblem(..),   showPlanProblem,-  PackageProblem(..),-  showPackageProblem,   problems,-  configuredPackageProblems++  -- ** Querying the install plan+  dependencyClosure,   ) where -import Distribution.Client.Types-         ( SourcePackage(packageDescription), ConfiguredPackage(..)-         , ReadyPackage(..), readyPackageToConfiguredPackage-         , InstalledPackage, BuildFailure, BuildSuccess(..), enableStanzas-         , InstalledPackage (..) )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo ) import Distribution.Package-         ( PackageIdentifier(..), PackageName(..), Package(..), packageName-         , PackageFixedDeps(..), Dependency(..) )+         ( PackageIdentifier(..), PackageName(..), Package(..)+         , InstalledPackageId, HasInstalledPackageId(..) )+import Distribution.Client.Types+         ( BuildSuccess, BuildFailure+         , PackageFixedDeps(..), ConfiguredPackage+         , GenericReadyPackage(..), fakeInstalledPackageId ) import Distribution.Version-         ( Version, withinRange )-import Distribution.PackageDescription-         ( GenericPackageDescription(genPackageFlags)-         , Flag(flagName), FlagName(..) )-import Distribution.Client.PackageUtils-         ( externalBuildDepends )-import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )-import Distribution.Client.PackageIndex+         ( Version )+import Distribution.Client.ComponentDeps (ComponentDeps)+import qualified Distribution.Client.ComponentDeps as CD+import Distribution.Simple.PackageIndex          ( PackageIndex )-import qualified Distribution.Client.PackageIndex as 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 Distribution.System-         ( Platform )-import Distribution.Compiler-         ( CompilerId(..) )-import Distribution.Client.Utils-         ( duplicates, duplicatesBy, mergeBy, MergeResult(..) )-import Distribution.Simple.Utils-         ( comparing, intercalate )-import qualified Distribution.InstalledPackageInfo as Installed  import Data.List-         ( sort, sortBy )+         ( intercalate ) import Data.Maybe          ( fromMaybe, maybeToList ) import qualified Data.Graph as Graph import Data.Graph (Graph) import Control.Exception          ( assert )+import Data.Maybe (catMaybes)+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. --@@ -128,66 +121,146 @@ -- have problems with inconsistent dependencies. -- On the other hand it is true that every closed sub plan is valid. -data PlanPackage = PreExisting InstalledPackage-                 | Configured  ConfiguredPackage-                 | Processing  ReadyPackage-                 | Installed   ReadyPackage BuildSuccess-                 | Failed      ConfiguredPackage BuildFailure-                   -- ^ NB: packages in the Failed state can be *either* Ready-                   -- or Configured.+-- | 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 ipkg)+   | Installed   (GenericReadyPackage srcpkg ipkg) (Maybe ipkg) iresult+   | Failed      srcpkg ifailure -instance Package PlanPackage where-  packageId (PreExisting pkg) = packageId pkg-  packageId (Configured  pkg) = packageId pkg-  packageId (Processing pkg)  = packageId pkg-  packageId (Installed pkg _) = packageId pkg-  packageId (Failed    pkg _) = packageId pkg+type PlanPackage = GenericPlanPackage+                   InstalledPackageInfo ConfiguredPackage+                   BuildSuccess BuildFailure -instance PackageFixedDeps PlanPackage 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 (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 -data InstallPlan = InstallPlan {-    planIndex    :: PackageIndex PlanPackage,-    planGraph    :: Graph,-    planGraphRev :: Graph,-    planPkgOf    :: Graph.Vertex -> PlanPackage,-    planVertexOf :: PackageIdentifier -> Graph.Vertex,-    planPlatform :: Platform,-    planCompiler :: CompilerId+instance (PackageFixedDeps srcpkg,+          PackageFixedDeps ipkg, HasInstalledPackageId 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 (HasInstalledPackageId ipkg, HasInstalledPackageId srcpkg) =>+         HasInstalledPackageId+         (GenericPlanPackage ipkg srcpkg iresult ifailure) where+  installedPackageId (PreExisting ipkg ) = installedPackageId ipkg+  installedPackageId (Configured  spkg)  = installedPackageId spkg+  installedPackageId (Processing  rpkg)  = installedPackageId rpkg+  -- NB: defer to the actual installed package info in this case+  installedPackageId (Installed _ (Just ipkg) _) = installedPackageId ipkg+  installedPackageId (Installed rpkg _        _) = installedPackageId rpkg+  installedPackageId (Failed      spkg        _) = installedPackageId spkg+++data GenericInstallPlan ipkg srcpkg iresult ifailure = GenericInstallPlan {+    planIndex      :: (PlanIndex ipkg srcpkg iresult ifailure),+    planFakeMap    :: FakeMap,+    planGraph      :: Graph,+    planGraphRev   :: Graph,+    planPkgOf      :: Graph.Vertex+                      -> GenericPlanPackage ipkg srcpkg iresult ifailure,+    planVertexOf   :: InstalledPackageId -> Graph.Vertex,+    planIndepGoals :: Bool   } -invariant :: InstallPlan -> Bool+-- | 'GenericInstallPlan' specialised to most commonly used types.+type InstallPlan = GenericInstallPlan+                   InstalledPackageInfo ConfiguredPackage+                   BuildSuccess BuildFailure++type PlanIndex ipkg srcpkg iresult ifailure =+     PackageIndex (GenericPlanPackage ipkg srcpkg iresult ifailure)++invariant :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,+              HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)+          => GenericInstallPlan ipkg srcpkg iresult ifailure -> Bool invariant plan =-  valid (planPlatform plan) (planCompiler plan) (planIndex plan)+    valid (planFakeMap plan)+          (planIndepGoals plan)+          (planIndex plan)  internalError :: String -> a internalError msg = error $ "InstallPlan: internal error: " ++ msg +showPlanIndex :: (HasInstalledPackageId ipkg, HasInstalledPackageId 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 (installedPackageId p) ++ ")"++showInstallPlan :: (HasInstalledPackageId ipkg, HasInstalledPackageId 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 :: Platform -> CompilerId -> PackageIndex PlanPackage-    -> Either [PlanProblem] InstallPlan-new platform compiler index =-  case problems platform compiler index of-    [] -> Right InstallPlan {-            planIndex    = index,-            planGraph    = graph,-            planGraphRev = Graph.transposeG graph,-            planPkgOf    = vertexToPkgId,-            planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex,-            planPlatform = platform,-            planCompiler = compiler+new :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,+        HasInstalledPackageId 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 -> (fakeInstalledPackageId (packageId p)+                           ,installedPackageId p))+              . filter isPreExisting+              $ PackageIndex.allPackages index in+  case problems fakeMap indepGoals index of+    [] -> Right GenericInstallPlan {+            planIndex      = index,+            planFakeMap    = fakeMap,+            planGraph      = graph,+            planGraphRev   = Graph.transposeG graph,+            planPkgOf      = vertexToPkgId,+            planVertexOf   = fromMaybe noSuchPkgId . pkgIdToVertex,+            planIndepGoals = indepGoals           }       where (graph, vertexToPkgId, pkgIdToVertex) =-              PackageIndex.dependencyGraph index+              PlanIndex.dependencyGraph fakeMap index             noSuchPkgId = internalError "package is not in the graph"     probs -> Left probs -toList :: InstallPlan -> [PlanPackage]+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@@ -196,11 +269,14 @@ -- the dependencies of a package or set of packages without actually -- installing the package itself, as when doing development. ---remove :: (PlanPackage -> Bool)-       -> InstallPlan-       -> Either [PlanProblem] InstallPlan+remove :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,+           HasInstalledPackageId 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 (planPlatform plan) (planCompiler plan) newIndex+    new (planIndepGoals plan) newIndex   where     newIndex = PackageIndex.fromList $                  filter (not . shouldRemove) (toList plan)@@ -209,7 +285,9 @@ -- configured state and have all their dependencies installed already. -- The plan is complete if the result is @[]@. ---ready :: InstallPlan -> [ReadyPackage]+ready :: forall ipkg srcpkg iresult ifailure. PackageFixedDeps srcpkg+      => GenericInstallPlan ipkg srcpkg iresult ifailure+      -> [GenericReadyPackage srcpkg ipkg] ready plan = assert check readyPackages   where     check = if null readyPackages && null processingPackages@@ -218,27 +296,31 @@     configuredPackages = [ pkg | Configured pkg <- toList plan ]     processingPackages = [ pkg | Processing pkg <- toList plan] -    readyPackages :: [ReadyPackage]+    readyPackages :: [GenericReadyPackage srcpkg ipkg]     readyPackages =-      [ ReadyPackage srcPkg flags stanzas deps-      | pkg@(ConfiguredPackage srcPkg flags stanzas _) <- configuredPackages+      [ ReadyPackage srcpkg deps+      | srcpkg <- configuredPackages         -- select only the package that have all of their deps installed:-      , deps <- maybeToList (hasAllInstalledDeps pkg)+      , deps <- maybeToList (hasAllInstalledDeps srcpkg)       ] -    hasAllInstalledDeps :: ConfiguredPackage -> Maybe [Installed.InstalledPackageInfo]-    hasAllInstalledDeps = mapM isInstalledDep . depends+    hasAllInstalledDeps :: srcpkg -> Maybe (ComponentDeps [ipkg])+    hasAllInstalledDeps = T.mapM (mapM isInstalledDep) . depends -    isInstalledDep :: PackageIdentifier -> Maybe Installed.InstalledPackageInfo+    isInstalledDep :: InstalledPackageId -> Maybe ipkg     isInstalledDep pkgid =-      case PackageIndex.lookupPackageId (planIndex plan) pkgid of-        Just (Configured  _)                            -> Nothing-        Just (Processing  _)                            -> Nothing-        Just (Failed    _ _)                            -> internalError depOnFailed-        Just (PreExisting (InstalledPackage instPkg _)) -> Just instPkg-        Just (Installed _ (BuildOk _ _ (Just instPkg))) -> Just instPkg-        Just (Installed _ (BuildOk _ _ Nothing))        -> internalError depOnNonLib-        Nothing                                         -> internalError incomplete+      -- 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.fakeLookupInstalledPackageId+           (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"@@ -247,7 +329,11 @@ -- -- * The package must exist in the graph and be in the configured state. ---processing :: [ReadyPackage] -> InstallPlan -> InstallPlan+processing :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,+               HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)+           => [GenericReadyPackage srcpkg ipkg]+           -> GenericInstallPlan ipkg srcpkg iresult ifailure+           -> GenericInstallPlan ipkg srcpkg iresult ifailure processing pkgs plan = assert (invariant plan') plan'   where     plan' = plan {@@ -261,15 +347,28 @@ -- * The package must exist in the graph and be in the processing state. -- * The package must have had no uninstalled dependent packages. ---completed :: PackageIdentifier-          -> BuildSuccess-          -> InstallPlan -> InstallPlan-completed pkgid buildResult plan = assert (invariant plan') plan'+completed :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,+              HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)+          => InstalledPackageId+          -> 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 {-                  planIndex = PackageIndex.insert installed (planIndex 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.deleteInstalledPackageId pkgid+                            $ planIndex plan                 }-    installed = Installed (lookupProcessingPackage plan pkgid) buildResult+    -- ...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 (installedPackageId 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.@@ -277,51 +376,62 @@ -- * The package must exist in the graph and be in the processing -- state. ---failed :: PackageIdentifier -- ^ The id of the package that failed to install-       -> BuildFailure      -- ^ The build result to use for the failed package-       -> BuildFailure      -- ^ The build result to use for its dependencies-       -> InstallPlan-       -> InstallPlan+failed :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,+           HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)+       => InstalledPackageId -- ^ 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                }-    pkg      = lookupProcessingPackage plan pkgid+    ReadyPackage srcpkg _deps = lookupProcessingPackage plan pkgid     failures = PackageIndex.fromList-             $ Failed (readyPackageToConfiguredPackage pkg) buildResult+             $ Failed srcpkg buildResult              : [ Failed pkg' buildResult'                | Just pkg' <- map checkConfiguredPackage                             $ packagesThatDependOn plan pkgid ]  -- | Lookup the reachable packages in the reverse dependency graph. ---packagesThatDependOn :: InstallPlan-                     -> PackageIdentifier -> [PlanPackage]-packagesThatDependOn plan = map (planPkgOf plan)+packagesThatDependOn :: GenericInstallPlan ipkg srcpkg iresult ifailure+                     -> InstalledPackageId+                     -> [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 :: InstallPlan-                        -> PackageIdentifier -> ReadyPackage+lookupProcessingPackage :: GenericInstallPlan ipkg srcpkg iresult ifailure+                        -> InstalledPackageId+                        -> GenericReadyPackage srcpkg ipkg lookupProcessingPackage plan pkgid =-  case PackageIndex.lookupPackageId (planIndex plan) pkgid of+  -- NB: processing packages are guaranteed to not indirect through+  -- planFakeMap+  case PackageIndex.lookupInstalledPackageId (planIndex plan) pkgid of     Just (Processing pkg) -> pkg-    _  -> internalError $ "not in processing state or no such pkg " ++ display pkgid+    _  -> 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 :: PlanPackage -> Maybe ConfiguredPackage+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)  -- --------------------------------------------------------------- * Checking valididy of plans+-- * Checking validity of plans -- ------------------------------------------------------------  -- | A valid installation plan is a set of packages that is 'acyclic',@@ -330,23 +440,24 @@ -- -- * if the result is @False@ use 'problems' to get a detailed list. ---valid :: Platform -> CompilerId -> PackageIndex PlanPackage -> Bool-valid platform comp index = null (problems platform comp index)+valid :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,+          HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)+      => FakeMap -> Bool+      -> PlanIndex ipkg srcpkg iresult ifailure+      -> Bool+valid fakeMap indepGoals index =+    null $ problems fakeMap indepGoals index -data PlanProblem =-     PackageInvalid       ConfiguredPackage [PackageProblem]-   | PackageMissingDeps   PlanPackage [PackageIdentifier]-   | PackageCycle         [PlanPackage]+data PlanProblem ipkg srcpkg iresult ifailure =+     PackageMissingDeps   (GenericPlanPackage ipkg srcpkg iresult ifailure)+                          [PackageIdentifier]+   | PackageCycle         [GenericPlanPackage ipkg srcpkg iresult ifailure]    | PackageInconsistency PackageName [(PackageIdentifier, Version)]-   | PackageStateInvalid  PlanPackage PlanPackage--showPlanProblem :: PlanProblem -> String-showPlanProblem (PackageInvalid pkg packageProblems) =-     "Package " ++ display (packageId pkg)-  ++ " has an invalid configuration, in particular:\n"-  ++ unlines [ "  " ++ showPackageProblem problem-             | problem <- packageProblems ]+   | 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: "@@ -371,36 +482,41 @@   ++ " which is in the " ++ showPlanState pkg'   ++ " state"   where-    showPlanState (PreExisting _) = "pre-existing"-    showPlanState (Configured  _) = "configured"-    showPlanState (Processing _)  = "processing"-    showPlanState (Installed _ _) = "installed"-    showPlanState (Failed    _ _) = "failed"+    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 :: Platform -> CompilerId-         -> PackageIndex PlanPackage -> [PlanProblem]-problems platform comp index =-     [ PackageInvalid pkg packageProblems-     | Configured pkg <- PackageIndex.allPackages index-     , let packageProblems = configuredPackageProblems platform comp pkg-     , not (null packageProblems) ]+problems :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,+             HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)+         => FakeMap -> Bool+         -> PlanIndex ipkg srcpkg iresult ifailure+         -> [PlanProblem ipkg srcpkg iresult ifailure]+problems fakeMap indepGoals index = -  ++ [ PackageMissingDeps pkg missingDeps-     | (pkg, missingDeps) <- PackageIndex.brokenPackages index ]+     [ PackageMissingDeps pkg+       (catMaybes+        (map+         (fmap packageId . PlanIndex.fakeLookupInstalledPackageId fakeMap index)+         missingDeps))+     | (pkg, missingDeps) <- PlanIndex.brokenPackages fakeMap index ]    ++ [ PackageCycle cycleGroup-     | cycleGroup <- PackageIndex.dependencyCycles index ]+     | cycleGroup <- PlanIndex.dependencyCycles fakeMap index ]    ++ [ PackageInconsistency name inconsistencies-     | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies index ]+     | (name, inconsistencies) <-+       PlanIndex.dependencyInconsistencies fakeMap indepGoals index ]    ++ [ PackageStateInvalid pkg pkg'      | pkg <- PackageIndex.allPackages index-     , Just pkg' <- map (PackageIndex.lookupPackageId index) (depends pkg)+     , Just pkg' <- map (PlanIndex.fakeLookupInstalledPackageId fakeMap index)+                    (CD.nonSetupDeps (depends pkg))      , not (stateDependencyRelation pkg pkg') ]  -- | The graph of packages (nodes) and dependencies (edges) must be acyclic.@@ -408,8 +524,10 @@ -- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out --   which packages are involved in dependency cycles. ---acyclic :: PackageIndex PlanPackage -> Bool-acyclic = null . PackageIndex.dependencyCycles+acyclic :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,+            HasInstalledPackageId 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@@ -418,8 +536,10 @@ -- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out --   which packages depend on packages not in the index. ---closed :: PackageIndex PlanPackage -> Bool-closed = null . PackageIndex.brokenPackages+closed :: (HasInstalledPackageId ipkg, 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.@@ -428,128 +548,68 @@ -- 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+-- 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 aproximation of that.+-- current definition is just a safe approximation of that. -- -- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to --   find out which packages are. ---consistent :: PackageIndex PlanPackage -> Bool-consistent = null . PackageIndex.dependencyInconsistencies+consistent :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,+               HasInstalledPackageId 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 :: PlanPackage -> PlanPackage -> Bool-stateDependencyRelation (PreExisting _) (PreExisting _) = 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 (Configured  _) (PreExisting _)   = True+stateDependencyRelation (Configured  _) (Configured  _)   = True+stateDependencyRelation (Configured  _) (Processing  _)   = True+stateDependencyRelation (Configured  _) (Installed _ _ _) = True -stateDependencyRelation (Processing  _) (PreExisting _) = True-stateDependencyRelation (Processing  _) (Installed _ _) = True+stateDependencyRelation (Processing  _) (PreExisting _)   = True+stateDependencyRelation (Processing  _) (Installed _ _ _) = True -stateDependencyRelation (Installed _ _) (PreExisting _) = True-stateDependencyRelation (Installed _ _) (Installed _ _) = True+stateDependencyRelation (Installed _ _ _) (PreExisting _)   = True+stateDependencyRelation (Installed _ _ _) (Installed _ _ _) = True -stateDependencyRelation (Failed    _ _) (PreExisting _) = 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 (Failed    _ _) (Configured  _)   = True+stateDependencyRelation (Failed    _ _) (Processing  _)   = True+stateDependencyRelation (Failed    _ _) (Installed _ _ _) = True+stateDependencyRelation (Failed    _ _) (Failed    _   _) = True -stateDependencyRelation _               _               = False+stateDependencyRelation _               _                 = False --- | A 'ConfiguredPackage' is valid if the flag assignment is total and if--- in the configuration given by the flag assignment, all the package--- dependencies are satisfied by the specified packages.----configuredPackageValid :: Platform -> CompilerId -> ConfiguredPackage -> Bool-configuredPackageValid platform comp pkg =-  null (configuredPackageProblems platform comp pkg) -data PackageProblem = DuplicateFlag FlagName-                    | MissingFlag   FlagName-                    | ExtraFlag     FlagName-                    | DuplicateDeps [PackageIdentifier]-                    | MissingDep    Dependency-                    | ExtraDep      PackageIdentifier-                    | InvalidDep    Dependency PackageIdentifier--showPackageProblem :: PackageProblem -> String-showPackageProblem (DuplicateFlag (FlagName flag)) =-  "duplicate flag in the flag assignment: " ++ flag--showPackageProblem (MissingFlag (FlagName flag)) =-  "missing an assignment for the flag: " ++ flag--showPackageProblem (ExtraFlag (FlagName flag)) =-  "extra flag given that is not used by the package: " ++ flag--showPackageProblem (DuplicateDeps pkgids) =-     "duplicate packages specified as selected dependencies: "-  ++ intercalate ", " (map display pkgids)--showPackageProblem (MissingDep dep) =-     "the package has a dependency " ++ display dep-  ++ " but no package has been selected to satisfy it."--showPackageProblem (ExtraDep pkgid) =-     "the package configuration specifies " ++ display pkgid-  ++ " but (with the given flag assignment) the package does not actually"-  ++ " depend on any version of that package."--showPackageProblem (InvalidDep dep pkgid) =-     "the package depends on " ++ display dep-  ++ " but the configuration specifies " ++ display pkgid-  ++ " which does not satisfy the dependency."--configuredPackageProblems :: Platform -> CompilerId-                          -> ConfiguredPackage -> [PackageProblem]-configuredPackageProblems platform comp-  (ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps) =-     [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]-  ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]-  ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]-  ++ [ DuplicateDeps pkgs-     | pkgs <- duplicatesBy (comparing packageName) specifiedDeps ]-  ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]-  ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]-  ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps-                            , not (packageSatisfiesDependency pkgid dep) ]+-- | Compute the dependency closure of a _source_ package in a install plan+--+-- See `Distribution.Client.PlanIndex.dependencyClosure`+dependencyClosure :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,+                      HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)+                  => GenericInstallPlan ipkg srcpkg iresult ifailure+                  -> [PackageIdentifier]+                  -> Either [(GenericPlanPackage ipkg srcpkg iresult ifailure,+                              [InstalledPackageId])]+                            (PackageIndex+                             (GenericPlanPackage ipkg srcpkg iresult ifailure))+dependencyClosure installPlan pids =+    PlanIndex.dependencyClosure+      (planFakeMap installPlan)+      (planIndex installPlan)+      (map (resolveFakeId . fakeInstalledPackageId) pids)   where-    mergedFlags = mergeBy compare-      (sort $ map flagName (genPackageFlags (packageDescription pkg)))-      (sort $ map fst specifiedFlags)--    mergedDeps = mergeBy-      (\dep pkgid -> dependencyName dep `compare` packageName pkgid)-      (sortBy (comparing dependencyName) requiredDeps)-      (sortBy (comparing packageName)    specifiedDeps)--    packageSatisfiesDependency-      (PackageIdentifier name  version)-      (Dependency        name' versionRange) = assert (name == name') $-        version `withinRange` versionRange--    dependencyName (Dependency name _) = name--    requiredDeps :: [Dependency]-    requiredDeps =-      --TODO: use something lower level than finalizePackageDescription-      case finalizePackageDescription specifiedFlags-         (const True)-         platform comp-         []-         (enableStanzas stanzas $ packageDescription pkg) of-        Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg-        Left  _ -> error "configuredPackageInvalidDeps internal error"+    resolveFakeId :: InstalledPackageId -> InstalledPackageId+    resolveFakeId ipid = Map.findWithDefault ipid ipid (planFakeMap installPlan)

cabal/cabal-install/Distribution/Client/InstallSymlink.hs view

@@ -16,18 +16,21 @@     symlinkBinary,   ) where -#if mingw32_HOST_OS || mingw32_TARGET_OS+#if mingw32_HOST_OS  import Distribution.Package (PackageIdentifier) import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Setup (InstallFlags) import Distribution.Simple.Setup (ConfigFlags)+import Distribution.Simple.Compiler+import Distribution.System -symlinkBinaries :: ConfigFlags+symlinkBinaries :: Platform -> Compiler+                -> ConfigFlags                 -> InstallFlags-                -> InstallPlan+                -> InstallPlan                  -> IO [(PackageIdentifier, String, FilePath)]-symlinkBinaries _ _ _ = return []+symlinkBinaries _ _ _ _ _ = return []  symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"@@ -35,17 +38,21 @@ #else  import Distribution.Client.Types-         ( SourcePackage(..), ReadyPackage(..), enableStanzas )+         ( SourcePackage(..)+         , GenericReadyPackage(..), ReadyPackage, enableStanzas+         , ConfiguredPackage(..) ) import Distribution.Client.Setup          ( InstallFlags(installSymlinkBinDir) ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan)  import Distribution.Package-         ( PackageIdentifier, Package(packageId) )+         ( PackageIdentifier, Package(packageId), mkPackageKey+         , packageKeyLibraryName, LibraryName ) import Distribution.Compiler          ( CompilerId(..) ) import qualified Distribution.PackageDescription as PackageDescription+import qualified Distribution.Client.ComponentDeps as CD import Distribution.PackageDescription          ( PackageDescription ) import Distribution.PackageDescription.Configuration@@ -53,6 +60,11 @@ import Distribution.Simple.Setup          ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.InstallDirs as InstallDirs+import qualified Distribution.InstalledPackageInfo as Installed+import Distribution.Simple.Compiler+         ( Compiler, compilerInfo, CompilerInfo(..), packageKeySupported )+import Distribution.System+         ( Platform )  import System.Posix.Files          ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink@@ -77,25 +89,26 @@ -- directory will be on the user's PATH. However some people are a bit nervous -- about letting a package manager install programs into @~/bin/@. ----- A comprimise solution is that instead of installing binaries directly into+-- A compromise solution is that instead of installing binaries directly into -- @~/bin/@, we could install them in a private location under @~/.cabal/bin@ -- and then create symlinks in @~/bin/@. We can be careful when setting up the -- symlinks that we do not overwrite any binary that the user installed. We can -- check if it was a symlink we made because it would point to the private dir -- where we install our binaries. This means we can install normally without -- worrying and in a later phase set up symlinks, and if that fails then we--- report it to the user, but even in this case the package is still in an ok+-- report it to the user, but even in this case the package is still in an OK -- installed state. -- -- This is an optional feature that users can choose to use or not. It is--- controlled from the config file. Of course it only works on posix systems+-- controlled from the config file. Of course it only works on POSIX systems -- with symlinks so is not available to Windows users. ---symlinkBinaries :: ConfigFlags+symlinkBinaries :: Platform -> Compiler+                -> ConfigFlags                 -> InstallFlags                 -> InstallPlan                 -> IO [(PackageIdentifier, String, FilePath)]-symlinkBinaries configFlags installFlags plan =+symlinkBinaries platform comp configFlags installFlags plan =   case flagToMaybe (installSymlinkBinDir installFlags) of     Nothing            -> return []     Just symlinkBinDir@@ -105,7 +118,7 @@ --    TODO: do we want to do this here? : --      createDirectoryIfMissing True publicBinDir       fmap catMaybes $ sequence-        [ do privateBinDir <- pkgBinDir pkg+        [ do privateBinDir <- pkgBinDir pkg libname              ok <- symlinkBinary                      publicBinDir  privateBinDir                      publicExeName privateExeName@@ -113,32 +126,39 @@                then return Nothing                else return (Just (pkgid, publicExeName,                                   privateBinDir </> privateExeName))-        | (pkg, exe) <- exes-        , let publicExeName  = PackageDescription.exeName exe+        | (ReadyPackage (ConfiguredPackage _ _flags _ _) deps, pkg, exe) <- exes+        , let pkgid  = packageId pkg+              pkg_key = mkPackageKey (packageKeySupported comp) pkgid+                                     (map Installed.libraryName+                                      (CD.nonSetupDeps deps))+              libname = packageKeyLibraryName pkgid pkg_key+              publicExeName  = PackageDescription.exeName exe               privateExeName = prefix ++ publicExeName ++ suffix-              pkgid  = packageId pkg-              prefix = substTemplate pkgid prefixTemplate-              suffix = substTemplate pkgid suffixTemplate ]+              prefix = substTemplate pkgid libname prefixTemplate+              suffix = substTemplate pkgid libname suffixTemplate ]   where     exes =-      [ (pkg, exe)-      | InstallPlan.Installed cpkg _ <- InstallPlan.toList plan+      [ (cpkg, pkg, exe)+      | InstallPlan.Installed cpkg _ _ <- InstallPlan.toList plan       , let pkg   = pkgDescription cpkg       , exe <- PackageDescription.executables pkg       , PackageDescription.buildable (PackageDescription.buildInfo exe) ]      pkgDescription :: ReadyPackage -> PackageDescription-    pkgDescription (ReadyPackage (SourcePackage _ pkg _ _) flags stanzas _) =+    pkgDescription (ReadyPackage (ConfiguredPackage+                                    (SourcePackage _ pkg _ _)+                                    flags stanzas _)+                                  _) =       case finalizePackageDescription flags              (const True)-             platform compilerId [] (enableStanzas stanzas pkg) of+             platform cinfo [] (enableStanzas stanzas pkg) of         Left _ -> error "finalizePackageDescription ReadyPackage failed"         Right (desc, _) -> desc      -- This is sadly rather complicated. We're kind of re-doing part of the     -- configuration for the package. :-(-    pkgBinDir :: PackageDescription -> IO FilePath-    pkgBinDir pkg = do+    pkgBinDir :: PackageDescription -> LibraryName -> IO FilePath+    pkgBinDir pkg libname = do       defaultDirs <- InstallDirs.defaultInstallDirs                        compilerFlavor                        (fromFlag (configUserInstall configFlags))@@ -146,19 +166,21 @@       let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault                            defaultDirs (configInstallDirs configFlags)           absoluteDirs = InstallDirs.absoluteInstallDirs-                           (packageId pkg) compilerId InstallDirs.NoCopyDest+                           (packageId pkg) libname+                           cinfo InstallDirs.NoCopyDest                            platform templateDirs       canonicalizePath (InstallDirs.bindir absoluteDirs) -    substTemplate pkgid = InstallDirs.fromPathTemplate-                        . InstallDirs.substPathTemplate env-      where env = InstallDirs.initialPathTemplateEnv pkgid compilerId platform+    substTemplate pkgid libname = InstallDirs.fromPathTemplate+                                . InstallDirs.substPathTemplate env+      where env = InstallDirs.initialPathTemplateEnv pkgid libname+                                                     cinfo platform      fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")     prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)     suffixTemplate   = fromFlagTemplate (configProgSuffix configFlags)-    platform         = InstallPlan.planPlatform plan-    compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan+    cinfo            = compilerInfo comp+    (CompilerId compilerFlavor _) = compilerInfoId cinfo  symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir                           --   eg @/home/user/bin@@@ -168,7 +190,7 @@                           --   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 sucessful. @False@+              -> 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.@@ -185,11 +207,11 @@                                 (publicBindir   </> publicName)     rmLink = removeLink (publicBindir </> publicName) --- | Check a filepath 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+-- | 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 -- be a symlink to our target (in which case we can assume ownership). ---targetOkToOverwrite :: FilePath -- ^ The filepath of the symlink to the private+targetOkToOverwrite :: FilePath -- ^ The file path of the symlink to the private                                 -- binary that we would like to create                     -> FilePath -- ^ The canonical path of the private binary.                                 -- Use 'canonicalizePath' to make this.@@ -214,7 +236,7 @@ data SymlinkStatus    = NotExists     -- ^ The file doesn't exist so we can make a symlink.    | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll-                   -- have to delete it first bemore we make a new symlink.+                   -- have to delete it first before we make a new symlink.    | NotOurFile    -- ^ A file already exists and it is not one of our existing                    -- symlinks (either because it is not a symlink or because                    -- it points somewhere other than our managed space).

cabal/cabal-install/Distribution/Client/List.hs view

@@ -15,7 +15,8 @@  import Distribution.Package          ( PackageName(..), Package(..), packageName, packageVersion-         , Dependency(..), simplifyDependency )+         , Dependency(..), simplifyDependency+         , InstalledPackageId ) import Distribution.ModuleName (ModuleName) import Distribution.License (License) import qualified Distribution.InstalledPackageInfo as Installed@@ -30,7 +31,8 @@ import Distribution.Simple.Program (ProgramConfiguration) import Distribution.Simple.Utils         ( equating, comparing, die, notice )-import Distribution.Simple.Setup (fromFlag)+import Distribution.Simple.Setup (fromFlag, flagToMaybe)+import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Version@@ -43,7 +45,7 @@ import Distribution.Client.Types          ( SourcePackage(..), Repo, SourcePackageDb(..) ) import Distribution.Client.Dependency.Types-         ( PackageConstraint(..), ExtDependency(..) )+         ( PackageConstraint(..) ) import Distribution.Client.Targets          ( UserTarget, resolveUserTargets, PackageSpecifier(..) ) import Distribution.Client.Setup@@ -54,6 +56,8 @@          ( getSourcePackages, getInstalledPackages ) import Distribution.Client.FetchUtils          ( isFetched )+import Distribution.Client.HttpUtils+        ( configureTransport )  import Data.List          ( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition )@@ -86,16 +90,30 @@         prefs name = fromMaybe anyVersion                        (Map.lookup name (packagePreferences sourcePkgDb)) -        pkgsInfo :: [(PackageName, [Installed.InstalledPackageInfo], [SourcePackage])]+        pkgsInfo ::+          [(PackageName, [Installed.InstalledPackageInfo], [SourcePackage])]         pkgsInfo             -- gather info for all packages-          | null pats = mergePackages (InstalledPackageIndex.allPackages installedPkgIndex)-                                      (         PackageIndex.allPackages sourcePkgIndex)+          | null pats = mergePackages+                        (InstalledPackageIndex.allPackages installedPkgIndex)+                        (         PackageIndex.allPackages sourcePkgIndex)              -- gather info for packages matching search term-          | otherwise = mergePackages (matchingPackages InstalledPackageIndex.searchByNameSubstring installedPkgIndex)-                                      (matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchByNameSubstring idx n)) sourcePkgIndex)+          | otherwise = pkgsInfoMatching +        pkgsInfoMatching ::+          [(PackageName, [Installed.InstalledPackageInfo], [SourcePackage])]+        pkgsInfoMatching =+          let matchingInstalled = matchingPackages+                                  InstalledPackageIndex.searchByNameSubstring+                                  installedPkgIndex+              matchingSource   = matchingPackages+                                 (\ idx n ->+                                   concatMap snd+                                   (PackageIndex.searchByNameSubstring idx n))+                                 sourcePkgIndex+          in mergePackages matchingInstalled matchingSource+         matches :: [PackageDisplayInfo]         matches = [ mergePackageInfo pref                       installedPkgs sourcePkgs selectedPkg False@@ -168,9 +186,12 @@         -- just available source packages, so we must resolve targets using         -- the combination of installed and source packages.     let sourcePkgs' = PackageIndex.fromList-                    $ map packageId (InstalledPackageIndex.allPackages installedPkgIndex)-                   ++ map packageId (         PackageIndex.allPackages sourcePkgIndex)-    pkgSpecifiers <- resolveUserTargets verbosity+                    $ map packageId+                      (InstalledPackageIndex.allPackages installedPkgIndex)+                   ++ map packageId+                      (PackageIndex.allPackages sourcePkgIndex)+    transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))+    pkgSpecifiers <- resolveUserTargets verbosity transport                        (fromFlag $ globalWorldFile globalFlags)                        sourcePkgs' userTargets @@ -186,11 +207,12 @@    where     gatherPkgInfo :: (PackageName -> VersionRange) ->-                     InstalledPackageIndex.PackageIndex ->+                     InstalledPackageIndex ->                      PackageIndex.PackageIndex SourcePackage ->                      PackageSpecifier SourcePackage ->                      Either String PackageDisplayInfo-    gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (NamedPackage name constraints)+    gatherPkgInfo prefs installedPkgIndex sourcePkgIndex+      (NamedPackage name constraints)       | null (selectedInstalledPkgs) && null (selectedSourcePkgs)       = Left $ "There is no available version of " ++ display name             ++ " that satisfies "@@ -204,10 +226,11 @@         (pref, installedPkgs, sourcePkgs) =           sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex -        selectedInstalledPkgs = InstalledPackageIndex.lookupDependency installedPkgIndex-                                    (Dependency name verConstraint)-        selectedSourcePkgs    =          PackageIndex.lookupDependency sourcePkgIndex-                                    (Dependency name verConstraint)+        selectedInstalledPkgs = InstalledPackageIndex.lookupDependency+                                installedPkgIndex+                                (Dependency name verConstraint)+        selectedSourcePkgs    = PackageIndex.lookupDependency sourcePkgIndex+                                (Dependency name verConstraint)         selectedSourcePkg'    = latestWithPref pref selectedSourcePkgs                           -- display a specific package version if the user@@ -216,7 +239,8 @@         verConstraint  = foldr intersectVersionRanges anyVersion verConstraints         verConstraints = [ vr | PackageConstraintVersion _ vr <- constraints ] -    gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (SpecificSourcePackage pkg) =+    gatherPkgInfo prefs installedPkgIndex sourcePkgIndex+      (SpecificSourcePackage pkg) =         Right $ mergePackageInfo pref installedPkgs sourcePkgs                                  selectedPkg True       where@@ -228,19 +252,20 @@ sourcePkgsInfo ::   (PackageName -> VersionRange)   -> PackageName-  -> InstalledPackageIndex.PackageIndex+  -> InstalledPackageIndex   -> PackageIndex.PackageIndex SourcePackage   -> (VersionRange, [Installed.InstalledPackageInfo], [SourcePackage]) sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex =   (pref, installedPkgs, sourcePkgs)   where     pref          = prefs name-    installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name)-    sourcePkgs    =                         PackageIndex.lookupPackageName sourcePkgIndex name+    installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName+                                   installedPkgIndex name)+    sourcePkgs    = PackageIndex.lookupPackageName sourcePkgIndex name   -- | The info that we can display for each package. It is information per--- package name and covers all installed and avilable versions.+-- package name and covers all installed and available versions. -- data PackageDisplayInfo = PackageDisplayInfo {     pkgName           :: PackageName,@@ -268,6 +293,11 @@     haveTarball       :: Bool   } +-- | Covers source dependencies and installed dependencies in+-- one type.+data ExtDependency = SourceDependency Dependency+                   | InstalledDependency InstalledPackageId+ showPackageSummaryInfo :: PackageDisplayInfo -> String showPackageSummaryInfo pkginfo =   renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $@@ -320,7 +350,7 @@    , entry "Source repo"   sourceRepo   orNotSpecified text    , entry "Executables"   executables  hideIfNull     (commaSep text)    , entry "Flags"         flags        hideIfNull     (commaSep dispFlag)-   , entry "Dependencies"  dependencies hideIfNull     (commaSep disp)+   , entry "Dependencies"  dependencies hideIfNull     (commaSep dispExtDep)    , entry "Documentation" haddockHtml  showIfInstalled text    , entry "Cached"        haveTarball  alwaysShow     dispYesNo    , if not (hasLib pkginfo) then empty else@@ -354,6 +384,9 @@     dispYesNo True  = text "Yes"     dispYesNo False = text "No" +    dispExtDep (SourceDependency    dep) = disp dep+    dispExtDep (InstalledDependency dep) = disp dep+     isInstalled = not (null (installedVersions pkginfo))     hasExes = length (executables pkginfo) >= 2     --TODO: exclude non-buildable exes@@ -429,11 +462,14 @@     hasExe       = fromMaybe False                    (fmap (not . null . Source.condExecutables) sourceGeneric),     executables  = map fst (maybe [] Source.condExecutables sourceGeneric),-    modules      = combine Installed.exposedModules installed-                           (maybe [] Source.exposedModules-                                   . Source.library) source,-    dependencies = combine (map (SourceDependency . simplifyDependency) . Source.buildDepends) source-                           (map InstalledDependency . Installed.depends) installed,+    modules      = combine (map Installed.exposedName . Installed.exposedModules)+                           installed+                           (maybe [] getListOfExposedModules . Source.library)+                           source,+    dependencies =+      combine (map (SourceDependency . simplifyDependency)+               . Source.buildDepends) source+      (map InstalledDependency . Installed.depends) installed,     haddockHtml  = fromMaybe "" . join                  . fmap (listToMaybe . Installed.haddockHTMLs)                  $ installed,@@ -443,6 +479,10 @@     combine f x g y  = fromJust (fmap f x `mplus` fmap g y)     installed :: Maybe Installed.InstalledPackageInfo     installed = latestWithPref versionPref installedPkgs++    getListOfExposedModules lib = Source.exposedModules lib+                               ++ map Source.moduleReexportName+                                      (Source.reexportedModules lib)      sourceSelected       | isJust selectedPkg = selectedPkg

cabal/cabal-install/Distribution/Client/PackageIndex.hs view

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.PackageIndex@@ -41,42 +43,31 @@   -- ** Bulk queries   allPackages,   allPackagesByName,--  -- ** Special queries-  brokenPackages,-  dependencyClosure,-  reverseDependencyClosure,-  topologicalOrder,-  reverseTopologicalOrder,-  dependencyInconsistencies,-  dependencyCycles,-  dependencyGraph,   ) where  import Prelude hiding (lookup) import Control.Exception (assert) import qualified Data.Map as Map import Data.Map (Map)-import qualified Data.Tree  as Tree-import qualified Data.Graph as Graph-import qualified Data.Array as Array-import Data.Array ((!))-import Data.List (groupBy, sortBy, nub, isInfixOf)+import Data.List (groupBy, sortBy, isInfixOf)+#if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid(..))-import Data.Maybe (isJust, isNothing, fromMaybe, catMaybes)+#endif+import Data.Maybe (isJust, fromMaybe)  import Distribution.Package          ( PackageName(..), PackageIdentifier(..)          , Package(..), packageName, packageVersion-         , Dependency(Dependency), PackageFixedDeps(..) )+         , Dependency(Dependency) ) import Distribution.Version-         ( Version, withinRange )-import Distribution.Simple.Utils (lowercase, equating, comparing)+         ( withinRange )+import Distribution.Simple.Utils+         ( lowercase, comparing )   -- | The collection of information about packages from one or more 'PackageDB's. ----- It can be searched effeciently by package name and version.+-- 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@@ -87,10 +78,7 @@   --   (Map PackageName [pkg]) -  deriving (Show, Read)--instance Functor PackageIndex where-  fmap f (PackageIndex m) = PackageIndex (fmap (map f) m)+  deriving (Show, Read, Functor)  instance Package pkg => Monoid (PackageIndex pkg) where   mempty  = PackageIndex Map.empty@@ -125,7 +113,7 @@ -- | Lookup a name in the index to get all packages that match that name -- case-sensitively. ---lookup :: Package pkg => PackageIndex pkg -> PackageName -> [pkg]+lookup :: PackageIndex pkg -> PackageName -> [pkg] lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m  --@@ -227,14 +215,14 @@  -- | Get all the packages from the index. ---allPackages :: Package pkg => PackageIndex pkg -> [pkg]+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 :: Package pkg => PackageIndex pkg -> [[pkg]]+allPackagesByName :: PackageIndex pkg -> [[pkg]] allPackagesByName (PackageIndex m) = Map.elems m  --@@ -285,17 +273,17 @@  -- | Does a case-insensitive search by package name. ----- If there is only one package that compares case-insentiviely to this 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-insentiviely but one matches exactly then it is also+-- If several match case-insensitively but one matches exactly then it is also -- unambiguous. ----- If however several match case-insentiviely and none match exactly then we+-- 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 :: Package pkg => PackageIndex pkg+searchByName :: PackageIndex pkg              -> String -> [(PackageName, [pkg])] searchByName (PackageIndex m) name =     [ pkgs@@ -310,7 +298,7 @@ -- -- That is, all packages that contain the given string in their name. ---searchByNameSubstring :: Package pkg => PackageIndex pkg+searchByNameSubstring :: PackageIndex pkg                       -> String -> [(PackageName, [pkg])] searchByNameSubstring (PackageIndex m) searchterm =     [ pkgs@@ -318,172 +306,3 @@     , lsearchterm `isInfixOf` lowercase name ]   where     lsearchterm = lowercase searchterm------- * Special queries------- | 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, [PackageIdentifier])]-brokenPackages index =-  [ (pkg, missing)-  | pkg  <- allPackages index-  , let missing = [ pkg' | pkg' <- depends pkg-                         , isNothing (lookupPackageId index pkg') ]-  , not (null missing) ]---- | 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-                  => PackageIndex pkg-                  -> [PackageIdentifier]-                  -> Either (PackageIndex pkg)-                            [(pkg, [PackageIdentifier])]-dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of-  (completed, []) -> Left completed-  (completed, _)  -> Right (brokenPackages completed)-  where-    closure completed failed []             = (completed, failed)-    closure completed failed (pkgid:pkgids) = case lookupPackageId index pkgid of-      Nothing   -> closure completed (pkgid:failed) pkgids-      Just pkg  -> case lookupPackageId completed (packageId pkg) of-        Just _  -> closure completed  failed pkgids-        Nothing -> closure completed' failed pkgids'-          where completed' = insert pkg completed-                pkgids'    = depends pkg ++ pkgids---- | Takes the transitive closure of the packages reverse dependencies.------ * The given 'PackageIdentifier's must be in the index.----reverseDependencyClosure :: PackageFixedDeps pkg-                         => PackageIndex pkg-                         -> [PackageIdentifier]-                         -> [pkg]-reverseDependencyClosure index =-    map vertexToPkg-  . concatMap Tree.flatten-  . Graph.dfs reverseDepGraph-  . map (fromMaybe noSuchPkgId . pkgIdToVertex)--  where-    (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index-    reverseDepGraph = Graph.transposeG depGraph-    noSuchPkgId = error "reverseDependencyClosure: package is not in the graph"--topologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg]-topologicalOrder index = map toPkgId-                       . Graph.topSort-                       $ graph-  where (graph, toPkgId, _) = dependencyGraph index--reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg]-reverseTopologicalOrder index = map toPkgId-                              . Graph.topSort-                              . Graph.transposeG-                              $ graph-  where (graph, toPkgId, _) = dependencyGraph index---- | 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 :: PackageFixedDeps pkg-                          => PackageIndex pkg-                          -> [(PackageName, [(PackageIdentifier, Version)])]-dependencyInconsistencies index =-  [ (name, inconsistencies)-  | (name, uses) <- Map.toList inverseIndex-  , let inconsistencies = duplicatesBy uses-        versions = map snd inconsistencies-  , reallyIsInconsistent name (nub versions) ]--  where inverseIndex = Map.fromListWith (++)-          [ (packageName dep, [(packageId pkg, packageVersion dep)])-          | pkg <- allPackages index-          , dep <- depends pkg ]--        duplicatesBy = (\groups -> if length groups == 1-                                     then []-                                     else concat groups)-                     . groupBy (equating snd)-                     . sortBy (comparing snd)--        reallyIsInconsistent :: PackageName -> [Version] -> Bool-        reallyIsInconsistent _    []       = False-        reallyIsInconsistent name [v1, v2] =-          case (mpkg1, mpkg2) of-            (Just pkg1, Just pkg2) -> pkgid1 `notElem` depends pkg2-                                   && pkgid2 `notElem` depends pkg1-            _ -> True-          where-            pkgid1 = PackageIdentifier name v1-            pkgid2 = PackageIdentifier name v2-            mpkg1 = lookupPackageId index pkgid1-            mpkg2 = lookupPackageId index pkgid2--        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-                 => PackageIndex pkg-                 -> [[pkg]]-dependencyCycles index =-  [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]-  where-    adjacencyList = [ (pkg, packageId pkg, depends pkg)-                    | pkg <- allPackages index ]---- | 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-                => PackageIndex pkg-                -> (Graph.Graph,-                    Graph.Vertex -> pkg,-                    PackageIdentifier -> Maybe Graph.Vertex)-dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex)-  where-    graph = Array.listArray bounds $-            map (catMaybes . map pkgIdToVertex . depends) pkgs-    vertexToPkg vertex = pkgTable ! vertex-    pkgIdToVertex = binarySearch 0 topBound--    pkgTable   = Array.listArray bounds pkgs-    pkgIdTable = Array.listArray bounds (map packageId pkgs)-    pkgs = sortBy (comparing packageId) (allPackages index)-    topBound = length pkgs - 1-    bounds = (0, topBound)--    binarySearch a b key-      | a > b     = Nothing-      | otherwise = case compare key (pkgIdTable ! 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/ParseUtils.hs view

@@ -16,7 +16,7 @@          ( Field(..) )  import Control.Monad    ( foldM )-import Text.PrettyPrint ( (<>), (<+>), ($$) )+import Text.PrettyPrint ( (<>), (<+>), ($+$) ) import qualified Data.Map as Map import qualified Text.PrettyPrint as Disp          ( Doc, text, colon, vcat, empty, isEmpty, nest )@@ -52,6 +52,11 @@   | otherwise        = Disp.text name <> Disp.colon <+> cur  ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc-ppSection name arg fields def cur =-     Disp.text name <+> Disp.text arg-  $$ Disp.nest 2 (ppFields fields def cur)+ppSection name arg fields def cur+  | Disp.isEmpty fieldsDoc = Disp.empty+  | otherwise              = Disp.text name <+> argDoc+                             $+$ (Disp.nest 2 fieldsDoc)+  where+    fieldsDoc = ppFields fields def cur+    argDoc | arg == "" = Disp.empty+           | otherwise = Disp.text arg

+ cabal/cabal-install/Distribution/Client/PlanIndex.hs view

@@ -0,0 +1,339 @@+-- | 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+  , fakeLookupInstalledPackageId+    -- * Graph traversal functions+  , brokenPackages+  , dependencyClosure+  , dependencyCycles+  , dependencyGraph+  , dependencyInconsistencies+  , reverseDependencyClosure+  , reverseTopologicalOrder+  , topologicalOrder+  ) where++import Prelude hiding (lookup)+import qualified Data.Map as Map+import qualified Data.Tree  as Tree+import qualified Data.Graph as Graph+import Data.Array ((!))+import Data.Map (Map)+import Data.Maybe (isNothing, fromMaybe, fromJust)+import Data.Either (rights)++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid(..))+#endif++import Distribution.Package+         ( PackageName(..), PackageIdentifier(..), InstalledPackageId(..)+         , 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, lookupInstalledPackageId )+import Distribution.Package+         ( HasInstalledPackageId(..), 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 InstalledPackageId, 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 InstalledPackageId will be calculatable prior to actually+-- building the package (making it something of a misnomer), 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 InstalledPackageId 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 InstalledPackageId 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 InstalledPackageId.  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 installed package IDs to real ones.  See Note [FakeMap]+type FakeMap = Map InstalledPackageId InstalledPackageId++-- | Variant of `depends` which accepts a `FakeMap`+--+-- Analogous to `fakeInstalledDepends`. See Note [FakeMap].+fakeDepends :: PackageFixedDeps pkg => FakeMap -> pkg -> ComponentDeps [InstalledPackageId]+fakeDepends fakeMap = fmap (map resolveFakeId) . depends+  where+    resolveFakeId :: InstalledPackageId -> InstalledPackageId+    resolveFakeId ipid = Map.findWithDefault ipid ipid fakeMap++--- | Variant of 'lookupInstalledPackageId' which accepts a 'FakeMap'.  See Note+--- [FakeMap].+fakeLookupInstalledPackageId :: FakeMap -> PackageIndex a -> InstalledPackageId+                             -> Maybe a+fakeLookupInstalledPackageId fakeMap index pkg =+  lookupInstalledPackageId 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, [InstalledPackageId])]+brokenPackages fakeMap index =+  [ (pkg, missing)+  | pkg  <- allPackages index+  , let missing =+          [ pkg' | pkg' <- CD.nonSetupDeps (depends pkg)+                 , isNothing (fakeLookupInstalledPackageId 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, HasInstalledPackageId 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, HasInstalledPackageId pkg)+         => FakeMap -> Bool -> PackageIndex pkg -> [[InstalledPackageId]]+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, HasInstalledPackageId pkg)+             => FakeMap -> PackageIndex pkg -> [InstalledPackageId]+libraryRoots fakeMap index =+    map (installedPackageId . 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 -> [[InstalledPackageId]]+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, HasInstalledPackageId 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 InstalledPackageId (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 <- [fakeLookupInstalledPackageId 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 = installedPackageId p1+          pid2 = installedPackageId 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, HasInstalledPackageId pkg)+                 => FakeMap+                 -> PackageIndex pkg+                 -> [[pkg]]+dependencyCycles fakeMap index =+  [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]+  where+    adjacencyList = [ (pkg, installedPackageId pkg, CD.nonSetupDeps (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, HasInstalledPackageId pkg)+                  => FakeMap+                  -> PackageIndex pkg+                  -> [InstalledPackageId]+                  -> Either [(pkg, [InstalledPackageId])]+                            (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 fakeLookupInstalledPackageId fakeMap index pkgid of+        Nothing   -> closure completed (pkgid:failed) pkgids+        Just pkg  ->+          case fakeLookupInstalledPackageId fakeMap completed+               (installedPackageId pkg) of+            Just _  -> closure completed  failed pkgids+            Nothing -> closure completed' failed pkgids'+              where completed' = insert pkg completed+                    pkgids'    = CD.nonSetupDeps (depends pkg) ++ pkgids+++topologicalOrder :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)+                 => FakeMap -> PackageIndex pkg -> [pkg]+topologicalOrder fakeMap index = map toPkgId+                               . Graph.topSort+                               $ graph+  where (graph, toPkgId, _) = dependencyGraph fakeMap index+++reverseTopologicalOrder :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)+                        => FakeMap -> PackageIndex pkg -> [pkg]+reverseTopologicalOrder fakeMap index = map toPkgId+                                      . Graph.topSort+                                      . Graph.transposeG+                                      $ graph+  where (graph, toPkgId, _) = dependencyGraph fakeMap index+++-- | Takes the transitive closure of the packages reverse dependencies.+--+-- * The given 'PackageIdentifier's must be in the index.+--+reverseDependencyClosure :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)+                         => FakeMap+                         -> PackageIndex pkg+                         -> [InstalledPackageId]+                         -> [pkg]+reverseDependencyClosure fakeMap index =+    map vertexToPkg+  . concatMap Tree.flatten+  . Graph.dfs reverseDepGraph+  . map (fromMaybe noSuchPkgId . pkgIdToVertex)++  where+    (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph fakeMap index+    reverseDepGraph = Graph.transposeG depGraph+    noSuchPkgId = error "reverseDependencyClosure: package is not in the 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'.+--+dependencyGraph :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)+                => FakeMap+                -> PackageIndex pkg+                -> (Graph.Graph,+                    Graph.Vertex -> pkg,+                    InstalledPackageId -> Maybe Graph.Vertex)+dependencyGraph fakeMap index = (graph, vertexToPkg, idToVertex)+  where+    (graph, vertexToPkg', idToVertex) = Graph.graphFromEdges edges+    vertexToPkg = fromJust+                . (\((), key, _targets) -> lookupInstalledPackageId index key)+                . vertexToPkg'++    pkgs  = allPackages index+    edges = map edgesFrom pkgs++    resolve   pid = Map.findWithDefault pid pid fakeMap+    edgesFrom pkg = ( ()+                    , resolve (installedPackageId pkg)+                    , CD.nonSetupDeps (fakeDepends fakeMap pkg)+                    )

cabal/cabal-install/Distribution/Client/Run.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Run@@ -13,42 +14,96 @@ import Distribution.Client.Utils             (tryCanonicalizePath)  import Distribution.PackageDescription       (Executable (..),-                                              PackageDescription (..))+                                              TestSuite(..),+                                              Benchmark(..),+                                              PackageDescription (..),+                                              BuildInfo(buildable))+import Distribution.Simple.Compiler          (compilerFlavor, CompilerFlavor(..)) import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) import Distribution.Simple.BuildPaths        (exeExtension)-import Distribution.Simple.LocalBuildInfo    (LocalBuildInfo (..))-import Distribution.Simple.Utils             (die, rawSystemExitWithEnv)+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 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                       ((<.>), (</>))   -- | Return the executable to run and any extra arguments that should be--- forwarded to it.-splitRunArgs :: LocalBuildInfo -> [String] -> IO (Executable, [String])-splitRunArgs lbi args =-  case exes of-    []    -> die "Couldn't find any executables."-    [exe] -> case args of-      []                        -> return (exe, [])-      (x:xs) | x == exeName exe -> return (exe, xs)-             | otherwise        -> return (exe, args)-    _     -> case args of-      []     -> die $ "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) exes of-        Nothing  -> die $ "No executable named '" ++ x ++ "'."-        Just exe -> return (exe, xs)+-- forwarded to it. Die in case of error.+splitRunArgs :: Verbosity -> LocalBuildInfo -> [String]+             -> IO (Executable, [String])+splitRunArgs verbosity lbi args =+  case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest)+    Left err               -> do+      warn verbosity `traverse_` maybeWarning -- If there is a warning, print it.+      die err+    Right (True, exe, xs)  -> return (exe, xs)+    Right (False, exe, xs) -> do+      let addition = " Interpreting all parameters to `run` as a parameter to"+                     ++ " the default executable."+      -- If there is a warning, print it together with the addition.+      warn verbosity `traverse_` fmap (++addition) maybeWarning+      return (exe, xs)   where     pkg_descr = localPkgDescr lbi-    exes      = executables pkg_descr+    whichExecutable :: Either String       -- Error string.+                              ( Bool       -- If it was manually chosen.+                              , Executable -- The executable.+                              , [String]   -- The remaining parameters.+                              )+    whichExecutable = case (enabledExes, args) of+      ([]   , _)           -> 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+        $ "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+          Nothing  -> Left $ "No executable named '" ++ x ++ "'."+          Just exe -> return (True, exe, xs)+      where+        enabledExes = filter (buildable . buildInfo) (executables pkg_descr) +    maybeWarning :: Maybe String+    maybeWarning = case args of+      []    -> Nothing+      (x:_) -> lookup x components+      where+        components :: [(String, String)] -- Component name, message.+        components =+          [ (name, "The executable '" ++ name ++ "' is disabled.")+          | e <- executables pkg_descr+          , not . buildable . buildInfo $ e, let name = exeName e] +          ++ [ (name, "There is a test-suite '" ++ name ++ "',"+                      ++ " but the `run` command is only for executables.")+             | t <- testSuites pkg_descr+             , let name = testName t]++          ++ [ (name, "There is a benchmark '" ++ name ++ "',"+                      ++ " but the `run` command is only for executables.")+             | b <- benchmarks pkg_descr+             , let name = benchmarkName b]+ -- | Run a given executable. run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO () run verbosity lbi exe exeArgs = do@@ -58,7 +113,27 @@       dataDirEnvVar = (pkgPathEnvVar pkg_descr "datadir",                        curDir </> dataDir pkg_descr) -  path <- tryCanonicalizePath $-          buildPref </> exeName exe </> (exeName exe <.> exeExtension)+  (path, runArgs) <-+    case compilerFlavor (compiler lbi) of+      GHCJS -> do+        let (script, cmd, cmdArgs) =+              GHCJS.runCmd (withPrograms lbi)+                           (buildPref </> exeName exe </> exeName exe)+        script' <- tryCanonicalizePath script+        return (cmd, cmdArgs ++ [script'])+      _     -> do+         p <- tryCanonicalizePath $+            buildPref </> exeName exe </> (exeName exe <.> exeExtension)+         return (p, [])+   env  <- (dataDirEnvVar:) <$> getEnvironment-  rawSystemExitWithEnv verbosity path exeArgs env+  -- Add (DY)LD_LIBRARY_PATH if needed+  env' <- if withDynExe lbi+             then do let (Platform _ os) = hostPlatform lbi+                         clbi = getComponentLocalBuildInfo lbi+                                  (CExeName (exeName exe))+                     paths <- depLibraryPaths True False lbi clbi+                     return (addLibraryPath os paths env)+             else return env+  notice verbosity $ "Running " ++ exeName exe ++ "..."+  rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env'

cabal/cabal-install/Distribution/Client/Sandbox.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Sandbox@@ -20,6 +21,7 @@      getSandboxConfigFilePath,     loadConfigOrSandboxConfig,+    findSavedDistPref,     initPackageDBIfNeeded,     maybeWithSandboxDirOnSearchPath, @@ -34,6 +36,7 @@     sandboxBuildDir,     getInstalledPackagesInSandbox,     updateSandboxConfigFileFlag,+    updateInstallDirs,      -- FIXME: move somewhere else     configPackageDB', configCompilerAux'@@ -47,24 +50,30 @@                                               , maybeAddCompilerTimestampRecord                                               , withAddTimestamps                                               , withRemoveTimestamps )-import Distribution.Client.Config             ( SavedConfig(..), loadConfig )+import Distribution.Client.Config+  ( SavedConfig(..), defaultUserInstall, loadConfig ) import Distribution.Client.Dependency         ( foldProgress ) import Distribution.Client.IndexUtils         ( BuildTreeRefType(..) ) import Distribution.Client.Install            ( InstallArgs,                                                 makeInstallContext,                                                 makeInstallPlan,                                                 processInstallPlan )+import Distribution.Utils.NubList            ( fromNubList )+ import Distribution.Client.Sandbox.PackageEnvironment-  ( PackageEnvironment(..), IncludeComments(..), PackageEnvironmentType(..)+  ( PackageEnvironment(..), PackageEnvironmentType(..)   , createPackageEnvironmentFile, classifyPackageEnvironment   , tryLoadSandboxPackageEnvironmentFile, loadUserConfig   , commentPackageEnvironment, showPackageEnvironmentWithComments   , sandboxPackageEnvironmentFile, userPackageEnvironmentFile ) import Distribution.Client.Sandbox.Types      ( SandboxPackageInfo(..)                                               , UseSandbox(..) )+import Distribution.Client.SetupWrapper+  ( SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Types              ( PackageLocation(..)                                               , SourcePackage(..) )-import Distribution.Client.Utils              ( inDir, tryCanonicalizePath )+import Distribution.Client.Utils              ( inDir, tryCanonicalizePath+                                              , tryFindAddSourcePackageDesc ) import Distribution.PackageDescription.Configuration                                               ( flattenPackageDescription ) import Distribution.PackageDescription.Parse  ( readPackageDescription )@@ -72,7 +81,8 @@                                               , PackageDBStack ) import Distribution.Simple.Configure          ( configCompilerAuxEx                                               , interpretPackageDbFlags-                                              , getPackageDBContents )+                                              , getPackageDBContents+                                              , findDistPref ) import Distribution.Simple.PreProcess         ( knownSuffixHandlers ) import Distribution.Simple.Program            ( ProgramConfiguration ) import Distribution.Simple.Setup              ( Flag(..), HaddockFlags(..)@@ -80,16 +90,16 @@ import Distribution.Simple.SrcDist            ( prepareTree ) import Distribution.Simple.Utils              ( die, debug, notice, info, warn                                               , debugNoWrap, defaultPackageDesc-                                              , tryFindPackageDesc                                               , intercalate, topHandlerWith                                               , createDirectoryIfMissingVerbose ) import Distribution.Package                   ( Package(..) ) import Distribution.System                    ( Platform ) import Distribution.Text                      ( display ) import Distribution.Verbosity                 ( Verbosity, lessVerbose )-import Distribution.Client.Compat.Environment ( lookupEnv, setEnv )+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 qualified Data.Map                          as M@@ -100,8 +110,10 @@ import Data.Char                              ( ord ) import Data.IORef                             ( newIORef, writeIORef, readIORef ) import Data.List                              ( delete, foldl' )-import Data.Maybe                             ( fromJust, fromMaybe )+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                       ( createDirectory@@ -111,7 +123,8 @@                                               , removeDirectoryRecursive                                               , removeFile                                               , renameDirectory )-import System.FilePath                        ( (</>), getSearchPath+import System.FilePath                        ( (</>), equalFilePath+                                              , getSearchPath                                               , searchPathSeparator                                               , takeDirectory ) @@ -163,8 +176,7 @@   case globalSandboxConfigFile globalFlags of     Flag _ -> return globalFlags     NoFlag -> do-      f' <- fmap (fromMaybe NoFlag . fmap Flag) . lookupEnv-            $ "CABAL_SANDBOX_CONFIG"+      f' <- fmap (maybe NoFlag Flag) . lookupEnv $ "CABAL_SANDBOX_CONFIG"       return globalFlags { globalSandboxConfigFile = f' }  -- | Return the path to the sandbox config file - either the default or the one@@ -196,7 +208,7 @@ -- 'SavedConfig'. tryGetIndexFilePath' :: GlobalFlags -> IO FilePath tryGetIndexFilePath' globalFlags = do-  let paths = globalLocalRepos globalFlags+  let paths = fromNubList $ globalLocalRepos globalFlags   case paths of     []  -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++            "no local repos found. " ++ checkConfiguration@@ -228,7 +240,7 @@ -- | Which packages are installed in the sandbox package DB? getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags                                  -> Compiler -> ProgramConfiguration-                                 -> IO InstalledPackageIndex.PackageIndex+                                 -> IO InstalledPackageIndex getInstalledPackagesInSandbox verbosity configFlags comp conf = do     sandboxDB <- getSandboxPackageDB configFlags     getPackageDBContents verbosity comp sandboxDB conf@@ -296,13 +308,12 @@   setFileHidden sandboxDir    -- Determine which compiler to use (using the value from ~/.cabal/config).-  userConfig <- loadConfig verbosity (globalConfigFile globalFlags) NoFlag+  userConfig <- loadConfig verbosity (globalConfigFile globalFlags)   (comp, platform, conf) <- configCompilerAuxEx (savedConfigureFlags userConfig)    -- Create the package environment file.   pkgEnvFile <- getSandboxConfigFilePath globalFlags-  createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile-    NoComments comp platform+  createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile comp platform   (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags   let config      = pkgEnvSavedConfig pkgEnv       configFlags = savedConfigureFlags config@@ -323,17 +334,19 @@ -- | Entry point for the 'cabal sandbox delete' command. sandboxDelete :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () sandboxDelete verbosity _sandboxFlags globalFlags = do-  (useSandbox, _) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  (useSandbox, _) <- loadConfigOrSandboxConfig+                       verbosity+                       globalFlags { globalRequireSandbox = Flag False }   case useSandbox of-    NoSandbox -> die "Not in a sandbox."+    NoSandbox -> warn verbosity "Not in a sandbox."     UseSandbox sandboxDir -> do       curDir     <- getCurrentDirectory       pkgEnvFile <- getSandboxConfigFilePath globalFlags        -- Remove the @cabal.sandbox.config@ file, unless it's in a non-standard       -- location.-      let isNonDefaultConfigLocation =-            pkgEnvFile /= (curDir </> sandboxPackageEnvironmentFile)+      let isNonDefaultConfigLocation = not $ equalFilePath pkgEnvFile $+                                       curDir </> sandboxPackageEnvironmentFile        if isNonDefaultConfigLocation         then warn verbosity $ "Sandbox config file is in non-default location: '"@@ -341,8 +354,8 @@         else removeFile pkgEnvFile        -- Remove the sandbox directory, unless we're using a shared sandbox.-      let isNonDefaultSandboxLocation =-            sandboxDir /= (curDir </> defaultSandboxLocation)+      let isNonDefaultSandboxLocation = not $ equalFilePath sandboxDir $+                                        curDir </> defaultSandboxLocation        when isNonDefaultSandboxLocation $         die $ "Non-default sandbox location used: '" ++ sandboxDir@@ -473,15 +486,35 @@    Register.invokeHcPkg verbosity comp conf dbStack extraArgs +updateInstallDirs :: Flag Bool+                  -> (UseSandbox, SavedConfig) -> (UseSandbox, SavedConfig)+updateInstallDirs userInstallFlag (useSandbox, savedConfig) =+  case useSandbox of+    NoSandbox ->+      let savedConfig' = savedConfig {+            savedConfigureFlags = configureFlags {+                configInstallDirs = installDirs+            }+          }+      in (useSandbox, savedConfig')+    _ -> (useSandbox, savedConfig)+  where+    configureFlags = savedConfigureFlags savedConfig+    userInstallDirs = savedUserInstallDirs savedConfig+    globalInstallDirs = savedGlobalInstallDirs savedConfig+    installDirs | userInstall = userInstallDirs+                | otherwise   = globalInstallDirs+    userInstall = fromFlagOrDefault defaultUserInstall+                  (configUserInstall configureFlags `mappend` userInstallFlag)+ -- | Check which type of package environment we're in and return a -- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates -- whether we're working in a sandbox. loadConfigOrSandboxConfig :: Verbosity-                             -> GlobalFlags  -- ^ For @--config-file@ and-                                             -- @--sandbox-config-file@.-                             -> Flag Bool    -- ^ Ignored if we're in a sandbox.-                             -> IO (UseSandbox, SavedConfig)-loadConfigOrSandboxConfig verbosity globalFlags userInstallFlag = do+                          -> GlobalFlags  -- ^ For @--config-file@ and+                                          -- @--sandbox-config-file@.+                          -> IO (UseSandbox, SavedConfig)+loadConfigOrSandboxConfig verbosity globalFlags = do   let configFileFlag        = globalConfigFile        globalFlags       sandboxConfigFileFlag = globalSandboxConfigFile globalFlags       ignoreSandboxFlag     = globalIgnoreSandbox globalFlags@@ -499,7 +532,7 @@      -- Only @cabal.config@ is present.     UserPackageEnvironment    -> do-      config <- loadConfig verbosity configFileFlag userInstallFlag+      config <- loadConfig verbosity configFileFlag       userConfig <- loadUserConfig verbosity pkgEnvDir       let config' = config `mappend` userConfig       dieIfSandboxRequired config'@@ -507,7 +540,7 @@      -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.     AmbientPackageEnvironment -> do-      config <- loadConfig verbosity configFileFlag userInstallFlag+      config <- loadConfig verbosity configFileFlag       dieIfSandboxRequired config       return (NoSandbox, config) @@ -527,10 +560,20 @@         flag = (globalRequireSandbox . savedGlobalFlags $ config)                `mappend` (globalRequireSandbox globalFlags)         checkFlag (Flag True)  =-          die $ "'require-sandbox' is set to True, but no sandbox is present."+          die $ "'require-sandbox' is set to True, but no sandbox is present. "+             ++ "Use '--no-require-sandbox' if you want to override "+             ++ "'require-sandbox' temporarily."         checkFlag (Flag False) = return ()         checkFlag (NoFlag)     = return () +-- | Return the saved \"dist/\" prefix, or the default prefix.+findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath+findSavedDistPref config flagDistPref = do+    let defDistPref = useDistPref defaultSetupScriptOptions+        flagDistPref' = configDistPref (savedConfigureFlags config)+                        `mappend` flagDistPref+    findDistPref defDistPref flagDistPref'+ -- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do -- nothing. maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a@@ -587,10 +630,7 @@       die' message = die (message ++ installFailedInSandbox)       -- TODO: use a better error message, remove duplication.       installFailedInSandbox =-        "Note: when using a sandbox, all packages are required to have \-        \consistent dependencies. \-        \Try reinstalling/unregistering the offending packages or \-        \recreating the sandbox."+        "Note: when using a sandbox, all packages are required to have consistent dependencies. Try reinstalling/unregistering the offending packages or recreating the sandbox."       logMsg message rest = debugNoWrap verbosity message >> rest        topHandler' = topHandlerWith $ \_ -> do@@ -618,9 +658,9 @@   -- List all packages installed in the sandbox.   installedPkgIndex <- getInstalledPackagesInSandbox verbosity                        configFlags comp conf-+  let err = "Error reading sandbox package information."   -- Get the package descriptions for all add-source deps.-  depsCabalFiles <- mapM tryFindPackageDesc buildTreeRefs+  depsCabalFiles <- mapM (flip tryFindAddSourcePackageDesc err) buildTreeRefs   depsPkgDescs   <- mapM (readPackageDescription verbosity) depsCabalFiles   let depsMap           = M.fromList (zip buildTreeRefs depsPkgDescs)       isInstalled pkgid = not . null@@ -677,13 +717,12 @@                                -> ConfigFlags      -- ^ Saved configure flags                                                    -- (from dist/setup-config)                                -> GlobalFlags-                               -> IO (UseSandbox, SavedConfig-                                     ,WereDepsReinstalled)-maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags' globalFlags' = do-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags'-                          (configUserInstall configFlags')+                               -> (UseSandbox, SavedConfig)+                               -> IO WereDepsReinstalled+maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags'+                            globalFlags' (useSandbox, config) = do   case useSandbox of-    NoSandbox             -> return (NoSandbox, config, NoDepsReinstalled)+    NoSandbox             -> return NoDepsReinstalled     UseSandbox sandboxDir -> do       -- Reinstall the modified add-source deps.       let configFlags    = savedConfigureFlags config@@ -702,10 +741,9 @@           -- from the command line. These options are hidden, and are only           -- useful for debugging, so this should be fine.                            `mappend` globalFlags'-      depsReinstalled <- reinstallAddSourceDeps verbosity-                         configFlags configExFlags installFlags globalFlags-                         sandboxDir-      return (UseSandbox sandboxDir, config, depsReinstalled)+      reinstallAddSourceDeps+        verbosity configFlags configExFlags+        installFlags globalFlags sandboxDir    where @@ -726,10 +764,11 @@         configProgramPaths = configProgramPaths sandboxConfigFlags                              `mappend` configProgramPaths savedFlags,         configProgramArgs  = configProgramArgs sandboxConfigFlags-                             `mappend` configProgramArgs savedFlags-        -- NOTE: We don't touch the @configPackageDBs@ field because-        -- @sandboxConfigFlags@ contains the sandbox location which was set when-        -- creating @cabal.sandbox.config@.+                             `mappend` configProgramArgs savedFlags,+        -- NOTE: Unconditionally choosing the value from+        -- 'dist/setup-config'. Sandbox package DB location may have been+        -- changed by 'configure -w'.+        configPackageDBs   = configPackageDBs savedFlags         -- FIXME: Is this compatible with the 'inherit' feature?         }

cabal/cabal-install/Distribution/Client/Sandbox/Index.hs view

@@ -22,6 +22,7 @@ import Distribution.Client.IndexUtils ( BuildTreeRefType(..)                                       , refTypeFromTypeCode                                       , typeCodeFromRefType+                                      , updatePackageIndexCacheFile                                       , getSourcePackagesStrict ) import Distribution.Client.PackageIndex ( allPackages ) import Distribution.Client.Types ( Repo(..), LocalRepo(..)@@ -29,9 +30,10 @@                                  , SourcePackage(..), PackageLocation(..) ) import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString                                  , makeAbsoluteToCwd, tryCanonicalizePath-                                 , canonicalizePathNoThrow )+                                 , canonicalizePathNoThrow+                                 , tryFindAddSourcePackageDesc  ) -import Distribution.Simple.Utils ( die, debug, tryFindPackageDesc )+import Distribution.Simple.Utils ( die, debug ) import Distribution.Verbosity    ( Verbosity )  import qualified Data.ByteString.Lazy as BS@@ -42,7 +44,8 @@ import System.Directory          ( createDirectoryIfMissing,                                    doesDirectoryExist, doesFileExist,                                    renameFile )-import System.FilePath           ( (</>), (<.>), takeDirectory, takeExtension )+import System.FilePath           ( (</>), (<.>), takeDirectory, takeExtension+                                 , replaceExtension ) import System.IO                 ( IOMode(..), SeekMode(..)                                  , hSeek, withBinaryFile ) @@ -61,7 +64,7 @@   dirExists <- doesDirectoryExist dir   unless dirExists $     die $ "directory '" ++ dir ++ "' does not exist"-  _ <- tryFindPackageDesc dir+  _ <- tryFindAddSourcePackageDesc dir "Error adding source reference."   return . Just $ BuildTreeRef refType dir  -- | Given a tar archive entry, try to parse it as a local build tree reference.@@ -149,6 +152,8 @@       hSeek h AbsoluteSeek (fromIntegral offset)       BS.hPut h (Tar.write entries)       debug verbosity $ "Successfully appended to '" ++ path ++ "'"+    updatePackageIndexCacheFile verbosity path+      (path `replaceExtension` "cache")  -- | Remove given local build tree references from the index. removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO [FilePath]@@ -163,10 +168,10 @@   -- much smaller.   BS.writeFile tmpFile . Tar.writeEntries . Tar.filterEntries (p l) . Tar.read     =<< BS.readFile path-  -- This invalidates the cache, so we don't have to update it explicitly.   renameFile tmpFile path   debug verbosity $ "Successfully renamed '" ++ tmpFile     ++ "' to '" ++ path ++ "'"+  updatePackageIndexCacheFile verbosity path (path `replaceExtension` "cache")   -- FIXME: return only the refs that vere actually removed.   return l     where

cabal/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Sandbox.PackageEnvironment@@ -10,7 +11,6 @@  module Distribution.Client.Sandbox.PackageEnvironment (     PackageEnvironment(..)-  , IncludeComments(..)   , PackageEnvironmentType(..)   , classifyPackageEnvironment   , createPackageEnvironmentFile@@ -19,6 +19,7 @@   , showPackageEnvironment   , showPackageEnvironmentWithComments   , setPackageDB+  , sandboxPackageDBPath   , loadUserConfig    , basePackageEnvironment@@ -30,33 +31,39 @@  import Distribution.Client.Config      ( SavedConfig(..), commentSavedConfig                                        , loadConfig, configFieldDescriptions-                                       , installDirsFields, defaultCompiler )+                                       , haddockFlagsFields+                                       , 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.Simple.Command     ( ShowOrParseArgs(..), viewAsFieldDescr )+import Distribution.Utils.NubList            ( toNubList ) import Distribution.Simple.Compiler    ( Compiler, PackageDB(..)-                                       , compilerFlavor, showCompilerId )+                                       , compilerFlavor, showCompilerIdWithAbi ) import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate                                        , defaultInstallDirs, combineInstallDirs                                        , fromPathTemplate, toPathTemplate )-import Distribution.Simple.Program     ( defaultProgramConfiguration )-import Distribution.Simple.Setup       ( Flag(..), ConfigFlags(..)-                                       , programConfigurationOptions+import Distribution.Simple.Setup       ( Flag(..)+                                       , ConfigFlags(..), HaddockFlags(..)                                        , fromFlagOrDefault, toFlag, flagToMaybe )-import Distribution.Simple.Utils       ( die, info, notice, warn, lowercase )+import Distribution.Simple.Utils       ( die, info, notice, warn ) import Distribution.ParseUtils         ( FieldDescr(..), ParseResult(..)-                                       , commaListField+                                       , commaListField, commaNewLineListField                                        , liftField, lineNo, locatedErrorMsg                                        , parseFilePathQ, readFields-                                       , showPWarning, simpleField, syntaxError )+                                       , showPWarning, simpleField+                                       , syntaxError, warning ) import Distribution.System             ( Platform ) import Distribution.Verbosity          ( Verbosity, normal ) import Control.Monad                   ( foldM, liftM2, when, unless ) import Data.List                       ( partition ) import Data.Maybe                      ( isJust )+#if !MIN_VERSION_base(4,8,0) import Data.Monoid                     ( Monoid(..) )+#endif import Distribution.Compat.Exception   ( catchIO ) import System.Directory                ( doesDirectoryExist, doesFileExist                                        , renameFile )@@ -197,25 +204,36 @@        savedUserInstallDirs   = installDirs,        savedGlobalInstallDirs = installDirs,        savedGlobalFlags = (savedGlobalFlags initialConfig) {-          globalLocalRepos = [sandboxDir </> "packages"]+          globalLocalRepos = toNubList [sandboxDir </> "packages"]           },        savedConfigureFlags = setPackageDB sandboxDir compiler platform                              (savedConfigureFlags initialConfig),        savedInstallFlags = (savedInstallFlags initialConfig) {-         installSummaryFile = [toPathTemplate (sandboxDir </>+         installSummaryFile = toNubList [toPathTemplate (sandboxDir </>                                                "logs" </> "build.log")]          }        }     } +-- | Return the path to the sandbox package database.+sandboxPackageDBPath :: FilePath -> Compiler -> Platform -> String+sandboxPackageDBPath sandboxDir compiler platform =+    sandboxDir+         </> (Text.display platform ++ "-"+             ++ showCompilerIdWithAbi compiler+             ++ "-packages.conf.d")+-- The path in sandboxPackageDBPath should be kept in sync with the+-- path in the bootstrap.sh which is used to bootstrap cabal-install+-- into a sandbox.+ -- | Use the package DB location specific for this compiler. setPackageDB :: FilePath -> Compiler -> Platform -> ConfigFlags -> ConfigFlags setPackageDB sandboxDir compiler platform configFlags =   configFlags {-    configPackageDBs = [Just (SpecificPackageDB $ sandboxDir-                              </> (Text.display platform ++ "-"-                                   ++ showCompilerId compiler-                                   ++ "-packages.conf.d"))]+    configPackageDBs = [Just (SpecificPackageDB $ sandboxPackageDBPath+                                                      sandboxDir+                                                      compiler+                                                      platform)]     }  -- | Almost the same as 'savedConf `mappend` pkgEnv', but some settings are@@ -258,7 +276,7 @@   case (pkgEnvInherit pkgEnv) of     NoFlag                -> return mempty     confPathFlag@(Flag _) -> do-      conf <- loadConfig verbosity confPathFlag NoFlag+      conf <- loadConfig verbosity confPathFlag       return $ mempty { pkgEnvSavedConfig = conf }  -- | Load the user package environment if it exists (the optional "cabal.config"@@ -266,7 +284,7 @@ userPackageEnvironment :: Verbosity -> FilePath -> IO PackageEnvironment userPackageEnvironment verbosity pkgEnvDir = do   let path = pkgEnvDir </> userPackageEnvironmentFile-  minp <- readPackageEnvironmentFile mempty path+  minp <- readPackageEnvironmentFile ConstraintSourceUserConfig mempty path   case minp of     Nothing -> return mempty     Just (ParseOk warns parseResult) -> do@@ -309,11 +327,13 @@                                         -> IO (FilePath, PackageEnvironment) tryLoadSandboxPackageEnvironmentFile verbosity pkgEnvFile configFileFlag = do   let pkgEnvDir = takeDirectory pkgEnvFile-  minp   <- readPackageEnvironmentFile mempty pkgEnvFile+  minp   <- readPackageEnvironmentFile+            (ConstraintSourceSandboxConfig pkgEnvFile) mempty pkgEnvFile   pkgEnv <- handleParseResult verbosity pkgEnvFile minp    -- Get the saved sandbox directory.-  -- TODO: Use substPathTemplate with compilerTemplateEnv ++ platformTemplateEnv.+  -- TODO: Use substPathTemplate with+  -- compilerTemplateEnv ++ platformTemplateEnv ++ abiTemplateEnv.   let sandboxDir = fromFlagOrDefault defaultSandboxLocation                    . fmap fromPathTemplate . prefix . savedUserInstallDirs                    . pkgEnvSavedConfig $ pkgEnv@@ -331,8 +351,7 @@   inherited <- inheritedPackageEnvironment verbosity user    -- Layer the package environment settings over settings from ~/.cabal/config.-  cabalConfig <- fmap unsetSymlinkBinDir $-                 loadConfig verbosity configFileFlag NoFlag+  cabalConfig <- fmap unsetSymlinkBinDir $ loadConfig verbosity configFileFlag   return (sandboxDir,           updateInstallDirs $           (base `mappend` (toPkgEnv cabalConfig) `mappend`@@ -363,35 +382,27 @@              }           } --- | Should the generated package environment file include comments?-data IncludeComments = IncludeComments | NoComments- -- | Create a new package environment file, replacing the existing one if it -- exists. Note that the path parameters should point to existing directories. createPackageEnvironmentFile :: Verbosity -> FilePath -> FilePath-                                -> IncludeComments                                 -> Compiler                                 -> Platform                                 -> IO ()-createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile incComments-  compiler platform = do-  notice verbosity $ "Writing a default package environment file to "-    ++ pkgEnvFile--  commentPkgEnv <- commentPackageEnvironment sandboxDir+createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile compiler platform = do+  notice verbosity $ "Writing a default package environment file to " ++ pkgEnvFile   initialPkgEnv <- initialPackageEnvironment sandboxDir compiler platform-  writePackageEnvironmentFile pkgEnvFile incComments commentPkgEnv initialPkgEnv+  writePackageEnvironmentFile pkgEnvFile initialPkgEnv  -- | Descriptions of all fields in the package environment file.-pkgEnvFieldDescrs :: [FieldDescr PackageEnvironment]-pkgEnvFieldDescrs = [+pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]+pkgEnvFieldDescrs src = [   simpleField "inherit"     (fromFlagOrDefault Disp.empty . fmap Disp.text) (optional parseFilePathQ)     pkgEnvInherit (\v pkgEnv -> pkgEnv { pkgEnvInherit = v })      -- FIXME: Should we make these fields part of ~/.cabal/config ?-  , commaListField "constraints"-    Text.disp Text.parse+  , commaNewLineListField "constraints"+    (Text.disp . fst) ((\pc -> (pc, src)) `fmap` Text.parse)     (configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig)     (\v pkgEnv -> updateConfigureExFlags pkgEnv                   (\flags -> flags { configExConstraints = v }))@@ -403,22 +414,13 @@                   (\flags -> flags { configPreferences = v }))   ]   ++ map toPkgEnv configFieldDescriptions'-  ++ map toPkgEnv programOptionsFields   where     optional = Parse.option mempty . fmap toFlag      configFieldDescriptions' :: [FieldDescr SavedConfig]     configFieldDescriptions' = filter       (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint")-      configFieldDescriptions--    programOptionsFields :: [FieldDescr SavedConfig]-    programOptionsFields =-      map viewAsFieldDescr $-      programConfigurationOptions defaultProgramConfiguration ParseArgs-      (configProgramArgs . savedConfigureFlags)-      (\v cfg -> cfg { savedConfigureFlags =-                          (savedConfigureFlags cfg) { configProgramArgs = v } })+      (configFieldDescriptions src)      toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment     toPkgEnv fieldDescr =@@ -437,11 +439,11 @@       }  -- | Read the package environment file.-readPackageEnvironmentFile :: PackageEnvironment -> FilePath+readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath                               -> IO (Maybe (ParseResult PackageEnvironment))-readPackageEnvironmentFile initial file =+readPackageEnvironmentFile src initial file =   handleNotExists $-  fmap (Just . parsePackageEnvironment initial) (readFile file)+  fmap (Just . parsePackageEnvironment src initial) (readFile file)   where     handleNotExists action = catchIO action $ \ioe ->       if isDoesNotExistError ioe@@ -449,18 +451,25 @@         else ioError ioe  -- | Parse the package environment file.-parsePackageEnvironment :: PackageEnvironment -> String+parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> String                            -> ParseResult PackageEnvironment-parsePackageEnvironment initial str = do+parsePackageEnvironment src initial str = do   fields <- readFields str   let (knownSections, others) = partition isKnownSection fields   pkgEnv <- parse others   let config       = pkgEnvSavedConfig pkgEnv       installDirs0 = savedUserInstallDirs config-  -- 'install-dirs' is the only section that we care about.-  installDirs <- foldM parseSection installDirs0 knownSections+  (haddockFlags, installDirs, paths, args) <-+    foldM parseSections+    (savedHaddockFlags config, installDirs0, [], [])+    knownSections   return pkgEnv {     pkgEnvSavedConfig = config {+       savedConfigureFlags    = (savedConfigureFlags config) {+          configProgramPaths  = paths,+          configProgramArgs   = args+          },+       savedHaddockFlags      = haddockFlags,        savedUserInstallDirs   = installDirs,        savedGlobalInstallDirs = installDirs        }@@ -468,40 +477,63 @@    where     isKnownSection :: ParseUtils.Field -> Bool-    isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True-    isKnownSection _                                         = False+    isKnownSection (ParseUtils.Section _ "haddock" _ _)                 = True+    isKnownSection (ParseUtils.Section _ "install-dirs" _ _)            = True+    isKnownSection (ParseUtils.Section _ "program-locations" _ _)       = True+    isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True+    isKnownSection _                                                    = False      parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment-    parse = parseFields pkgEnvFieldDescrs initial+    parse = parseFields (pkgEnvFieldDescrs src) initial -    parseSection :: InstallDirs (Flag PathTemplate)-                    -> ParseUtils.Field-                    -> ParseResult (InstallDirs (Flag PathTemplate))-    parseSection accum (ParseUtils.Section line "install-dirs" name fs)-      | name' == "" = do accum' <- parseFields installDirsFields accum fs-                         return accum'-      | otherwise   =+    parseSections :: SectionsAccum -> ParseUtils.Field+                     -> ParseResult SectionsAccum+    parseSections accum@(h,d,p,a)+                 (ParseUtils.Section _ "haddock" name fs)+      | name == "" = do h' <- parseFields haddockFlagsFields h fs+                        return (h', d, p, a)+      | otherwise  = do+          warning "The 'haddock' section should be unnamed"+          return accum+    parseSections (h,d,p,a)+                  (ParseUtils.Section line "install-dirs" name fs)+      | name == "" = do d' <- parseFields installDirsFields d fs+                        return (h, d',p,a)+      | otherwise  =         syntaxError line $         "Named 'install-dirs' section: '" ++ name         ++ "'. Note that named 'install-dirs' sections are not allowed in the '"         ++ userPackageEnvironmentFile ++ "' file."-      where name' = lowercase name-    parseSection _accum f =-      syntaxError (lineNo f)  "Unrecognized stanza."+    parseSections accum@(h, d,p,a)+                  (ParseUtils.Section _ "program-locations" name fs)+      | name == "" = do p' <- parseFields withProgramsFields p fs+                        return (h, d, p', a)+      | otherwise  = do+          warning "The 'program-locations' section should be unnamed"+          return accum+    parseSections accum@(h, d, p, a)+                  (ParseUtils.Section _ "program-default-options" name fs)+      | name == "" = do a' <- parseFields withProgramOptionsFields a fs+                        return (h, d, p, a')+      | otherwise  = do+          warning "The 'program-default-options' section should be unnamed"+          return accum+    parseSections accum f = do+      warning $ "Unrecognized stanza on line " ++ show (lineNo f)+      return accum +-- | Accumulator type for 'parseSections'.+type SectionsAccum = (HaddockFlags, InstallDirs (Flag PathTemplate)+                     , [(String, FilePath)], [(String, [String])])+ -- | Write out the package environment file.-writePackageEnvironmentFile :: FilePath -> IncludeComments-                               -> PackageEnvironment -> PackageEnvironment-                               -> IO ()-writePackageEnvironmentFile path incComments comments pkgEnv = do+writePackageEnvironmentFile :: FilePath -> PackageEnvironment -> IO ()+writePackageEnvironmentFile path pkgEnv = do   let tmpPath = (path <.> "tmp")   writeFile tmpPath $ explanation ++ pkgEnvStr ++ "\n"   renameFile tmpPath path   where-    pkgEnvStr = case incComments of-      IncludeComments -> showPackageEnvironmentWithComments-                         (Just comments) pkgEnv-      NoComments      -> showPackageEnvironment pkgEnv+    pkgEnvStr = showPackageEnvironment pkgEnv     explanation = unlines       ["-- This is a Cabal package environment file."       ,"-- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY."@@ -520,7 +552,8 @@                                       -> PackageEnvironment                                       -> String showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $-      ppFields pkgEnvFieldDescrs mdefPkgEnv pkgEnv+      ppFields (pkgEnvFieldDescrs ConstraintSourceUnknown)+               mdefPkgEnv pkgEnv   $+$ Disp.text ""   $+$ ppSection "install-dirs" "" installDirsFields                 (fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv)

cabal/cabal-install/Distribution/Client/Sandbox/Timestamp.hs view

@@ -13,10 +13,10 @@   withRemoveTimestamps,   withUpdateTimestamps,   maybeAddCompilerTimestampRecord,-  isDepModified,   listModifiedDeps,   ) where +import Control.Exception                             (IOException) import Control.Monad                                 (filterM, forM, when) import Data.Char                                     (isSpace) import Data.List                                     (partition)@@ -32,8 +32,7 @@                                                       SDistFlags (..),                                                       defaultSDistFlags,                                                       sdistCommand)-import Distribution.Simple.Utils                     (debug, die,-                                                      tryFindPackageDesc, warn)+import Distribution.Simple.Utils                     (debug, die, warn) import Distribution.System                           (Platform) import Distribution.Text                             (display) import Distribution.Verbosity                        (Verbosity, lessVerbose,@@ -42,13 +41,13 @@                                                       orLaterVersion)  import Distribution.Client.Sandbox.Index-  (ListIgnoredBuildTreeRefs (DontListIgnored), RefTypesToList(OnlyLinks)+  (ListIgnoredBuildTreeRefs (ListIgnored), RefTypesToList(OnlyLinks)   ,listBuildTreeRefs) import Distribution.Client.SetupWrapper              (SetupScriptOptions (..),                                                       defaultSetupScriptOptions,                                                       setupWrapper)-import Distribution.Client.Utils                     (inDir, removeExistingFile,-                                                      tryCanonicalizePath)+import Distribution.Client.Utils+  (inDir, removeExistingFile, tryCanonicalizePath, tryFindAddSourcePackageDesc)  import Distribution.Compat.Exception                 (catchIO) import Distribution.Client.Compat.Time               (EpochTime, getCurTime,@@ -142,15 +141,16 @@                                    -> IO () maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile                                 compId platform = do-  buildTreeRefs <- listBuildTreeRefs verbosity DontListIgnored OnlyLinks-                                     indexFile+  let key = timestampRecordKey compId platform   withTimestampFile sandboxDir $ \timestampRecords -> do-    let key = timestampRecordKey compId platform     case lookup key timestampRecords of       Just _  -> return timestampRecords-      Nothing -> do now <- getCurTime-                    let timestamps = map (\p -> (p, now)) buildTreeRefs-                    return $ (key, timestamps):timestampRecords+      Nothing -> do+        buildTreeRefs <- listBuildTreeRefs verbosity ListIgnored OnlyLinks+                         indexFile+        now <- getCurTime+        let timestamps = map (\p -> (p, now)) buildTreeRefs+        return $ (key, timestamps):timestampRecords  -- | Given an IO action that returns a list of build tree refs, add those -- build tree refs to the timestamps file (for all compilers).@@ -214,9 +214,10 @@ -- FIXME: This function is not thread-safe because of 'inDir'. allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath] allPackageSourceFiles verbosity packageDir = inDir (Just packageDir) $ do-  pkg <- fmap (flattenPackageDescription)-         . readPackageDescription verbosity =<< tryFindPackageDesc packageDir-+  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@@ -234,13 +235,16 @@         srcs <- fmap lines . readFile $ file         mapM tryCanonicalizePath srcs -      onFailedListSources :: IO ()-      onFailedListSources = warn verbosity $+      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` (\_ -> onFailedListSources >> return [])+  ret <- doListSources `catchIO` (\e -> onFailedListSources e >> return [])   removeExistingFile file   return ret

cabal/cabal-install/Distribution/Client/Sandbox/Types.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Sandbox.Types@@ -15,7 +16,9 @@ import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import Distribution.Client.Types (SourcePackage) +#if !MIN_VERSION_base(4,8,0) import Data.Monoid+#endif import qualified Data.Set as S  -- | Are we using a sandbox?@@ -51,7 +54,7 @@   -- ^ Remaining add-source deps. Some of these may be not installed in the   -- sandbox. -  otherInstalledSandboxPackages :: !InstalledPackageIndex.PackageIndex,+  otherInstalledSandboxPackages :: !InstalledPackageIndex.InstalledPackageIndex,   -- ^ All packages installed in the sandbox. Intersection with   -- 'modifiedAddSourceDependencies' and/or 'otherAddSourceDependencies' can be   -- non-empty.

cabal/cabal-install/Distribution/Client/Setup.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Setup@@ -16,28 +17,34 @@     , configureExCommand, ConfigExFlags(..), defaultConfigExFlags                         , configureExOptions     , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)-    , testCommand, benchmarkCommand+    , replCommand, testCommand, benchmarkCommand     , installCommand, InstallFlags(..), installOptions, defaultInstallFlags     , listCommand, ListFlags(..)     , updateCommand     , upgradeCommand+    , uninstallCommand     , infoCommand, InfoFlags(..)     , fetchCommand, FetchFlags(..)     , freezeCommand, FreezeFlags(..)     , getCommand, unpackCommand, GetFlags(..)     , checkCommand+    , formatCommand     , uploadCommand, UploadFlags(..)     , reportCommand, ReportFlags(..)     , runCommand     , initCommand, IT.InitFlags(..)     , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)     , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)+    , actAsSetupCommand, ActAsSetupFlags(..)     , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)+    , execCommand, ExecFlags(..)+    , userConfigCommand, UserConfigFlags(..)      , parsePackageArgs     --TODO: stop exporting these:     , showRepo     , parseRepo+    , readRepo     ) where  import Distribution.Client.Types@@ -45,11 +52,13 @@ import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.Dependency.Types-         ( AllowNewer(..), PreSolver(..) )+         ( AllowNewer(..), PreSolver(..), ConstraintSource(..) ) import qualified Distribution.Client.Init.Types as IT          ( InitFlags(..), PackageType(..) ) import Distribution.Client.Targets          ( UserConstraint, readUserConstraint )+import Distribution.Utils.NubList+         ( NubList, toNubList, fromNubList)  import Distribution.Simple.Compiler (PackageDB) import Distribution.Simple.Program@@ -58,7 +67,8 @@ import qualified Distribution.Simple.Command as Command import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Setup-         ( ConfigFlags(..), BuildFlags(..), TestFlags(..), BenchmarkFlags(..)+         ( ConfigFlags(..), BuildFlags(..), ReplFlags+         , TestFlags(..), BenchmarkFlags(..)          , SDistFlags(..), HaddockFlags(..)          , readPackageDbList, showPackageDbList          , Flag(..), toFlag, fromFlag, flagToMaybe, flagToList@@ -71,7 +81,7 @@ import Distribution.Package          ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) import Distribution.PackageDescription-         ( RepoKind(..) )+         ( BuildType(..), RepoKind(..) ) import Distribution.Text          ( Text(..), display ) import Distribution.ReadE@@ -81,16 +91,18 @@ import Distribution.Verbosity          ( Verbosity, normal ) import Distribution.Simple.Utils-         ( wrapText )+         ( wrapText, wrapLine )  import Data.Char          ( isSpace, isAlphaNum ) import Data.List-         ( intercalate )+         ( intercalate, deleteFirstsBy ) import Data.Maybe          ( listToMaybe, maybeToList, fromMaybe )+#if !MIN_VERSION_base(4,8,0) import Data.Monoid          ( Monoid(..) )+#endif import Control.Monad          ( liftM ) import System.FilePath@@ -108,13 +120,14 @@     globalNumericVersion    :: Flag Bool,     globalConfigFile        :: Flag FilePath,     globalSandboxConfigFile :: Flag FilePath,-    globalRemoteRepos       :: [RemoteRepo],     -- ^ Available Hackage servers.+    globalRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.     globalCacheDir          :: Flag FilePath,-    globalLocalRepos        :: [FilePath],+    globalLocalRepos        :: NubList FilePath,     globalLogsDir           :: Flag FilePath,     globalWorldFile         :: Flag FilePath,     globalRequireSandbox    :: Flag Bool,-    globalIgnoreSandbox     :: Flag Bool+    globalIgnoreSandbox     :: Flag Bool,+    globalHttpTransport     :: Flag String   }  defaultGlobalFlags :: GlobalFlags@@ -129,27 +142,127 @@     globalLogsDir           = mempty,     globalWorldFile         = mempty,     globalRequireSandbox    = Flag False,-    globalIgnoreSandbox     = Flag False+    globalIgnoreSandbox     = Flag False,+    globalHttpTransport     = mempty   } -globalCommand :: CommandUI GlobalFlags-globalCommand = CommandUI {+globalCommand :: [Command action] -> CommandUI GlobalFlags+globalCommand commands = CommandUI {     commandName         = "",-    commandSynopsis     = "",-    commandUsage        = \_ ->-         "This program is the command line interface "-           ++ "to the Haskell Cabal infrastructure.\n"-      ++ "See http://www.haskell.org/cabal/ for more information.\n",+    commandSynopsis     =+         "Command line interface to the Haskell Cabal infrastructure.",+    commandUsage        = \pname ->+         "See http://www.haskell.org/cabal/ for more information.\n"+      ++ "\n"+      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",     commandDescription  = Just $ \pname ->-         "For more information about a command use:\n"-      ++ "  " ++ pname ++ " COMMAND --help\n\n"+      let+        commands' = commands ++ [commandAddAction helpCommandUI undefined]+        cmdDescs = getNormalCommandDescriptions commands'+        -- if new commands are added, we want them to appear even if they+        -- are not included in the custom listing below. Thus, we calculate+        -- the `otherCmds` list and append it under the `other` category.+        -- Alternatively, a new testcase could be added that ensures that+        -- the set of commands listed here is equal to the set of commands+        -- that are actually available.+        otherCmds = deleteFirstsBy (==) (map fst cmdDescs)+          [ "help"+          , "update"+          , "install"+          , "fetch"+          , "list"+          , "info"+          , "user-config"+          , "get"+          , "init"+          , "configure"+          , "build"+          , "clean"+          , "run"+          , "repl"+          , "test"+          , "bench"+          , "check"+          , "sdist"+          , "upload"+          , "report"+          , "freeze"+          , "haddock"+          , "hscolour"+          , "copy"+          , "register"+          , "sandbox"+          , "exec"+          ]+        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]+        align str = str ++ replicate (maxlen - length str) ' '+        startGroup n = " ["++n++"]"+        par          = ""+        addCmd n     = case lookup n cmdDescs of+                         Nothing -> ""+                         Just d -> "  " ++ align n ++ "    " ++ d+        addCmdCustom n d = case lookup n cmdDescs of -- make sure that the+                                                  -- command still exists.+                         Nothing -> ""+                         Just _ -> "  " ++ align n ++ "    " ++ d+      in+         "Commands:\n"+      ++ unlines (+        [ startGroup "global"+        , addCmd "update"+        , addCmd "install"+        , par+        , addCmd "help"+        , addCmd "info"+        , addCmd "list"+        , addCmd "fetch"+        , addCmd "user-config"+        , par+        , startGroup "package"+        , addCmd "get"+        , addCmd "init"+        , par+        , addCmd "configure"+        , addCmd "build"+        , addCmd "clean"+        , par+        , addCmd "run"+        , addCmd "repl"+        , addCmd "test"+        , addCmd "bench"+        , par+        , addCmd "check"+        , addCmd "sdist"+        , addCmd "upload"+        , addCmd "report"+        , par+        , addCmd "freeze"+        , addCmd "haddock"+        , addCmd "hscolour"+        , addCmd "copy"+        , addCmd "register"+        , par+        , startGroup "sandbox"+        , addCmd "sandbox"+        , addCmd "exec"+        , addCmdCustom "repl" "Open interpreter with access to sandbox packages."+        ] ++ if null otherCmds then [] else par+                                           :startGroup "other"+                                           :[addCmd n | n <- otherCmds])+      ++ "\n"+      ++ "For more information about a command use:\n"+      ++ "   " ++ pname ++ " COMMAND --help\n"+      ++ "or " ++ pname ++ " help COMMAND\n"+      ++ "\n"       ++ "To install Cabal packages from hackage use:\n"-      ++ "  " ++ pname ++ " install foo [--dry-run]\n\n"+      ++ "  " ++ pname ++ " install foo [--dry-run]\n"+      ++ "\n"       ++ "Occasionally you need to update the list of available packages:\n"       ++ "  " ++ pname ++ " update\n",+    commandNotes = Nothing,     commandDefaultFlags = mempty,     commandOptions      = \showOrParseArgs ->-      (case showOrParseArgs of ShowArgs -> take 6; ParseArgs -> id)+      (case showOrParseArgs of ShowArgs -> take 7; ParseArgs -> id)       [option ['V'] ["version"]          "Print version information"          globalVersion (\v flags -> flags { globalVersion = v })@@ -166,8 +279,7 @@          (reqArgFlag "FILE")        ,option [] ["sandbox-config-file"]-         "Set an alternate location for the sandbox config file \-         \(default: './cabal.sandbox.config')"+         "Set an alternate location for the sandbox config file (default: './cabal.sandbox.config')"          globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })          (reqArgFlag "FILE") @@ -181,10 +293,15 @@          globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })          trueArg +      ,option [] ["http-transport"]+         "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"+         globalConfigFile (\v flags -> flags { globalHttpTransport = v })+         (reqArgFlag "HttpTransport")+       ,option [] ["remote-repo"]          "The name and url for a remote repository"          globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })-         (reqArg' "NAME:URL" (maybeToList . readRepo) (map showRepo))+         (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))        ,option [] ["remote-repo-cache"]          "The location where downloads from all remote repos are cached"@@ -194,7 +311,7 @@       ,option [] ["local-repo"]          "The location of a local repository"          globalLocalRepos (\v flags -> flags { globalLocalRepos = v })-         (reqArg' "DIR" (\x -> [x]) id)+         (reqArg' "DIR" (\x -> toNubList [x]) fromNubList)        ,option [] ["logs-dir"]          "The location to put log files"@@ -220,7 +337,8 @@     globalLogsDir           = mempty,     globalWorldFile         = mempty,     globalRequireSandbox    = mempty,-    globalIgnoreSandbox     = mempty+    globalIgnoreSandbox     = mempty,+    globalHttpTransport     = mempty   }   mappend a b = GlobalFlags {     globalVersion           = combine globalVersion,@@ -233,7 +351,8 @@     globalLogsDir           = combine globalLogsDir,     globalWorldFile         = combine globalWorldFile,     globalRequireSandbox    = combine globalRequireSandbox,-    globalIgnoreSandbox     = combine globalIgnoreSandbox+    globalIgnoreSandbox     = combine globalIgnoreSandbox,+    globalHttpTransport     = combine globalHttpTransport   }     where combine field = field a `mappend` field b @@ -242,46 +361,81 @@   where     remoteRepos =       [ Repo (Left remote) cacheDir-      | remote <- globalRemoteRepos globalFlags+      | remote <- fromNubList $ globalRemoteRepos globalFlags       , let cacheDir = fromFlag (globalCacheDir globalFlags)                    </> remoteRepoName remote ]     localRepos =       [ Repo (Right LocalRepo) local-      | local <- globalLocalRepos globalFlags ]+      | local <- fromNubList $ globalLocalRepos globalFlags ]  -- ------------------------------------------------------------ -- * Config flags -- ------------------------------------------------------------  configureCommand :: CommandUI ConfigFlags-configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {-    commandDefaultFlags = mempty+configureCommand = c+  { commandDefaultFlags = mempty+  , commandNotes = Just $ \pname -> (case commandNotes c of+         Nothing -> ""+         Just n  -> n pname ++ "\n")+       ++ "Examples:\n"+       ++ "  " ++ pname ++ " configure\n"+       ++ "    Configure with defaults;\n"+       ++ "  " ++ pname ++ " configure --enable-tests -fcustomflag\n"+       ++ "    Configure building package including tests,\n"+       ++ "    with some package-specific flag.\n"   }+ where+  c = Cabal.configureCommand defaultProgramConfiguration  configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags] configureOptions = commandOptions configureCommand  filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags filterConfigureFlags flags cabalLibVersion-  | cabalLibVersion >= Version [1,19,2] [] = flags_latest+  | 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,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   | otherwise = flags_latest   where     -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.     flags_latest = flags        { configConstraints = [] } -    -- Cabal < 1.19.2 doesn't know about '--exact-configuration'.-    flags_1_19_1 = flags_latest { configExactConfiguration = NoFlag }+    -- Cabal < 1.23 doesn't know about '--profiling-detail'.+    flags_1_22_0 = flags_latest { configProfDetail    = NoFlag+                                , configProfLibDetail = NoFlag }++    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.+    flags_1_21_0 = flags_1_22_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)+                   , 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+                                , configStripLibs = NoFlag }     -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.     flags_1_19_0 = flags_1_19_1 { 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 = []+    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList []                                 , configInstallDirs = configInstallDirs_1_18_0}     configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }     -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.@@ -299,7 +453,7 @@ -- data ConfigExFlags = ConfigExFlags {     configCabalVersion :: Flag Version,-    configExConstraints:: [UserConstraint],+    configExConstraints:: [(UserConstraint, ConstraintSource)],     configPreferences  :: [Dependency],     configSolver       :: Flag PreSolver,     configAllowNewer   :: Flag AllowNewer@@ -316,14 +470,17 @@          liftOptions fst setFst          (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])                   . optionName) $ configureOptions  showOrParseArgs)-      ++ liftOptions snd setSnd (configureExOptions showOrParseArgs)+      ++ liftOptions snd setSnd+         (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)   }   where     setFst a (_,b) = (a,b)     setSnd b (a,_) = (a,b) -configureExOptions ::  ShowOrParseArgs -> [OptionField ConfigExFlags]-configureExOptions _showOrParseArgs =+configureExOptions :: ShowOrParseArgs+                   -> ConstraintSource+                   -> [OptionField ConfigExFlags]+configureExOptions _showOrParseArgs src =   [ option [] ["cabal-lib-version"]       ("Select which version of the Cabal lib to use to build packages "       ++ "(useful for testing).")@@ -335,8 +492,8 @@       "Specify constraints on a package (version, installed/source, flags)"       configExConstraints (\v flags -> flags { configExConstraints = v })       (reqArg "CONSTRAINT"-              (fmap (\x -> [x]) (ReadE readUserConstraint))-              (map display))+              ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)+              (map $ display . fst))    , option [] ["preference"]       "Specify preferences (soft constraints) on the version of a package"@@ -349,13 +506,14 @@   , optionSolver configSolver (\v flags -> flags { configSolver = v })    , option [] ["allow-newer"]-    "Ignore upper bounds in dependencies on some or all packages."+    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)     configAllowNewer (\v flags -> flags { configAllowNewer = v})-    (optArg "PKGS"+    (optArg allowNewerArgument      (fmap Flag allowNewerParser) (Flag AllowNewerAll)      allowNewerPrinter)    ]+  where allowNewerArgument = "DEPS"  instance Monoid ConfigExFlags where   mempty = ConfigExFlags {@@ -420,6 +578,25 @@     where combine field = field a `mappend` field b  -- ------------------------------------------------------------+-- * Repl command+-- ------------------------------------------------------------++replCommand :: CommandUI (ReplFlags, BuildExFlags)+replCommand = parent {+    commandDefaultFlags = (commandDefaultFlags parent, mempty),+    commandOptions      =+      \showOrParseArgs -> liftOptions fst setFst+                          (commandOptions parent showOrParseArgs)+                          +++                          liftOptions snd setSnd (buildExOptions showOrParseArgs)+  }+  where+    setFst a (_,b) = (a,b)+    setSnd b (a,_) = (a,b)++    parent = Cabal.replCommand defaultProgramConfiguration++-- ------------------------------------------------------------ -- * Test command -- ------------------------------------------------------------ @@ -482,6 +659,7 @@       fetchReorderGoals     :: Flag Bool,       fetchIndependentGoals :: Flag Bool,       fetchShadowPkgs       :: Flag Bool,+      fetchStrongFlags      :: Flag Bool,       fetchVerbosity :: Flag Verbosity     } @@ -495,6 +673,7 @@     fetchReorderGoals     = Flag False,     fetchIndependentGoals = Flag False,     fetchShadowPkgs       = Flag False,+    fetchStrongFlags      = Flag False,     fetchVerbosity = toFlag normal    } @@ -502,8 +681,12 @@ fetchCommand = CommandUI {     commandName         = "fetch",     commandSynopsis     = "Downloads packages for later installation.",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "fetch",+    commandUsage        = usageAlternatives "fetch" [ "[FLAGS] PACKAGES"+                                                    ],+    commandDescription  = Just $ \_ ->+          "Note that it currently is not possible to fetch the dependencies for a\n"+       ++ "package in the current directory.\n",+    commandNotes        = Nothing,     commandDefaultFlags = defaultFetchFlags,     commandOptions      = \ showOrParseArgs -> [          optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v })@@ -536,6 +719,7 @@                          fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })                          fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })                          fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })+                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })    } @@ -545,22 +729,28 @@  data FreezeFlags = FreezeFlags {       freezeDryRun           :: Flag Bool,+      freezeTests            :: Flag Bool,+      freezeBenchmarks       :: Flag Bool,       freezeSolver           :: Flag PreSolver,       freezeMaxBackjumps     :: Flag Int,       freezeReorderGoals     :: Flag Bool,       freezeIndependentGoals :: Flag Bool,       freezeShadowPkgs       :: Flag Bool,+      freezeStrongFlags      :: Flag Bool,       freezeVerbosity        :: Flag Verbosity     }  defaultFreezeFlags :: FreezeFlags defaultFreezeFlags = FreezeFlags {     freezeDryRun           = toFlag False,+    freezeTests            = toFlag False,+    freezeBenchmarks       = toFlag False,     freezeSolver           = Flag defaultSolver,     freezeMaxBackjumps     = Flag defaultMaxBackjumps,     freezeReorderGoals     = Flag False,     freezeIndependentGoals = Flag False,     freezeShadowPkgs       = Flag False,+    freezeStrongFlags      = Flag False,     freezeVerbosity        = toFlag normal    } @@ -568,8 +758,16 @@ freezeCommand = CommandUI {     commandName         = "freeze",     commandSynopsis     = "Freeze dependencies.",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "freeze",+    commandDescription  = Just $ \_ -> wrapText $+         "Calculates a valid set of dependencies and their exact versions. "+      ++ "If successful, saves the result to the file `cabal.config`.\n"+      ++ "\n"+      ++ "The package versions specified in `cabal.config` will be used for "+      ++ "any future installs.\n"+      ++ "\n"+      ++ "An existing `cabal.config` is ignored and overwritten.\n",+    commandNotes        = Nothing,+    commandUsage        = usageFlags "freeze",     commandDefaultFlags = defaultFreezeFlags,     commandOptions      = \ showOrParseArgs -> [          optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v })@@ -579,6 +777,16 @@            freezeDryRun (\v flags -> flags { freezeDryRun = v })            trueArg +       , option [] ["tests"]+           "freezing of the dependencies of any tests suites in the package description file."+           freezeTests (\v flags -> flags { freezeTests = v })+           (boolOpt [] [])++       , option [] ["benchmarks"]+           "freezing of the dependencies of any benchmarks suites in the package description file."+           freezeBenchmarks (\v flags -> flags { freezeBenchmarks = v })+           (boolOpt [] [])+        ] ++         optionSolver      freezeSolver           (\v flags -> flags { freezeSolver           = v }) :@@ -587,6 +795,7 @@                          freezeReorderGoals     (\v flags -> flags { freezeReorderGoals     = v })                          freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })                          freezeShadowPkgs       (\v flags -> flags { freezeShadowPkgs       = v })+                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })    } @@ -598,7 +807,12 @@ updateCommand = CommandUI {     commandName         = "update",     commandSynopsis     = "Updates list of known packages.",-    commandDescription  = Nothing,+    commandDescription  = Just $ \_ ->+      "For all known remote repositories, download the package list.\n",+    commandNotes        = Just $ \_ ->+      relevantConfigValuesText ["remote-repo"+                               ,"remote-repo-cache"+                               ,"local-repo"],     commandUsage        = usageFlags "update",     commandDefaultFlags = toFlag normal,     commandOptions      = \_ -> [optionVerbosity id const]@@ -629,25 +843,63 @@ checkCommand = CommandUI {     commandName         = "check",     commandSynopsis     = "Check the package for common mistakes.",-    commandDescription  = Nothing,+    commandDescription  = Just $ \_ -> wrapText $+         "Expects a .cabal package file in the current directory.\n"+      ++ "\n"+      ++ "The checks correspond to the requirements to packages on Hackage. "+      ++ "If no errors and warnings are reported, Hackage will accept this "+      ++ "package.\n",+    commandNotes        = Nothing,     commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",     commandDefaultFlags = toFlag normal,     commandOptions      = \_ -> []   } +formatCommand  :: CommandUI (Flag Verbosity)+formatCommand = CommandUI {+    commandName         = "format",+    commandSynopsis     = "Reformat the .cabal file using the standard style.",+    commandDescription  = Nothing,+    commandNotes        = Nothing,+    commandUsage        = usageAlternatives "format" ["[FILE]"],+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> []+  }++uninstallCommand  :: CommandUI (Flag Verbosity)+uninstallCommand = CommandUI {+    commandName         = "uninstall",+    commandSynopsis     = "Warn about 'uninstall' not being implemented.",+    commandDescription  = Nothing,+    commandNotes        = Nothing,+    commandUsage        = usageAlternatives "uninstall" ["PACKAGES"],+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> []+  }+ runCommand :: CommandUI (BuildFlags, BuildExFlags) runCommand = CommandUI {     commandName         = "run",-    commandSynopsis     = "Runs the compiled executable.",-    commandDescription  = Nothing,-    commandUsage        =-      \pname -> "Usage: " ++ pname-                ++ " run [FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]\n\n"-                ++ "Flags for run:",+    commandSynopsis     = "Builds and runs an executable.",+    commandDescription  = Just $ \pname -> wrapText $+         "Builds and then runs the specified executable. If no executable is "+      ++ "specified, but the package contains just one executable, that one "+      ++ "is built and executed.\n"+      ++ "\n"+      ++ "Use `" ++ pname ++ " test --show-details=streaming` to run a "+      ++ "test-suite and get its full output.\n",+    commandNotes        = Just $ \pname ->+          "Examples:\n"+       ++ "  " ++ pname ++ " run\n"+       ++ "    Run the only executable in the current package;\n"+       ++ "  " ++ pname ++ " run foo -- --fooflag\n"+       ++ "    Works similar to `./foo --fooflag`.\n",+    commandUsage        = usageAlternatives "run"+        ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],     commandDefaultFlags = mempty,     commandOptions      =       \showOrParseArgs -> liftOptions fst setFst-                          (Cabal.buildOptions progConf showOrParseArgs)+                          (commandOptions parent showOrParseArgs)                           ++                           liftOptions snd setSnd                           (buildExOptions showOrParseArgs)@@ -656,7 +908,7 @@     setFst a (_,b) = (a,b)     setSnd b (a,_) = (a,b) -    progConf = defaultProgramConfiguration+    parent = Cabal.buildCommand defaultProgramConfiguration  -- ------------------------------------------------------------ -- * Report flags@@ -679,10 +931,10 @@ reportCommand = CommandUI {     commandName         = "report",     commandSynopsis     = "Upload build reports to a remote server.",-    commandDescription  = Just $ \_ ->+    commandDescription  = Nothing,+    commandNotes        = Just $ \_ ->          "You can store your Hackage login in the ~/.cabal/config file\n",-    commandUsage        = \pname -> "Usage: " ++ pname ++ " report [FLAGS]\n\n"-      ++ "Flags for upload:",+    commandUsage        = usageAlternatives "report" ["[FLAGS]"],     commandDefaultFlags = defaultReportFlags,     commandOptions      = \_ ->       [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v })@@ -736,12 +988,18 @@ getCommand :: CommandUI GetFlags getCommand = CommandUI {     commandName         = "get",-    commandSynopsis     = "Gets a package's source code.",-    commandDescription  = Just $ \_ ->+    commandSynopsis     = "Download/Extract a package's source code (repository).",+    commandDescription  = Just $ \_ -> wrapText $           "Creates a local copy of a package's source code. By default it gets "        ++ "the source\ntarball and unpacks it in a local subdirectory. "        ++ "Alternatively, with -s it will\nget the code from the source "        ++ "repository specified by the package.\n",+    commandNotes        = Just $ \pname ->+          "Examples:\n"+       ++ "  " ++ pname ++ " get hlint\n"+       ++ "    Download the latest stable version of hlint;\n"+       ++ "  " ++ pname ++ " get lens --source-repository=head\n"+       ++ "    Download the source repository (i.e. git clone from github).\n",     commandUsage        = usagePackages "get",     commandDefaultFlags = defaultGetFlags,     commandOptions      = \_ -> [@@ -813,8 +1071,20 @@ listCommand = CommandUI {     commandName         = "list",     commandSynopsis     = "List packages matching a search string.",-    commandDescription  = Nothing,-    commandUsage        = usageFlagsOrPackages "list",+    commandDescription  = Just $ \_ -> wrapText $+         "List all packages, or all packages matching one of the search"+      ++ " strings.\n"+      ++ "\n"+      ++ "If there is a sandbox in the current directory and "+      ++ "config:ignore-sandbox is False, use the sandbox package database. "+      ++ "Otherwise, use the package database specified with --package-db. "+      ++ "If not specified, use the user package database.\n",+    commandNotes        = Just $ \pname ->+         "Examples:\n"+      ++ "  " ++ pname ++ " list pandoc\n"+      ++ "    Will find pandoc, pandoc-citeproc, pandoc-lens, ...\n",+    commandUsage        = usageAlternatives "list" [ "[FLAGS]"+                                                   , "[FLAGS] STRINGS"],     commandDefaultFlags = defaultListFlags,     commandOptions      = \_ -> [         optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })@@ -830,7 +1100,12 @@             trueArg          , option "" ["package-db"]-          "Use a given package database. May be a specific file, 'global', 'user' or 'clear'."+          (   "Append the given package database to the list of package"+           ++ " databases used (to satisfy dependencies and register into)."+           ++ " May be a specific file, 'global' or 'user'. The initial list"+           ++ " is ['global'], ['global', 'user'], or ['global', $sandbox],"+           ++ " depending on context. Use 'clear' to reset the list to empty."+           ++ " See the user guide for details.")           listPackageDBs (\v flags -> flags { listPackageDBs = v })           (reqArg' "DB" readPackageDbList showPackageDbList) @@ -871,14 +1146,24 @@ infoCommand = CommandUI {     commandName         = "info",     commandSynopsis     = "Display detailed information about a particular package.",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "info",+    commandDescription  = Just $ \_ -> wrapText $+         "If there is a sandbox in the current directory and "+      ++ "config:ignore-sandbox is False, use the sandbox package database. "+      ++ "Otherwise, use the package database specified with --package-db. "+      ++ "If not specified, use the user package database.\n",+    commandNotes        = Nothing,+    commandUsage        = usageAlternatives "info" ["[FLAGS] PACKAGES"],     commandDefaultFlags = defaultInfoFlags,     commandOptions      = \_ -> [         optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })          , option "" ["package-db"]-          "Use a given package database. May be a specific file, 'global', 'user' or 'clear'."+          (   "Append the given package database to the list of package"+           ++ " databases used (to satisfy dependencies and register into)."+           ++ " May be a specific file, 'global' or 'user'. The initial list"+           ++ " is ['global'], ['global', 'user'], or ['global', $sandbox],"+           ++ " depending on context. Use 'clear' to reset the list to empty."+           ++ " See the user guide for details.")           infoPackageDBs (\v flags -> flags { infoPackageDBs = v })           (reqArg' "DB" readPackageDbList showPackageDbList) @@ -910,6 +1195,7 @@     installReorderGoals     :: Flag Bool,     installIndependentGoals :: Flag Bool,     installShadowPkgs       :: Flag Bool,+    installStrongFlags      :: Flag Bool,     installReinstall        :: Flag Bool,     installAvoidReinstalls  :: Flag Bool,     installOverrideReinstall :: Flag Bool,@@ -917,12 +1203,15 @@     installOnly             :: Flag Bool,     installOnlyDeps         :: Flag Bool,     installRootCmd          :: Flag String,-    installSummaryFile      :: [PathTemplate],+    installSummaryFile      :: NubList PathTemplate,     installLogFile          :: Flag PathTemplate,     installBuildReports     :: Flag ReportLevel,+    installReportPlanningFailure :: Flag Bool,     installSymlinkBinDir    :: Flag FilePath,     installOneShot          :: Flag Bool,-    installNumJobs          :: Flag (Maybe Int)+    installNumJobs          :: Flag (Maybe Int),+    installRunTests         :: Flag Bool,+    installOfflineMode      :: Flag Bool   }  defaultInstallFlags :: InstallFlags@@ -934,6 +1223,7 @@     installReorderGoals    = Flag False,     installIndependentGoals= Flag False,     installShadowPkgs      = Flag False,+    installStrongFlags     = Flag False,     installReinstall       = Flag False,     installAvoidReinstalls = Flag False,     installOverrideReinstall = Flag False,@@ -944,12 +1234,16 @@     installSummaryFile     = mempty,     installLogFile         = mempty,     installBuildReports    = Flag NoReports,+    installReportPlanningFailure = Flag False,     installSymlinkBinDir   = mempty,     installOneShot         = Flag False,-    installNumJobs         = mempty+    installNumJobs         = mempty,+    installRunTests        = mempty,+    installOfflineMode     = Flag False   }   where-    docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")+    docIndexFile = toPathTemplate ("$datadir" </> "doc"+                                   </> "$arch-$os-$compiler" </> "index.html")  allowNewerParser :: ReadE AllowNewer allowNewerParser = ReadE $ \s ->@@ -973,7 +1267,7 @@   defaultMaxBackjumps :: Int-defaultMaxBackjumps = 200+defaultMaxBackjumps = 2000  defaultSolver :: PreSolver defaultSolver = Choose@@ -984,13 +1278,43 @@ installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) installCommand = CommandUI {   commandName         = "install",-  commandSynopsis     = "Installs a list of packages.",-  commandUsage        = usageFlagsOrPackages "install",-  commandDescription  = Just $ \pname ->-    let original = case commandDescription configureCommand of-          Just desc -> desc pname ++ "\n"-          Nothing   -> ""-     in original+  commandSynopsis     = "Install packages.",+  commandUsage        = usageAlternatives "install" [ "[FLAGS]"+                                                    , "[FLAGS] PACKAGES"+                                                    ],+  commandDescription  = Just $ \_ -> wrapText $+        "Installs one or more packages. By default, the installed package"+     ++ " will be registered in the user's package database or, if a sandbox"+     ++ " is present in the current directory, inside the sandbox.\n"+     ++ "\n"+     ++ "If PACKAGES are specified, downloads and installs those packages."+     ++ " Otherwise, install the package in the current directory (and/or its"+     ++ " dependencies) (there must be exactly one .cabal file in the current"+     ++ " directory).\n"+     ++ "\n"+     ++ "When using a sandbox, the flags for `install` only affect the"+     ++ " current command and have no effect on future commands. (To achieve"+     ++ " that, `configure` must be used.)\n"+     ++ " In contrast, without a sandbox, the flags to `install` are saved and"+     ++ " affect future commands such as `build` and `repl`. See the help for"+     ++ " `configure` for a list of commands being affected.\n"+     ++ "\n"+     ++ "Installed executables will by default (and without a sandbox)"+     ++ " be put into `~/.cabal/bin/`."+     ++ " If you want installed executable to be available globally, make"+     ++ " sure that the PATH environment variable contains that directory.\n"+     ++ "When using a sandbox, executables will be put into"+     ++ " `$SANDBOX/bin/` (by default: `./.cabal-sandbox/bin/`).\n"+     ++ "\n"+     ++ "When specifying --bindir, consider also specifying --datadir;"+     ++ " this way the sandbox can be deleted and the executable should"+     ++ " continue working as long as bindir and datadir are left untouched.",+  commandNotes        = Just $ \pname ->+        ( case commandNotes+               $ Cabal.configureCommand defaultProgramConfiguration+          of Just desc -> desc pname ++ "\n"+             Nothing   -> ""+        )      ++ "Examples:\n"      ++ "  " ++ pname ++ " install                 "      ++ "    Package in the current directory\n"@@ -999,7 +1323,11 @@      ++ "  " ++ pname ++ " install foo-1.0         "      ++ "    Specific version of a package\n"      ++ "  " ++ pname ++ " install 'foo < 2'       "-     ++ "    Constrained package version\n",+     ++ "    Constrained package version\n"+     ++ "  " ++ pname ++ " install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n"+     ++ "  " ++ (map (const ' ') pname)+                      ++ "                         "+     ++ "    Change installation destination\n",   commandDefaultFlags = (mempty, mempty, mempty, mempty),   commandOptions      = \showOrParseArgs ->        liftOptions get1 set1@@ -1007,7 +1335,7 @@                            , "exact-configuration"])                 . optionName) $                               configureOptions   showOrParseArgs)-    ++ liftOptions get2 set2 (configureExOptions showOrParseArgs)+    ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)     ++ liftOptions get3 set3 (installOptions     showOrParseArgs)     ++ liftOptions get4 set4 (haddockOptions     showOrParseArgs)   }@@ -1024,10 +1352,10 @@                           | descr <- optionDescr opt] }     | opt <- commandOptions Cabal.haddockCommand showOrParseArgs     , let name = optionName opt-    , name `elem` ["hoogle", "html", "html-location",-                   "executables", "internal", "css",-                   "hyperlink-source", "hscolour-css",-                   "contents-location"]+    , name `elem` ["hoogle", "html", "html-location"+                  ,"executables", "tests", "benchmarks", "all", "internal", "css"+                  ,"hyperlink-source", "hscolour-css"+                  ,"contents-location"]     ]   where     fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a@@ -1059,7 +1387,8 @@                         installMaxBackjumps     (\v flags -> flags { installMaxBackjumps     = v })                         installReorderGoals     (\v flags -> flags { installReorderGoals     = v })                         installIndependentGoals (\v flags -> flags { installIndependentGoals = v })-                        installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v }) +++                        installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v })+                        installStrongFlags      (\v flags -> flags { installStrongFlags      = v }) ++        [ option [] ["reinstall"]           "Install even if it means installing the same version again."@@ -1104,7 +1433,7 @@       , option [] ["build-summary"]           "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)"           installSummaryFile (\v flags -> flags { installSummaryFile = v })-          (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate))+          (reqArg' "TEMPLATE" (\x -> toNubList [toPathTemplate x]) (map fromPathTemplate . fromNubList))        , option [] ["build-log"]           "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)"@@ -1120,14 +1449,28 @@                                       (toFlag `fmap` parse))                           (flagToList . fmap display)) +      , option [] ["report-planning-failure"]+          "Generate build reports when the dependency solver fails. This is used by the Hackage build bot."+          installReportPlanningFailure (\v flags -> flags { installReportPlanningFailure = v })+          trueArg+       , option [] ["one-shot"]           "Do not record the packages in the world file."           installOneShot (\v flags -> flags { installOneShot = v })           (yesNoOpt showOrParseArgs) +      , option [] ["run-tests"]+          "Run package test suites during installation."+          installRunTests (\v flags -> flags { installRunTests = v })+          trueArg+       , optionNumJobs         installNumJobs (\v flags -> flags { installNumJobs = v }) +      , option [] ["offline"]+          "Don't download packages from the Internet."+          installOfflineMode (\v flags -> flags { installOfflineMode = v })+          (yesNoOpt showOrParseArgs)       ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install"                                         -- avoids           ParseArgs ->@@ -1151,15 +1494,19 @@     installReorderGoals    = mempty,     installIndependentGoals= mempty,     installShadowPkgs      = mempty,+    installStrongFlags     = mempty,     installOnly            = mempty,     installOnlyDeps        = mempty,     installRootCmd         = mempty,     installSummaryFile     = mempty,     installLogFile         = mempty,     installBuildReports    = mempty,+    installReportPlanningFailure = mempty,     installSymlinkBinDir   = mempty,     installOneShot         = mempty,-    installNumJobs         = mempty+    installNumJobs         = mempty,+    installRunTests        = mempty,+    installOfflineMode     = mempty   }   mappend a b = InstallFlags {     installDocumentation   = combine installDocumentation,@@ -1173,15 +1520,19 @@     installReorderGoals    = combine installReorderGoals,     installIndependentGoals= combine installIndependentGoals,     installShadowPkgs      = combine installShadowPkgs,+    installStrongFlags     = combine installStrongFlags,     installOnly            = combine installOnly,     installOnlyDeps        = combine installOnlyDeps,     installRootCmd         = combine installRootCmd,     installSummaryFile     = combine installSummaryFile,     installLogFile         = combine installLogFile,     installBuildReports    = combine installBuildReports,+    installReportPlanningFailure = combine installReportPlanningFailure,     installSymlinkBinDir   = combine installSymlinkBinDir,     installOneShot         = combine installOneShot,-    installNumJobs         = combine installNumJobs+    installNumJobs         = combine installNumJobs,+    installRunTests        = combine installRunTests,+    installOfflineMode     = combine installOfflineMode   }     where combine field = field a `mappend` field b @@ -1190,29 +1541,32 @@ -- ------------------------------------------------------------  data UploadFlags = UploadFlags {-    uploadCheck     :: Flag Bool,-    uploadUsername  :: Flag Username,-    uploadPassword  :: Flag Password,-    uploadVerbosity :: Flag Verbosity+    uploadCheck       :: Flag Bool,+    uploadUsername    :: Flag Username,+    uploadPassword    :: Flag Password,+    uploadPasswordCmd :: Flag [String],+    uploadVerbosity   :: Flag Verbosity   }  defaultUploadFlags :: UploadFlags defaultUploadFlags = UploadFlags {-    uploadCheck     = toFlag False,-    uploadUsername  = mempty,-    uploadPassword  = mempty,-    uploadVerbosity = toFlag normal+    uploadCheck       = toFlag False,+    uploadUsername    = mempty,+    uploadPassword    = mempty,+    uploadPasswordCmd = mempty,+    uploadVerbosity   = toFlag normal   }  uploadCommand :: CommandUI UploadFlags uploadCommand = CommandUI {     commandName         = "upload",     commandSynopsis     = "Uploads source packages to Hackage.",-    commandDescription  = Just $ \_ ->-         "You can store your Hackage login in the ~/.cabal/config file\n",+    commandDescription  = Nothing,+    commandNotes        = Just $ \_ ->+         "You can store your Hackage login in the ~/.cabal/config file\n"+      ++ relevantConfigValuesText ["username", "password"],     commandUsage        = \pname ->-         "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n"-      ++ "Flags for upload:",+         "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n",     commandDefaultFlags = defaultUploadFlags,     commandOptions      = \_ ->       [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })@@ -1233,21 +1587,28 @@         uploadPassword (\v flags -> flags { uploadPassword = v })         (reqArg' "PASSWORD" (toFlag . Password)                             (flagToList . fmap unPassword))++      ,option ['P'] ["password-command"]+        "Command to get Hackage password."+        uploadPasswordCmd (\v flags -> flags { uploadPasswordCmd = v })+        (reqArg' "PASSWORD" (Flag . words) (fromMaybe [] . flagToMaybe))       ]   }  instance Monoid UploadFlags where   mempty = UploadFlags {-    uploadCheck     = mempty,-    uploadUsername  = mempty,-    uploadPassword  = mempty,-    uploadVerbosity = mempty+    uploadCheck       = mempty,+    uploadUsername    = mempty,+    uploadPassword    = mempty,+    uploadPasswordCmd = mempty,+    uploadVerbosity   = mempty   }   mappend a b = UploadFlags {-    uploadCheck     = combine uploadCheck,-    uploadUsername  = combine uploadUsername,-    uploadPassword  = combine uploadPassword,-    uploadVerbosity = combine uploadVerbosity+    uploadCheck       = combine uploadCheck,+    uploadUsername    = combine uploadUsername,+    uploadPassword    = combine uploadPassword,+    uploadPasswordCmd = combine uploadPasswordCmd,+    uploadVerbosity   = combine uploadVerbosity   }     where combine field = field a `mappend` field b @@ -1264,19 +1625,20 @@ initCommand :: CommandUI IT.InitFlags initCommand = CommandUI {     commandName = "init",-    commandSynopsis = "Interactively create a .cabal file.",+    commandSynopsis = "Create a new .cabal package file (interactively).",     commandDescription = Just $ \_ -> wrapText $          "Cabalise a project by creating a .cabal, Setup.hs, and "-      ++ "optionally a LICENSE file.\n\n"+      ++ "optionally a LICENSE file.\n"+      ++ "\n"       ++ "Calling init with no arguments (recommended) uses an "       ++ "interactive mode, which will try to guess as much as "       ++ "possible and prompt you for the rest.  Command-line "       ++ "arguments are provided for scripting purposes. "       ++ "If you don't want interactive mode, be sure to pass "       ++ "the -n flag.\n",+    commandNotes = Nothing,     commandUsage = \pname ->-         "Usage: " ++ pname ++ " init [FLAGS]\n\n"-      ++ "Flags for init:",+         "Usage: " ++ pname ++ " init [FLAGS]\n",     commandDefaultFlags = defaultInitFlags,     commandOptions = \_ ->       [ option ['n'] ["non-interactive"]@@ -1312,7 +1674,9 @@       , option ['p'] ["package-name"]         "Name of the Cabal package to create."         IT.packageName (\v flags -> flags { IT.packageName = v })-        (reqArgFlag "PACKAGE")+        (reqArg "PACKAGE" (readP_to_E ("Cannot parse package name: "++)+                                      (toFlag `fmap` parse))+                          (flagToList . fmap display))        , option [] ["version"]         "Initial version of the package."@@ -1378,6 +1742,12 @@         (\v flags -> flags { IT.packageType = v })         (noArg (Flag IT.Executable)) +      , option [] ["main-is"]+        "Specify the main module."+        IT.mainIs+        (\v flags -> flags { IT.mainIs = v })+        (reqArgFlag "FILE")+       , option [] ["language"]         "Specify the default language."         IT.language@@ -1497,9 +1867,9 @@   commandName         = "win32selfupgrade",   commandSynopsis     = "Self-upgrade the executable on Windows",   commandDescription  = Nothing,+  commandNotes        = Nothing,   commandUsage        = \pname ->-    "Usage: " ++ pname ++ " win32selfupgrade PID PATH\n\n"-     ++ "Flags for win32selfupgrade:",+    "Usage: " ++ pname ++ " win32selfupgrade PID PATH\n",   commandDefaultFlags = defaultWin32SelfUpgradeFlags,   commandOptions      = \_ ->       [optionVerbosity win32SelfUpgradeVerbosity@@ -1517,6 +1887,47 @@     where combine field = field a `mappend` field b  -- ------------------------------------------------------------+-- * ActAsSetup flags+-- ------------------------------------------------------------++data ActAsSetupFlags = ActAsSetupFlags {+    actAsSetupBuildType :: Flag BuildType+}++defaultActAsSetupFlags :: ActAsSetupFlags+defaultActAsSetupFlags = ActAsSetupFlags {+    actAsSetupBuildType = toFlag Simple+}++actAsSetupCommand :: CommandUI ActAsSetupFlags+actAsSetupCommand = CommandUI {+  commandName         = "act-as-setup",+  commandSynopsis     = "Run as-if this was a Setup.hs",+  commandDescription  = Nothing,+  commandNotes        = Nothing,+  commandUsage        = \pname ->+    "Usage: " ++ pname ++ " act-as-setup\n",+  commandDefaultFlags = defaultActAsSetupFlags,+  commandOptions      = \_ ->+      [option "" ["build-type"]+         "Use the given build type."+         actAsSetupBuildType (\v flags -> flags { actAsSetupBuildType = v })+         (reqArg "BUILD-TYPE" (readP_to_E ("Cannot parse build type: "++)+                               (fmap toFlag parse))+                              (map display . flagToList))+      ]+}++instance Monoid ActAsSetupFlags where+  mempty      = ActAsSetupFlags {+     actAsSetupBuildType = mempty+    }+  mappend a b = ActAsSetupFlags {+    actAsSetupBuildType = combine actAsSetupBuildType+    }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------ -- * Sandbox-related flags -- ------------------------------------------------------------ @@ -1541,14 +1952,78 @@ sandboxCommand = CommandUI {   commandName         = "sandbox",   commandSynopsis     = "Create/modify/delete a sandbox.",-  commandDescription  = Nothing,-  commandUsage        = \pname ->-       "Usage: " ++ pname ++ " sandbox init\n"-    ++ "   or: " ++ pname ++ " sandbox delete\n"-    ++ "   or: " ++ pname ++ " sandbox add-source  [PATHS]\n\n"-    ++ "   or: " ++ pname ++ " sandbox hc-pkg      -- [ARGS]\n"-    ++ "   or: " ++ pname ++ " sandbox list-sources\n\n"-    ++ "Flags for sandbox:",+  commandDescription  = Just $ \pname -> concat+    [ paragraph $ "Sandboxes are isolated package databases that can be used"+      ++ " to prevent dependency conflicts that arise when many different"+      ++ " packages are installed in the same database (i.e. the user's"+      ++ " database in the home directory)."+    , paragraph $ "A sandbox in the current directory (created by"+      ++ " `sandbox init`) will be used instead of the user's database for"+      ++ " commands such as `install` and `build`. Note that (a directly"+      ++ " invoked) GHC will not automatically be aware of sandboxes;"+      ++ " only if called via appropriate " ++ pname+      ++ " commands, e.g. `repl`, `build`, `exec`."+    , paragraph $ "Currently, " ++ pname ++ " will not search for a sandbox"+      ++ " in folders above the current one, so cabal will not see the sandbox"+      ++ " if you are in a subfolder of a sandbox."+    , paragraph "Subcommands:"+    , headLine "init:"+    , indentParagraph $ "Initialize a sandbox in the current directory."+      ++ " An existing package database will not be modified, but settings"+      ++ " (such as the location of the database) can be modified this way."+    , headLine "delete:"+    , indentParagraph $ "Remove the sandbox; deleting all the packages"+      ++ " installed inside."+    , headLine "add-source:"+    , indentParagraph $ "Make one or more local packages available in the"+      ++ " sandbox. PATHS may be relative or absolute."+      ++ " Typical usecase is when you need"+      ++ " to make a (temporary) modification to a dependency: You download"+      ++ " the package into a different directory, make the modification,"+      ++ " and add that directory to the sandbox with `add-source`."+    , indentParagraph $ "Unless given `--snapshot`, any add-source'd"+      ++ " dependency that was modified since the last build will be"+      ++ " re-installed automatically."+    , headLine "delete-source:"+    , indentParagraph $ "Remove an add-source dependency; however, this will"+      ++ " not delete the package(s) that have been installed in the sandbox"+      ++ " from this dependency. You can either unregister the package(s) via"+      ++ " `" ++ pname ++ " sandbox hc-pkg unregister` or re-create the"+      ++ " sandbox (`sandbox delete; sandbox init`)."+    , headLine "list-sources:"+    , indentParagraph $ "List the directories of local packages made"+      ++ " available via `" ++ pname ++ " add-source`."+    , headLine "hc-pkg:"+    , indentParagraph $ "Similar to `ghc-pkg`, but for the sandbox package"+      ++ " database. Can be used to list specific/all packages that are"+      ++ " installed in the sandbox. For subcommands, see the help for"+      ++ " ghc-pkg. Affected by the compiler version specified by `configure`."+    ],+  commandNotes        = Just $ \pname ->+       relevantConfigValuesText ["require-sandbox"+                                ,"ignore-sandbox"]+    ++ "\n"+    ++ "Examples:\n"+    ++ "  Set up a sandbox with one local dependency, located at ../foo:\n"+    ++ "    " ++ pname ++ " sandbox init\n"+    ++ "    " ++ pname ++ " sandbox add-source ../foo\n"+    ++ "    " ++ pname ++ " install --only-dependencies\n"+    ++ "  Reset the sandbox:\n"+    ++ "    " ++ pname ++ " sandbox delete\n"+    ++ "    " ++ pname ++ " sandbox init\n"+    ++ "    " ++ pname ++ " install --only-dependencies\n"+    ++ "  List the packages in the sandbox:\n"+    ++ "    " ++ pname ++ " sandbox hc-pkg list\n"+    ++ "  Unregister the `broken` package from the sandbox:\n"+    ++ "    " ++ pname ++ " sandbox hc-pkg -- --force unregister broken\n",+  commandUsage        = usageAlternatives "sandbox"+    [ "init          [FLAGS]"+    , "delete        [FLAGS]"+    , "add-source    [FLAGS] PATHS"+    , "delete-source [FLAGS] PATHS"+    , "list-sources  [FLAGS]"+    , "hc-pkg        [FLAGS] [--] COMMAND [--] [ARGS]"+    ],    commandDefaultFlags = defaultSandboxFlags,   commandOptions      = \_ ->@@ -1581,6 +2056,114 @@     where combine field = field a `mappend` field b  -- ------------------------------------------------------------+-- * Exec Flags+-- ------------------------------------------------------------++data ExecFlags = ExecFlags {+  execVerbosity :: Flag Verbosity+}++defaultExecFlags :: ExecFlags+defaultExecFlags = ExecFlags {+  execVerbosity = toFlag normal+  }++execCommand :: CommandUI ExecFlags+execCommand = CommandUI {+  commandName         = "exec",+  commandSynopsis     = "Give a command access to the sandbox package repository.",+  commandDescription  = Just $ \pname -> wrapText $+       -- TODO: this is too GHC-focused for my liking..+       "A directly invoked GHC will not automatically be aware of any"+    ++ " sandboxes: the GHC_PACKAGE_PATH environment variable controls what"+    ++ " GHC uses. `" ++ pname ++ " exec` can be used to modify this variable:"+    ++ " COMMAND will be executed in a modified environment and thereby uses"+    ++ " the sandbox package database.\n"+    ++ "\n"+    ++ "If there is no sandbox, behaves as identity (executing COMMAND).\n"+    ++ "\n"+    ++ "Note that other " ++ pname ++ " commands change the environment"+    ++ " variable appropriately already, so there is no need to wrap those"+    ++ " in `" ++ pname ++ " exec`. But with `" ++ pname ++ " exec`, the user"+    ++ " has more control and can, for example, execute custom scripts which"+    ++ " indirectly execute GHC.\n"+    ++ "\n"+    ++ "Note that `" ++ pname ++ " repl` is different from `" ++ pname+    ++ " exec -- ghci` as the latter will not forward any additional flags"+    ++ " being defined in the local package to ghci.\n"+    ++ "\n"+    ++ "See `" ++ pname ++ " sandbox`.\n",+  commandNotes        = Just $ \pname ->+       "Examples:\n"+    ++ "  " ++ pname ++ " exec -- ghci -Wall\n"+    ++ "    Start a repl session with sandbox packages and all warnings;\n"+    ++ "  " ++ pname ++ " exec gitit -- -f gitit.cnf\n"+    ++ "    Give gitit access to the sandbox packages, and pass it a flag;\n"+    ++ "  " ++ pname ++ " exec runghc Foo.hs\n"+    ++ "    Execute runghc on Foo.hs with runghc configured to use the\n"+    ++ "    sandbox package database (if a sandbox is being used).\n",+  commandUsage        = \pname ->+       "Usage: " ++ pname ++ " exec [FLAGS] [--] COMMAND [--] [ARGS]\n",++  commandDefaultFlags = defaultExecFlags,+  commandOptions      = \_ ->+    [ optionVerbosity execVerbosity+      (\v flags -> flags { execVerbosity = v })+    ]+  }++instance Monoid ExecFlags where+  mempty = ExecFlags {+    execVerbosity = mempty+    }+  mappend a b = ExecFlags {+    execVerbosity = combine execVerbosity+    }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * UserConfig flags+-- ------------------------------------------------------------++data UserConfigFlags = UserConfigFlags {+  userConfigVerbosity :: Flag Verbosity+}++instance Monoid UserConfigFlags where+  mempty = UserConfigFlags {+    userConfigVerbosity = toFlag normal+    }+  mappend a b = UserConfigFlags {+    userConfigVerbosity = combine userConfigVerbosity+    }+    where combine field = field a `mappend` field b++userConfigCommand :: CommandUI UserConfigFlags+userConfigCommand = CommandUI {+  commandName         = "user-config",+  commandSynopsis     = "Display and update the user's global cabal configuration.",+  commandDescription  = Just $ \_ -> wrapText $+       "When upgrading cabal, the set of configuration keys and their default"+    ++ " values may change. This command provides means to merge the existing"+    ++ " config in ~/.cabal/config"+    ++ " (i.e. all bindings that are actually defined and not commented out)"+    ++ " and the default config of the new version.\n"+    ++ "\n"+    ++ "diff: Shows a pseudo-diff of the user's ~/.cabal/config file and"+    ++ " the default configuration that would be created by cabal if the"+    ++ " config file did not exist.\n"+    ++ "update: Applies the pseudo-diff to the configuration that would be"+    ++ " created by default, and write the result back to ~/.cabal/config.",++  commandNotes        = Nothing,+  commandUsage        = usageAlternatives "user-config" ["diff", "update"],+  commandDefaultFlags = mempty,+  commandOptions      = \ _ -> [+   optionVerbosity userConfigVerbosity (\v flags -> flags { userConfigVerbosity = v })+   ]+  }++-- ------------------------------------------------------------ -- * GetOpt Utils -- ------------------------------------------------------------ @@ -1612,8 +2195,9 @@                   -> (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)                   -> [OptionField flags]-optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip setsip =+optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _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@@ -1634,25 +2218,25 @@   , option [] ["shadow-installed-packages"]       "If multiple package instances of the same version are installed, treat all but one as shadowed."       getsip setsip-      trueArg+      (yesNoOpt showOrParseArgs)+  , option [] ["strong-flags"]+      "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)."+      getstrfl setstrfl+      (yesNoOpt showOrParseArgs)   ] - usageFlagsOrPackages :: String -> String -> String usageFlagsOrPackages name pname =      "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"-  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"-  ++ "Flags for " ++ name ++ ":"+  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n"  usagePackages :: String -> String -> String usagePackages name pname =-     "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"-  ++ "Flags for " ++ name ++ ":"+     "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n"  usageFlags :: String -> String -> String usageFlags name pname =-  "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"-  ++ "Flags for " ++ name ++ ":"+  "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"  --TODO: do we want to allow per-package flags? parsePackageArgs :: [String] -> Either String [Dependency]@@ -1687,11 +2271,41 @@  parseRepo :: Parse.ReadP r RemoteRepo parseRepo = do-  name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.")-  _ <- Parse.char ':'+  name   <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.")+  _      <- Parse.char ':'   uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~")-  uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr)-  return $ RemoteRepo {-    remoteRepoName = name,-    remoteRepoURI  = uri+  uri    <- maybe Parse.pfail return (parseAbsoluteURI uriStr)+  return RemoteRepo {+    remoteRepoName           = name,+    remoteRepoURI            = uri,+    remoteRepoRootKeys       = (),+    remoteRepoShouldTryHttps = False   }++-- ------------------------------------------------------------+-- * Helpers for Documentation+-- ------------------------------------------------------------++headLine :: String -> String+headLine = unlines+         . map unwords+         . wrapLine 79+         . words++paragraph :: String -> String+paragraph = (++"\n")+          . unlines+          . map unwords+          . wrapLine 79+          . words++indentParagraph :: String -> String+indentParagraph = unlines+                . map (("  "++).unwords)+                . wrapLine 77+                . words++relevantConfigValuesText :: [String] -> String+relevantConfigValuesText vs =+     "Relevant global configuration keys:\n"+  ++ concat ["  " ++ v ++ "\n" |v <- vs]

cabal/cabal-install/Distribution/Client/SetupWrapper.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.SetupWrapper@@ -28,38 +29,43 @@          , withinRange ) import Distribution.InstalledPackageInfo (installedPackageId) import Distribution.Package-         ( InstalledPackageId(..), PackageIdentifier(..),+         ( InstalledPackageId(..), PackageIdentifier(..), PackageId,            PackageName(..), Package(..), packageName          , packageVersion, Dependency(..) ) import Distribution.PackageDescription          ( GenericPackageDescription(packageDescription)          , PackageDescription(..), specVersion-         , BuildType(..), knownBuildTypes )+         , BuildType(..), knownBuildTypes, defaultRenaming ) import Distribution.PackageDescription.Parse          ( readPackageDescription ) import Distribution.Simple.Configure          ( configCompilerEx )-import Distribution.Compiler ( buildCompilerId )+import Distribution.Compiler+         ( buildCompilerId, CompilerFlavor(GHC, GHCJS) ) import Distribution.Simple.Compiler-         ( CompilerFlavor(GHC), Compiler(compilerId)-         , PackageDB(..), PackageDBStack )+         ( Compiler(compilerId), compilerFlavor, PackageDB(..), PackageDBStack ) import Distribution.Simple.PreProcess          ( runSimplePreProcessor, ppUnlit )+import Distribution.Simple.Build.Macros+         ( generatePackageVersionMacros ) import Distribution.Simple.Program          ( ProgramConfiguration, emptyProgramConfiguration-         , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram )+         , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram+         , ghcjsProgram ) import Distribution.Simple.Program.Find          ( programSearchPathAsPATHVar ) import Distribution.Simple.Program.Run          ( getEffectiveEnvironment )+import qualified Distribution.Simple.Program.Strip as Strip import Distribution.Simple.BuildPaths          ( defaultDistPref, exeExtension )+ import Distribution.Simple.Command          ( CommandUI(..), commandShowOptions ) import Distribution.Simple.Program.GHC          ( GhcMode(..), GhcOptions(..), renderGhcOptions ) import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Client.Config          ( defaultCabalDir ) import Distribution.Client.IndexUtils@@ -74,10 +80,16 @@          , copyFileVerbose, rewriteFile, intercalate ) import Distribution.Client.Utils          ( inDir, tryCanonicalizePath-         , existsAndIsMoreRecentThan, moreRecentFile )+         , existsAndIsMoreRecentThan, moreRecentFile+#if mingw32_HOST_OS+         , canonicalizePathNoThrow+#endif+         ) import Distribution.System ( Platform(..), buildPlatform ) import Distribution.Text          ( display )+import Distribution.Utils.NubList+         ( toNubListR ) import Distribution.Verbosity          ( Verbosity ) import Distribution.Compat.Exception@@ -88,25 +100,62 @@ 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 Data.List           ( foldl1' ) import Data.Maybe          ( fromMaybe, isJust )-import Data.Monoid         ( mempty ) import Data.Char           ( isSpace )+import Distribution.Client.Compat.ExecutablePath  ( getExecutablePath ) +#ifdef mingw32_HOST_OS+import Distribution.Simple.Utils+         ( withTempDirectory )++import Control.Exception   ( bracket )+import System.FilePath     ( equalFilePath, takeDirectory )+import System.Directory    ( doesDirectoryExist )+import qualified System.Win32 as Win32+#endif+ data SetupScriptOptions = SetupScriptOptions {     useCabalVersion          :: VersionRange,     useCompiler              :: Maybe Compiler,     usePlatform              :: Maybe Platform,     usePackageDB             :: PackageDBStack,-    usePackageIndex          :: Maybe PackageIndex,+    usePackageIndex          :: Maybe InstalledPackageIndex,     useProgramConfig         :: ProgramConfiguration,     useDistPref              :: FilePath,     useLoggingHandle         :: Maybe Handle,     useWorkingDir            :: Maybe FilePath,     forceExternalSetupMethod :: Bool, +    -- | List of dependencies to use when building Setup.hs+    useDependencies :: [(InstalledPackageId, PackageId)],++    -- | Is the list of setup dependencies exclusive?+    --+    -- This is here for legacy reasons. Before the introduction of the explicit+    -- setup stanza in .cabal files we compiled Setup.hs scripts with all+    -- packages in the environment visible, but we will needed to restrict+    -- _some_ packages; in particular, we need to restrict the version of Cabal+    -- that the setup script gets linked against (this was the only "dependency+    -- constraint" that we had previously for Setup scripts).+    useDependenciesExclusive :: Bool,++    -- Used only by 'cabal clean' on Windows.+    --+    -- Note: win32 clean hack+    -------------------------+    -- On Windows, running './dist/setup/setup clean' doesn't work because the+    -- setup script will try to delete itself (which causes it to fail horribly,+    -- unlike on Linux). So we have to move the setup exe out of the way first+    -- and then delete it manually. This applies only to the external setup+    -- method.+    useWin32CleanHack        :: Bool,+     -- Used only when calling setupWrapper from parallel code to serialise     -- access to the setup cache; should be Nothing otherwise.     --@@ -129,10 +178,13 @@     usePlatform              = Nothing,     usePackageDB             = [GlobalPackageDB, UserPackageDB],     usePackageIndex          = Nothing,+    useDependencies          = [],+    useDependenciesExclusive = False,     useProgramConfig         = emptyProgramConfiguration,     useDistPref              = defaultDistPref,     useLoggingHandle         = Nothing,     useWorkingDir            = Nothing,+    useWin32CleanHack        = False,     forceExternalSetupMethod = False,     setupCacheLock           = Nothing   }@@ -174,12 +226,22 @@ -- determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod determineSetupMethod options buildType'-  | forceExternalSetupMethod options = externalSetupMethod+    -- 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+  | not (cabalVersion `withinRange`+         useCabalVersion options)    = externalSetupMethod   | isJust (useLoggingHandle options)- || buildType' == Custom             = externalSetupMethod-  | cabalVersion `withinRange`-      useCabalVersion options        = internalSetupMethod-  | otherwise                        = externalSetupMethod+    -- Forcing is done to use an external process e.g. due to parallel+    -- build concerns.+ || forceExternalSetupMethod options = selfExecSetupMethod+  | otherwise                        = internalSetupMethod  type SetupMethod = Verbosity                 -> SetupScriptOptions@@ -208,12 +270,41 @@ buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType"  -- ------------------------------------------------------------+-- * Self-Exec SetupMethod+-- ------------------------------------------------------------++selfExecSetupMethod :: SetupMethod+selfExecSetupMethod verbosity options _pkg bt mkargs = do+  let args = ["act-as-setup",+              "--build-type=" ++ display bt,+              "--"] ++ mkargs cabalVersion+  debug verbosity $ "Using self-exec internal setup method with build-type "+                 ++ show bt ++ " and args:\n  " ++ show args+  path <- getExecutablePath+  info verbosity $ unwords (path : args)+  case useLoggingHandle options of+    Nothing        -> return ()+    Just logHandle -> info verbosity $ "Redirecting build log to "+                                    ++ show logHandle++  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++-- ------------------------------------------------------------ -- * External SetupMethod -- ------------------------------------------------------------  externalSetupMethod :: SetupMethod externalSetupMethod verbosity options pkg bt mkargs = do   debug verbosity $ "Using external setup method with build-type " ++ show bt+  debug verbosity $ "Using explicit dependencies: " ++ show (useDependenciesExclusive options)   createDirectoryIfMissingVerbose verbosity True setupDir   (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse   debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion@@ -232,11 +323,12 @@   setupVersionFile = setupDir   </> "setup" <.> "version"   setupHs          = setupDir   </> "setup" <.> "hs"   setupProgFile    = setupDir   </> "setup" <.> exeExtension+  platform         = fromMaybe buildPlatform (usePlatform options)    useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make)    maybeGetInstalledPackages :: SetupScriptOptions -> Compiler-                               -> ProgramConfiguration -> IO PackageIndex+                            -> ProgramConfiguration -> IO InstalledPackageIndex   maybeGetInstalledPackages options' comp conf =     case usePackageIndex options' of       Just index -> return index@@ -376,7 +468,7 @@                         (useProgramConfig options') verbosity                       return (comp, conf)     -- Whenever we need to call configureCompiler, we also need to access the-    -- package index, so let's cache it here.+    -- package index, so let's cache it in SetupScriptOptions.     index <- maybeGetInstalledPackages options' comp conf     return (comp, conf, options' { useCompiler      = Just comp,                                    usePackageIndex  = Just index,@@ -402,8 +494,7 @@         compilerVersionString = display $                                 fromMaybe buildCompilerId                                 (fmap compilerId . useCompiler $ options')-        platformString        = display $-                                fromMaybe buildPlatform (usePlatform options')+        platformString        = display platform    -- | Look up the setup executable in the cache; update the cache if the setup   -- executable is not found.@@ -430,13 +521,17 @@                  cabalLibVersion maybeCabalLibInstalledPkgId True           createDirectoryIfMissingVerbose verbosity True setupCacheDir           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')+              cachedSetupProgFile     return cachedSetupProgFile       where         criticalSection'      = fromMaybe id                                 (fmap criticalSection $ setupCacheLock options')    -- | If the Setup.hs is out of date wrt the executable then recompile it.-  -- Currently this is GHC only. It should really be generalised.+  -- Currently this is GHC/GHCJS only. It should really be generalised.   --   compileSetupExecutable :: SetupScriptOptions                          -> Version -> Maybe InstalledPackageId -> Bool@@ -450,26 +545,48 @@       debug verbosity "Setup executable needs to be updated, compiling..."       (compiler, conf, options'') <- configureCompiler options'       let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion-      let ghcOptions = mempty {+          (program, extraOpts)+            = case compilerFlavor compiler of+                      GHCJS -> (ghcjsProgram, ["-build-runner"])+                      _     -> (ghcProgram,   ["-threaded"])+          cabalDep = maybe [] (\ipkgid -> [(ipkgid, cabalPkgid)])+                              maybeCabalLibInstalledPkgId++          -- We do a few things differently once packages opt-in and declare+          -- a custom-settup stanza. In particular we then enforce the deps+          -- specified, but also let the Setup.hs use the version macros.+          newPedanticDeps     = useDependenciesExclusive options'+          selectedDeps+            | newPedanticDeps = useDependencies options'+            | otherwise       = useDependencies options' ++ cabalDep+          addRenaming (ipid, pid) = (ipid, pid, defaultRenaming)+          cppMacrosFile = setupDir </> "setup_macros.h"+          ghcOptions = mempty {               ghcOptVerbosity       = Flag verbosity             , ghcOptMode            = Flag GhcModeMake-            , ghcOptInputFiles      = [setupHs]+            , ghcOptInputFiles      = toNubListR [setupHs]             , ghcOptOutputFile      = Flag setupProgFile             , ghcOptObjDir          = Flag setupDir             , ghcOptHiDir           = Flag setupDir             , ghcOptSourcePathClear = Flag True-            , ghcOptSourcePath      = [workingDir]+            , ghcOptSourcePath      = toNubListR [workingDir]             , ghcOptPackageDBs      = usePackageDB options''-            , ghcOptPackages        = maybe []-                                      (\ipkgid -> [(ipkgid, cabalPkgid)])-                                      maybeCabalLibInstalledPkgId+            , ghcOptHideAllPackages = Flag newPedanticDeps+            , ghcOptCabal           = Flag newPedanticDeps+            , ghcOptPackages        = toNubListR $ map addRenaming selectedDeps+            , ghcOptCppIncludes     = toNubListR [ cppMacrosFile+                                                 | newPedanticDeps ]+            , ghcOptExtra           = toNubListR extraOpts             }       let ghcCmdLine = renderGhcOptions compiler ghcOptions+      when newPedanticDeps $+        rewriteFile cppMacrosFile (generatePackageVersionMacros+                                     [ pid | (_ipid, pid) <- selectedDeps ])       case useLoggingHandle options of-        Nothing          -> runDbProgram verbosity ghcProgram conf ghcCmdLine+        Nothing          -> runDbProgram verbosity program conf ghcCmdLine          -- If build logging is enabled, redirect compiler output to the log file.-        (Just logHandle) -> do output <- getDbProgramOutput verbosity ghcProgram+        (Just logHandle) -> do output <- getDbProgramOutput verbosity program                                          conf ghcCmdLine                                hPutStr logHandle output     return setupProgFile@@ -488,12 +605,48 @@     -- working directory.     path' <- tryCanonicalizePath path -    searchpath <- programSearchPathAsPATHVar-                    (getProgramSearchPath (useProgramConfig options'))-    env        <- getEffectiveEnvironment [("PATH", Just searchpath)]+    -- 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 -    process <- runProcess path' args-                 (useWorkingDir options') env-                 Nothing (useLoggingHandle options') (useLoggingHandle options')-    exitCode <- waitForProcess process-    unless (exitCode == ExitSuccess) $ exitWith exitCode+    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

cabal/cabal-install/Distribution/Client/SrcDist.hs view

@@ -29,7 +29,7 @@ import Distribution.Simple.Program (requireProgram, simpleProgram, programPath) import Distribution.Simple.Program.Db (emptyProgramDb) import Distribution.Text ( display )-import Distribution.Verbosity (Verbosity, lessVerbose, normal)+import Distribution.Verbosity (Verbosity) import Distribution.Version   (Version(..), orLaterVersion)  import System.FilePath ((</>), (<.>))@@ -53,9 +53,6 @@     let outDir = if isOutDirectory then tmpDir else tmpDir </> tarBallName pkg         flags' = (if not needMakeArchive then flags                   else flags { sDistDirectory = Flag outDir })-                 { sDistVerbosity = Flag $ if   verbosity == normal-                                           then lessVerbose verbosity-                                           else verbosity }     unless isListSources $       createDirectoryIfMissingVerbose verbosity True outDir @@ -117,7 +114,7 @@         zipfile   = targetPref </> dir <.> "zip"     (zipProg, _) <- requireProgram verbosity zipProgram emptyProgramDb -    -- zip has an annoying habbit of updating the target rather than creating+    -- zip has an annoying habit of updating the target rather than creating     -- it from scratch. While that might sound like an optimisation, it doesn't     -- remove files already in the archive that are no longer present in the     -- uncompressed tree.

cabal/cabal-install/Distribution/Client/Tar.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- |@@ -230,7 +231,7 @@      V7Format       -- | The \"USTAR\" format is an extension of the classic V7 format. It was-     -- later standardised by POSIX. It has some restructions but is the most+     -- later standardised by POSIX. It has some restrictions but is the most      -- portable format.      --    | UstarFormat@@ -255,7 +256,7 @@ directoryPermissions  = 0o0755  isExecutable :: Permissions -> Bool-isExecutable p = testBit p 0 || testBit p 6 -- user or other exectuable+isExecutable p = testBit p 0 || testBit p 6 -- user or other executable  -- | An 'Entry' with all default values except for the file name and type. It -- uses the portable USTAR/POSIX format (see 'UstarHeader').@@ -319,7 +320,7 @@ -- -- So it's understandable but rather annoying. ----- * Tar paths use posix format (ie @\'/\'@ directory separators), irrespective+-- * Tar paths use POSIX format (ie @\'/\'@ directory separators), irrespective --   of the local path conventions. -- -- * The directory separator between the prefix and name is /not/ stored.@@ -368,7 +369,7 @@ -- | Take a sanitized path, split on directory separators and try to pack it -- into the 155 + 100 tar file name format. ----- The stragey is this: take the name-directory components in reverse order+-- The strategy is this: take the name-directory components in reverse order -- and try to fit as many components into the 100 long name area as possible. -- If all the remaining components fit in the 155 name area then we win. --@@ -484,7 +485,7 @@ -- * file names are valid -- -- These checks are from the perspective of the current OS. That means we check--- for \"@C:\blah@\" files on Windows and \"\/blah\" files on unix. For archive+-- for \"@C:\blah@\" files on Windows and \"\/blah\" files on Unix. For archive -- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the -- link target. A failure in any entry terminates the sequence of entries with -- an error.@@ -673,13 +674,11 @@                     . getBytes off len  data Partial a = Error String | Ok a+  deriving Functor  partial :: Partial a -> Either String a partial (Error msg) = Left msg partial (Ok x)      = Right x--instance Functor Partial where-    fmap          = liftM  instance Applicative Partial where     pure          = return

cabal/cabal-install/Distribution/Client/Targets.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Targets@@ -39,6 +40,7 @@    -- * User constraints   UserConstraint(..),+  userConstraintPackageName,   readUserConstraint,   userToPackageConstraint @@ -51,13 +53,16 @@ import Distribution.Client.Types          ( SourcePackage(..), PackageLocation(..), OptionalStanza(..) ) import Distribution.Client.Dependency.Types-         ( PackageConstraint(..) )+         ( PackageConstraint(..), ConstraintSource(..)+         , LabeledPackageConstraint(..) )  import qualified Distribution.Client.World as World import Distribution.Client.PackageIndex (PackageIndex) import qualified Distribution.Client.PackageIndex as PackageIndex import qualified Distribution.Client.Tar as Tar import Distribution.Client.FetchUtils+import Distribution.Client.HttpUtils ( HttpTransport(..) )+import Distribution.Client.Utils ( tryFindPackageDesc )  import Distribution.PackageDescription          ( GenericPackageDescription, FlagName(..), FlagAssignment )@@ -70,7 +75,7 @@          ( Text(..), display ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils-         ( die, warn, intercalate, tryFindPackageDesc, fromUTF8, lowercase )+         ( die, warn, intercalate, fromUTF8, lowercase, ignoreBOM )  import Data.List          ( find, nub )@@ -78,8 +83,10 @@          ( listToMaybe ) 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@@ -182,12 +189,15 @@ pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg  pkgSpecifierConstraints :: Package pkg-                        => PackageSpecifier pkg -> [PackageConstraint]-pkgSpecifierConstraints (NamedPackage _ constraints) = constraints+                        => PackageSpecifier pkg -> [LabeledPackageConstraint]+pkgSpecifierConstraints (NamedPackage _ constraints) = map toLpc constraints+  where+    toLpc pc = LabeledPackageConstraint pc ConstraintSourceUserTarget pkgSpecifierConstraints (SpecificSourcePackage pkg)  =-  [PackageConstraintVersion (packageName pkg)-                            (thisVersion (packageVersion pkg))]-+    [LabeledPackageConstraint pc ConstraintSourceUserTarget]+  where+    pc = PackageConstraintVersion (packageName pkg)+         (thisVersion (packageVersion pkg))  -- ------------------------------------------------------------ -- * Parsing and checking user targets@@ -260,7 +270,7 @@             uriScheme    = scheme,             uriAuthority = Just URIAuth { uriRegName = host }           }-          | scheme /= "http:" ->+          | scheme /= "http:" && scheme /= "https:" ->             Just (Left (UserTargetUnexpectedUriScheme targetstr))            | null host ->@@ -327,7 +337,7 @@               $ unlines                   [ "URL target not supported '" ++ name ++ "'."                   | name <- target ]-             ++ "Only 'http://' URLs are supported."+             ++ "Only 'http://' and 'https://' URLs are supported."      case [ target | UserTargetUnrecognisedUri target <- problems ] of       []     -> return ()@@ -347,16 +357,17 @@ -- resolveUserTargets :: Package pkg                    => Verbosity+                   -> HttpTransport                    -> FilePath                    -> PackageIndex pkg                    -> [UserTarget]                    -> IO [PackageSpecifier SourcePackage]-resolveUserTargets verbosity worldFile available userTargets = do+resolveUserTargets verbosity transport worldFile available userTargets = do      -- given the user targets, get a list of fully or partially resolved     -- package references     packageTargets <- mapM (readPackageTarget verbosity)-                  =<< mapM (fetchPackageTarget verbosity) . concat+                  =<< mapM (fetchPackageTarget transport verbosity) . concat                   =<< mapM (expandUserTarget worldFile) userTargets      -- users are allowed to give package names case-insensitively, so we must@@ -422,7 +433,7 @@      UserTargetLocalCabalFile file -> do       let dir = takeDirectory file-      _   <- tryFindPackageDesc dir -- just as a check+      _   <- tryFindPackageDesc dir (localPackageError dir) -- just as a check       return [ PackageTargetLocation (LocalUnpackedPackage dir) ]      UserTargetLocalTarball tarballFile ->@@ -431,6 +442,9 @@     UserTargetRemoteTarball tarballURL ->       return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ] +localPackageError :: FilePath -> String+localPackageError dir =+    "Error reading local package.\nCouldn't find .cabal file in: " ++ dir  -- ------------------------------------------------------------ -- * Fetching and reading package targets@@ -439,14 +453,15 @@  -- | Fetch any remote targets so that they can be read. ---fetchPackageTarget :: Verbosity+fetchPackageTarget :: HttpTransport+                   -> Verbosity                    -> PackageTarget (PackageLocation ())                    -> IO (PackageTarget (PackageLocation FilePath))-fetchPackageTarget verbosity target = case target of+fetchPackageTarget transport verbosity target = case target of     PackageTargetNamed      n cs ut -> return (PackageTargetNamed      n cs ut)     PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut)     PackageTargetLocation location  -> do-      location' <- fetchPackage verbosity (fmap (const Nothing) location)+      location' <- fetchPackage transport verbosity (fmap (const Nothing) location)       return (PackageTargetLocation location')  @@ -468,7 +483,8 @@     PackageTargetLocation location -> case location of        LocalUnpackedPackage dir -> do-        pkg <- readPackageDescription verbosity =<< tryFindPackageDesc dir+        pkg <- tryFindPackageDesc dir (localPackageError dir) >>=+                 readPackageDescription verbosity         return $ PackageTargetLocation $                    SourcePackage {                      packageInfoId        = packageId pkg,@@ -534,7 +550,7 @@      parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription     parsePackageDescription' content =-      case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of+      case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of         ParseOk _ pkg -> Just pkg         _             -> Nothing @@ -545,7 +561,7 @@  data PackageTargetProblem    = PackageNameUnknown   PackageName               UserTarget-   | PackageNameAmbigious PackageName [PackageName] UserTarget+   | PackageNameAmbiguous PackageName [PackageName] UserTarget   deriving Show  @@ -573,7 +589,7 @@         case disambiguatePackageName packageNameEnv pkgname of           None                 -> Left  (PackageNameUnknown                                           pkgname userTarget)-          Ambiguous   pkgnames -> Left  (PackageNameAmbigious+          Ambiguous   pkgnames -> Left  (PackageNameAmbiguous                                           pkgname pkgnames userTarget)           Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints')             where@@ -599,11 +615,11 @@                   ++ "You may need to run 'hackport update' to get the latest "                   ++ "list of available packages." -    case [ (pkg, matches) | PackageNameAmbigious pkg matches _ <- problems ] of+    case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of       []          -> return ()       ambiguities -> die $ unlines                              [    "The package name '" ++ display name-                               ++ "' is ambigious. It could be: "+                               ++ "' is ambiguous. It could be: "                                ++ intercalate ", " (map display matches)                              | (name, matches) <- ambiguities ] @@ -622,17 +638,17 @@ -- * Disambiguating package names -- ------------------------------------------------------------ -data MaybeAmbigious a = None | Unambiguous a | Ambiguous [a]+data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a]  -- | Given a package name and a list of matching names, figure out which one it -- might be referring to. If there is an exact case-sensitive match then that's -- ok. If it matches just one package case-insensitively then that's also ok. -- The only problem is if it matches multiple packages case-insensitively, in--- that case it is ambigious.+-- that case it is ambiguous. -- disambiguatePackageName :: PackageNameEnv                         -> PackageName-                        -> MaybeAmbigious PackageName+                        -> MaybeAmbiguous PackageName disambiguatePackageName (PackageNameEnv pkgNameLookup) name =     case nub (pkgNameLookup name) of       []      -> None@@ -649,7 +665,7 @@   mappend (PackageNameEnv lookupA) (PackageNameEnv lookupB) =     PackageNameEnv (\name -> lookupA name ++ lookupB name) -indexPackageNameEnv :: Package pkg => PackageIndex pkg -> PackageNameEnv+indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup   where     pkgNameLookup (PackageName name) =@@ -677,6 +693,13 @@    | UserConstraintStanzas   PackageName [OptionalStanza]   deriving (Show,Eq) +userConstraintPackageName :: UserConstraint -> PackageName+userConstraintPackageName uc = case uc of+  UserConstraintVersion   name _ -> name+  UserConstraintInstalled name   -> name+  UserConstraintSource    name   -> name+  UserConstraintFlags     name _ -> name+  UserConstraintStanzas   name _ -> name  userToPackageConstraint :: UserConstraint -> PackageConstraint -- At the moment, the types happen to be directly equivalent

cabal/cabal-install/Distribution/Client/Types.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Types@@ -14,7 +15,10 @@ module Distribution.Client.Types where  import Distribution.Package-         ( PackageName, PackageId, Package(..), PackageFixedDeps(..) )+         ( PackageName, PackageId, Package(..)+         , mkPackageKey, PackageKey, InstalledPackageId(..)+         , HasInstalledPackageId(..), PackageInstalled(..)+         , LibraryName, packageKeyLibraryName ) import Distribution.InstalledPackageInfo          ( InstalledPackageInfo ) import Distribution.PackageDescription@@ -24,11 +28,18 @@          ( mapTreeData ) import Distribution.Client.PackageIndex          ( PackageIndex )+import Distribution.Client.ComponentDeps+         ( ComponentDeps )+import qualified Distribution.Client.ComponentDeps as CD import Distribution.Version          ( VersionRange )+import Distribution.Simple.Compiler+         ( Compiler, packageKeySupported )+import Distribution.Text (display)+import qualified Distribution.InstalledPackageInfo as Info  import Data.Map (Map)-import Network.URI (URI)+import Network.URI (URI, nullURI) import Data.ByteString.Lazy (ByteString) import Control.Exception          ( SomeException )@@ -47,29 +58,32 @@ -- * Various kinds of information about packages -- ------------------------------------------------------------ --- | TODO: This is a hack to help us transition from Cabal-1.6 to 1.8.--- What is new in 1.8 is that installed packages and dependencies between--- installed packages are now identified by an opaque InstalledPackageId--- rather than a source PackageId.------ We should use simply an 'InstalledPackageInfo' here but to ease the--- transition we are temporarily using this variant where we pretend that--- installed packages still specify their deps in terms of PackageIds.+-- | Subclass of packages that have specific versioned dependencies. ----- Crucially this means that 'InstalledPackage' can be an instance of--- 'PackageFixedDeps' where as 'InstalledPackageInfo' is no longer an instance--- of that class. This means we can make 'PackageIndex'es of InstalledPackage--- where as the InstalledPackageInfo now has its own monomorphic index type.+-- 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. ---data InstalledPackage = InstalledPackage-       InstalledPackageInfo-       [PackageId]+class Package pkg => PackageFixedDeps pkg where+  depends :: pkg -> ComponentDeps [InstalledPackageId] -instance Package InstalledPackage where-  packageId (InstalledPackage pkg _) = packageId pkg-instance PackageFixedDeps InstalledPackage where-  depends (InstalledPackage _ deps) = deps+instance PackageFixedDeps InstalledPackageInfo where+  depends = CD.fromInstalled . installedDepends ++-- | In order to reuse the implementation of PackageIndex which relies on+-- 'InstalledPackageId', we need to be able to synthesize these IDs prior+-- to installation.  Eventually, we'll move to a representation of+-- 'InstalledPackageId' 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.+fakeInstalledPackageId :: PackageId -> InstalledPackageId+fakeInstalledPackageId = InstalledPackageId . (".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@@ -79,40 +93,78 @@        SourcePackage       -- package info, including repo        FlagAssignment      -- complete flag assignment for the package        [OptionalStanza]    -- list of enabled optional stanzas for the package-       [PackageId]         -- set of exact dependencies. These must be-                           -- consistent with the 'buildDepends' in the-                           -- 'PackageDescription' that you'd get by applying-                           -- the flag assignment and optional stanzas.+       (ComponentDeps [ConfiguredId])+                           -- set of exact dependencies (installed or source).+                           -- These must be consistent with the 'buildDepends'+                           -- in the 'PackageDescription' that you'd get by+                           -- applying the flag assignment and optional stanzas.   deriving Show +-- | A ConfiguredId is a package ID for a configured package.+--+-- Once we configure a source package we know it's InstalledPackageId+-- (at least, in principle, even if we have to fake it currently). It is still+-- however useful in lots of places to also know the source ID for the package.+-- We therefore bundle the two.+--+-- 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 InstalledPackageIds?+data ConfiguredId = ConfiguredId {+    confSrcId  :: PackageId+  , confInstId :: InstalledPackageId+  }++instance Show ConfiguredId where+  show = show . confSrcId+ instance Package ConfiguredPackage where   packageId (ConfiguredPackage pkg _ _ _) = packageId pkg  instance PackageFixedDeps ConfiguredPackage where-  depends (ConfiguredPackage _ _ _ deps) = deps+  depends (ConfiguredPackage _ _ _ deps) = fmap (map confInstId) deps +instance HasInstalledPackageId ConfiguredPackage where+  installedPackageId = fakeInstalledPackageId . packageId+ -- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be -- installed already, hence itself ready to be installed.-data ReadyPackage = ReadyPackage-       SourcePackage           -- see 'ConfiguredPackage'.-       FlagAssignment          ---       [OptionalStanza]        ---       [InstalledPackageInfo]  -- Installed dependencies.-  deriving Show+data GenericReadyPackage srcpkg ipkg+   = ReadyPackage+       srcpkg                  -- see 'ConfiguredPackage'.+       (ComponentDeps [ipkg])  -- Installed dependencies.+  deriving (Eq, Show) -instance Package ReadyPackage where-  packageId (ReadyPackage pkg _ _ _) = packageId pkg+type ReadyPackage = GenericReadyPackage ConfiguredPackage InstalledPackageInfo -instance PackageFixedDeps ReadyPackage where-  depends (ReadyPackage _ _ _ deps) = map packageId deps+instance Package srcpkg => Package (GenericReadyPackage srcpkg ipkg) where+  packageId (ReadyPackage srcpkg _deps) = packageId srcpkg --- | Sometimes we need to convert a 'ReadyPackage' back to a--- 'ConfiguredPackage'. For example, a failed 'PlanPackage' can be *either*--- Ready or Configured.-readyPackageToConfiguredPackage :: ReadyPackage -> ConfiguredPackage-readyPackageToConfiguredPackage (ReadyPackage srcpkg flags stanzas deps) =-  ConfiguredPackage srcpkg flags stanzas (map packageId deps)+instance (Package srcpkg, HasInstalledPackageId ipkg) =>+         PackageFixedDeps (GenericReadyPackage srcpkg ipkg) where+  depends (ReadyPackage _ deps) = fmap (map installedPackageId) deps +instance HasInstalledPackageId srcpkg =>+         HasInstalledPackageId (GenericReadyPackage srcpkg ipkg) where+  installedPackageId (ReadyPackage pkg _) = installedPackageId pkg+++-- | Extracts a package key from ReadyPackage, a common operation needed+-- to calculate build paths.+readyPackageKey :: Compiler -> ReadyPackage -> PackageKey+readyPackageKey comp (ReadyPackage pkg deps) =+    mkPackageKey (packageKeySupported comp) (packageId pkg)+                 (map Info.libraryName (CD.nonSetupDeps deps))++-- | Extracts a library name from ReadyPackage, a common operation needed+-- to calculate build paths.+readyLibraryName :: Compiler -> ReadyPackage -> LibraryName+readyLibraryName comp ready@(ReadyPackage pkg _) =+    packageKeyLibraryName (packageId pkg) (readyPackageKey comp ready)++ -- | A package description along with the location of the package sources. -- data SourcePackage = SourcePackage {@@ -172,24 +224,34 @@ --TODO: --  * add support for darcs and other SCM style remote repos with a local cache --  | ScmPackage-  deriving Show--instance Functor PackageLocation where-  fmap _ (LocalUnpackedPackage dir)      = LocalUnpackedPackage dir-  fmap _ (LocalTarballPackage  file)     = LocalTarballPackage  file-  fmap f (RemoteTarballPackage uri x)    = RemoteTarballPackage uri    (f x)-  fmap f (RepoTarballPackage repo pkg x) = RepoTarballPackage repo pkg (f x)-+  deriving (Show, Functor)  data LocalRepo = LocalRepo   deriving (Show,Eq) -data RemoteRepo = RemoteRepo {-    remoteRepoName :: String,-    remoteRepoURI  :: URI-  }-  deriving (Show,Eq)+data RemoteRepo =+    RemoteRepo {+      remoteRepoName     :: String,+      remoteRepoURI      :: URI,+      remoteRepoRootKeys :: (), +      -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a+      -- special case we may know a repo supports both and want to try HTTPS+      -- if we can, but still allow falling back to HTTP.+      --+      -- This field is not currently stored in the config file, but is filled+      -- in automagically for known repos.+      remoteRepoShouldTryHttps :: Bool+    }++  -- FIXME: discuss this type some more.++  deriving (Show,Eq,Ord)++-- | Construct a partial 'RemoteRepo' value to fold the field parser list over.+emptyRemoteRepo :: String -> RemoteRepo+emptyRemoteRepo name = RemoteRepo name nullURI () False+ data Repo = Repo {     repoKind     :: Either RemoteRepo LocalRepo,     repoLocalDir :: FilePath@@ -201,7 +263,8 @@ -- ------------------------------------------------------------  type BuildResult  = Either BuildFailure BuildSuccess-data BuildFailure = DependentFailed PackageId+data BuildFailure = PlanningFailed+                  | DependentFailed PackageId                   | DownloadFailed  SomeException                   | UnpackFailed    SomeException                   | ConfigureFailed SomeException

cabal/cabal-install/Distribution/Client/Update.hs view

@@ -15,21 +15,16 @@     ) where  import Distribution.Client.Types-         ( Repo(..), RemoteRepo(..), LocalRepo(..), SourcePackageDb(..) )+         ( Repo(..), RemoteRepo(..), LocalRepo(..) ) import Distribution.Client.HttpUtils-         ( DownloadResult(..) )+         ( DownloadResult(..), HttpTransport(..) ) import Distribution.Client.FetchUtils          ( downloadIndex )-import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Client.IndexUtils-         ( getSourcePackages, updateRepoIndexCache )-import qualified Paths_cabal_install-         ( version )+         ( updateRepoIndexCache )+import Distribution.Client.JobControl+         ( newParallelJobControl, spawnJob, collectJob ) -import Distribution.Package-         ( PackageName(..), packageVersion )-import Distribution.Version-         ( anyVersion, withinRange ) import Distribution.Simple.Utils          ( writeFileAtomic, warn, notice ) import Distribution.Verbosity@@ -37,49 +32,36 @@  import qualified Data.ByteString.Lazy       as BS import Distribution.Client.GZipUtils (maybeDecompress)-import qualified Data.Map as Map import System.FilePath (dropExtension)-import Data.Maybe      (fromMaybe)-import Control.Monad   (unless)+import Data.Either (lefts)  -- | 'update' downloads the package list from all known servers-update :: Verbosity -> [Repo] -> IO ()-update verbosity [] =+update :: HttpTransport -> Verbosity -> [Repo] -> IO ()+update _ verbosity [] =   warn verbosity $ "No remote package servers have been specified. Usually "                 ++ "you would have one specified in the config file."-update verbosity repos = do-  mapM_ (updateRepo verbosity) repos-  checkForSelfUpgrade verbosity repos+update transport verbosity repos = do+  jobCtrl <- newParallelJobControl+  let remoteRepos = lefts (map repoKind repos)+  case remoteRepos of+    [] -> return ()+    [remoteRepo] ->+        notice verbosity $ "Downloading the latest package list from "+                        ++ remoteRepoName remoteRepo+    _ -> notice verbosity . unlines+            $ "Downloading the latest package lists from: "+            : map (("- " ++) . remoteRepoName) remoteRepos+  mapM_ (spawnJob jobCtrl . updateRepo transport verbosity) repos+  mapM_ (\_ -> collectJob jobCtrl) repos -updateRepo :: Verbosity -> Repo -> IO ()-updateRepo verbosity repo = case repoKind repo of+updateRepo :: HttpTransport -> Verbosity -> Repo -> IO ()+updateRepo transport verbosity repo = case repoKind repo of   Right LocalRepo -> return ()   Left remoteRepo -> do-    notice verbosity $ "Downloading the latest package list from "-                    ++ remoteRepoName remoteRepo-    downloadResult <- downloadIndex verbosity remoteRepo (repoLocalDir repo)+    downloadResult <- downloadIndex transport verbosity remoteRepo (repoLocalDir repo)     case downloadResult of       FileAlreadyInCache -> return ()       FileDownloaded indexPath -> do         writeFileAtomic (dropExtension indexPath) . maybeDecompress                                                 =<< BS.readFile indexPath         updateRepoIndexCache verbosity repo--checkForSelfUpgrade :: Verbosity -> [Repo] -> IO ()-checkForSelfUpgrade verbosity repos = do-  SourcePackageDb sourcePkgIndex prefs <- getSourcePackages verbosity repos--  let self = PackageName "cabal-install"-      preferredVersionRange  = fromMaybe anyVersion (Map.lookup self prefs)-      currentVersion         = Paths_cabal_install.version-      laterPreferredVersions =-        [ packageVersion pkg-        | pkg <- PackageIndex.lookupPackageName sourcePkgIndex self-        , let version = packageVersion pkg-        , version > currentVersion-        , version `withinRange` preferredVersionRange ]--  unless (null laterPreferredVersions) $-    notice verbosity $-         "Note: there is a new version of cabal-install available.\n"-      ++ "To upgrade, run: cabal install cabal-install"

cabal/cabal-install/Distribution/Client/Upload.hs view

@@ -3,13 +3,11 @@  module Distribution.Client.Upload (check, upload, report) where -import qualified Data.ByteString.Lazy.Char8 as B (concat, length, pack, readFile, unpack)-import           Data.ByteString.Lazy.Char8 (ByteString)- import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..))-import Distribution.Client.HttpUtils (isOldHackageURI, cabalBrowse)+import Distribution.Client.HttpUtils+         ( isOldHackageURI, HttpTransport(..), remoteRepoTryUpgradeToHttps ) -import Distribution.Simple.Utils (debug, notice, warn, info)+import Distribution.Simple.Utils (notice, warn, info, die) import Distribution.Verbosity (Verbosity) import Distribution.Text (display) import Distribution.Client.Config@@ -17,25 +15,16 @@ import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import qualified Distribution.Client.BuildReports.Upload as BuildReport -import Network.Browser-         ( BrowserAction, request-         , Authority(..), addAuthority )-import Network.HTTP-         ( Header(..), HeaderName(..), findHeader-         , Request(..), RequestMethod(..), Response(..) )-import Network.TCP (HandleStream) import Network.URI (URI(uriPath), parseURI) -import Data.Char        (intToDigit)-import Numeric          (showHex) import System.IO        (hFlush, stdin, stdout, hGetEcho, hSetEcho) import Control.Exception (bracket)-import System.Random    (randomRIO)-import System.FilePath  ((</>), takeExtension, takeFileName)-import qualified System.FilePath.Posix as FilePath.Posix (combine)+import System.FilePath  ((</>), takeExtension)+import qualified System.FilePath.Posix as FilePath.Posix ((</>)) import System.Directory import Control.Monad (forM_, when) +type Auth = Maybe (String, String)  --FIXME: how do we find this path for an arbitrary hackage server? -- is it always at some fixed location relative to the server root?@@ -45,25 +34,26 @@ checkURI :: URI Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg" --upload :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO ()-upload verbosity repos mUsername mPassword paths = do-          let uploadURI = if isOldHackageURI targetRepoURI-                          then legacyUploadURI-                          else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"}-          Username username <- maybe promptUsername return mUsername-          Password password <- maybe promptPassword return mPassword-          let auth = addAuthority AuthBasic {-                       auRealm    = "Hackage",-                       auUsername = username,-                       auPassword = password,-                       auSite     = uploadURI-                     }-          flip mapM_ paths $ \path -> do-            notice verbosity $ "Uploading " ++ path ++ "... "-            handlePackage verbosity uploadURI auth path-  where-    targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given+upload :: HttpTransport -> Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO ()+upload transport verbosity repos mUsername mPassword paths = do+    targetRepo <-+      case [ remoteRepo | Left remoteRepo <- map repoKind repos ] of+        [] -> die $ "Cannot upload. No remote repositories are configured."+        rs -> remoteRepoTryUpgradeToHttps transport (last rs)+    let targetRepoURI = remoteRepoURI targetRepo+        uploadURI+          | isOldHackageURI targetRepoURI+          = legacyUploadURI+          | otherwise+          = targetRepoURI {+              uriPath = uriPath targetRepoURI FilePath.Posix.</> "upload"+            }+    Username username <- maybe promptUsername return mUsername+    Password password <- maybe promptPassword return mPassword+    let auth = Just (username,password)+    flip mapM_ paths $ \path -> do+      notice verbosity $ "Uploading " ++ path ++ "... "+      handlePackage transport verbosity uploadURI auth path  promptUsername :: IO Username promptUsername = do@@ -84,17 +74,9 @@  report :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> IO () report verbosity repos mUsername mPassword = do-      let uploadURI = if isOldHackageURI targetRepoURI-                      then legacyUploadURI-                      else targetRepoURI{uriPath = ""}       Username username <- maybe promptUsername return mUsername       Password password <- maybe promptPassword return mPassword-      let auth = addAuthority AuthBasic {-                   auRealm    = "Hackage",-                   auUsername = username,-                   auPassword = password,-                   auSite     = uploadURI-                 }+      let auth = (username,password)       forM_ repos $ \repo -> case repoKind repo of         Left remoteRepo             -> do dotCabal <- defaultCabalDir@@ -110,81 +92,23 @@                              Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME                              Right report' ->                                  do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')-                                    cabalBrowse verbosity auth $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)]+                                    BuildReport.uploadReports verbosity auth (remoteRepoURI remoteRepo) [(report', Just buildLog)]                                     return ()         Right{} -> return ()-  where-    targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given -check :: Verbosity -> [FilePath] -> IO ()-check verbosity paths = do+check :: HttpTransport -> Verbosity -> [FilePath] -> IO ()+check transport verbosity paths = do           flip mapM_ paths $ \path -> do             notice verbosity $ "Checking " ++ path ++ "... "-            handlePackage verbosity checkURI (return ()) path+            handlePackage transport verbosity checkURI Nothing path -handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream ByteString) ()+handlePackage :: HttpTransport -> Verbosity -> URI -> Auth               -> FilePath -> IO ()-handlePackage verbosity uri auth path =-  do req <- mkRequest uri path-     debug verbosity $ "\n" ++ show req-     (_,resp) <- cabalBrowse verbosity auth $ request req-     debug verbosity $ show resp-     case rspCode resp of-       (2,0,0) -> do notice verbosity "Ok"-       (x,y,z) -> do notice verbosity $ "Error: " ++ path ++ ": "-                                     ++ map intToDigit [x,y,z] ++ " "-                                     ++ rspReason resp-                     case findHeader HdrContentType resp of-                       Just contenttype-                         | takeWhile (/= ';') contenttype == "text/plain"-                         -> notice verbosity $ B.unpack $ rspBody resp-                       _ -> debug verbosity $ B.unpack $ rspBody resp--mkRequest :: URI -> FilePath -> IO (Request ByteString)-mkRequest uri path = -    do pkg <- readBinaryFile path-       boundary <- genBoundary-       let body = printMultiPart (B.pack boundary) (mkFormData path pkg)-       return $ Request {-                         rqURI = uri,-                         rqMethod = POST,-                         rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary),-                                      Header HdrContentLength (show (B.length body)),-                                      Header HdrAccept ("text/plain")],-                         rqBody = body-                        }--readBinaryFile :: FilePath -> IO ByteString-readBinaryFile = B.readFile--genBoundary :: IO String-genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer-                 return $ showHex i ""--mkFormData :: FilePath -> ByteString -> [BodyPart]-mkFormData path pkg =-  -- yes, web browsers are that stupid (re quoting)-  [BodyPart [Header hdrContentDisposition $-             "form-data; name=package; filename=\""++takeFileName path++"\"",-             Header HdrContentType "application/x-gzip"]-   pkg]--hdrContentDisposition :: HeaderName-hdrContentDisposition = HdrCustom "Content-disposition"---- * Multipart, partly stolen from the cgi package.--data BodyPart = BodyPart [Header] ByteString--printMultiPart :: ByteString -> [BodyPart] -> ByteString-printMultiPart boundary xs =-    B.concat $ map (printBodyPart boundary) xs ++ [crlf, dd, boundary, dd, crlf]--printBodyPart :: ByteString -> BodyPart -> ByteString-printBodyPart boundary (BodyPart hs c) = B.concat $ [crlf, dd, boundary, crlf] ++ map (B.pack . show) hs ++ [crlf, c]--crlf :: ByteString-crlf = B.pack "\r\n"+handlePackage transport verbosity uri auth path =+  do resp <- postHttpFile transport verbosity uri path auth+     case resp of+       (200,_)     -> do notice verbosity "Ok"+       (code,err)  -> do notice verbosity $ "Error uploading " ++ path ++ ": "+                                     ++ "http code " ++ show code ++ "\n"+                                     ++ err -dd :: ByteString-dd = B.pack "--"

cabal/cabal-install/Distribution/Client/Utils.hs view

@@ -2,17 +2,23 @@  module Distribution.Client.Utils ( MergeResult(..)                                  , mergeBy, duplicates, duplicatesBy+                                 , readMaybe                                  , inDir, determineNumJobs, numberOfProcessors                                  , removeExistingFile+                                 , withTempFileName                                  , makeAbsoluteToCwd, filePathToByteString                                  , byteStringToFilePath, tryCanonicalizePath                                  , canonicalizePathNoThrow-                                 , moreRecentFile, existsAndIsMoreRecentThan )+                                 , moreRecentFile, existsAndIsMoreRecentThan+                                 , tryFindAddSourcePackageDesc+                                 , tryFindPackageDesc+                                 , relaxEncodingErrors)        where  import Distribution.Compat.Exception   ( catchIO ) import Distribution.Client.Compat.Time ( getModTime ) import Distribution.Simple.Setup       ( Flag(..) )+import Distribution.Simple.Utils       ( die, findPackageDesc ) import qualified Data.ByteString.Lazy as BS import Control.Monad          ( when )@@ -20,20 +26,37 @@          ( (.|.), shiftL, shiftR ) import Data.Char          ( ord, chr )+#if MIN_VERSION_base(4,6,0)+import Text.Read+         ( readMaybe )+#endif import Data.List-         ( sortBy, groupBy )+         ( isPrefixOf, sortBy, groupBy ) import Data.Word          ( Word8, Word32) import Foreign.C.Types ( CInt(..) ) import qualified Control.Exception as Exception-         ( finally )+         ( finally, bracket ) import System.Directory          ( canonicalizePath, doesFileExist, getCurrentDirectory          , removeFile, setCurrentDirectory ) import System.FilePath          ( (</>), isAbsolute )+import System.IO+         ( Handle, hClose, openTempFile+#if MIN_VERSION_base(4,4,0)+         , hGetEncoding, hSetEncoding+#endif+         ) import System.IO.Unsafe ( unsafePerformIO ) +#if MIN_VERSION_base(4,4,0)+import GHC.IO.Encoding+         ( recover, TextEncoding(TextEncoding) )+import GHC.IO.Encoding.Failure+         ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) )+#endif+ #if defined(mingw32_HOST_OS) import Prelude hiding (ioError) import Control.Monad (liftM2, unless)@@ -70,6 +93,14 @@     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 ()@@ -78,6 +109,19 @@   when exists $     removeFile path +-- | A variant of 'withTempFile' that only gives us the file name, and while+-- it will clean up the file afterwards, it's lenient if the file is+-- moved\/deleted.+--+withTempFileName :: FilePath+                 -> String+                 -> (FilePath -> IO a) -> IO a+withTempFileName tmpDir template action =+  Exception.bracket+    (openTempFile tmpDir template)+    (\(name, _) -> removeExistingFile name)+    (\(name, h) -> hClose h >> action name)+ -- | Executes the action in the specified directory. inDir :: Maybe FilePath -> IO a -> IO a inDir Nothing m = m@@ -185,3 +229,36 @@   if not exists     then return False     else a `moreRecentFile` b++-- | Sets the handler for encoding errors to one that transliterates invalid+-- characters into one present in the encoding (i.e., \'?\').+-- This is opposed to the default behavior, which is to throw an exception on+-- error. This function will ignore file handles that have a Unicode encoding+-- set. It's a no-op for versions of `base` less than 4.4.+relaxEncodingErrors :: Handle -> IO ()+relaxEncodingErrors handle = do+#if MIN_VERSION_base(4,4,0)+  maybeEncoding <- hGetEncoding handle+  case maybeEncoding of+    Just (TextEncoding name decoder encoder) | not ("UTF" `isPrefixOf` name) ->+      let relax x = x { recover = recoverEncode TransliterateCodingFailure }+      in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder))+    _ ->+#endif+      return ()++-- |Like 'tryFindPackageDesc', but with error specific to add-source deps.+tryFindAddSourcePackageDesc :: FilePath -> String -> IO FilePath+tryFindAddSourcePackageDesc depPath err = tryFindPackageDesc depPath $+    err ++ "\n" ++ "Failed to read cabal file of add-source dependency: "+    ++ depPath++-- |Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be+-- found, with @err@ prefixing the error message. This function simply allows+-- us to give a more descriptive error than that provided by @findPackageDesc@.+tryFindPackageDesc :: FilePath -> String -> IO FilePath+tryFindPackageDesc depPath err = do+    errOrCabalFile <- findPackageDesc depPath+    case errOrCabalFile of+        Right file -> return file+        Left _ -> die err

+ cabal/cabal-install/Distribution/Client/Utils/LabeledGraph.hs view

@@ -0,0 +1,116 @@+-- | 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

@@ -25,7 +25,7 @@ -- -- * Move our own exe file to a new name -- * Copy a new exe file to the previous name--- * Run the new exe file, passing our own pid and new path+-- * Run the new exe file, passing our own PID and new path -- * Wait for the new process to start -- * Close the new exe file -- * Exit old process@@ -42,10 +42,9 @@     deleteOldExeFile,   ) where -#if mingw32_HOST_OS || mingw32_TARGET_OS+#if mingw32_HOST_OS  import qualified System.Win32 as Win32-import qualified System.Win32.DLL as Win32 import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR) import Foreign.Ptr (Ptr, nullPtr) import System.Process (runProcess)@@ -61,7 +60,7 @@ -- that the nested action can replace our own exe file. -- -- We require that the new process accepts a command line invocation that--- calls 'deleteOldExeFile', passing in the pid and exe file.+-- calls 'deleteOldExeFile', passing in the PID and exe file. -- possibleSelfUpgrade :: Verbosity                     -> [FilePath]@@ -87,7 +86,7 @@ -- old and new processes. We need to synchronise to make sure that the old -- process has not yet terminated by the time the new one starts up and looks -- for the old process. Otherwise the old one might have already terminated--- and we could not wait on it terminating reliably (eg the pid might get+-- and we could not wait on it terminating reliably (eg the PID might get -- re-used). -- syncEventName :: String@@ -131,7 +130,7 @@  -- | Assuming we're now in the new child process, we've been asked by the old -- process to wait for it to terminate and then we can remove the old exe file--- that it renamted itself to.+-- that it renamed itself to. -- deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () deleteOldExeFile verbosity oldPID tmpPath = do@@ -161,10 +160,16 @@  -- A bunch of functions sadly not provided by the Win32 package. -foreign import stdcall unsafe "windows.h GetCurrentProcessId"+#ifdef x86_64_HOST_ARCH+#define CALLCONV ccall+#else+#define CALLCONV stdcall+#endif++foreign import CALLCONV unsafe "windows.h GetCurrentProcessId"   getCurrentProcessId :: IO DWORD -foreign import stdcall unsafe "windows.h WaitForSingleObject"+foreign import CALLCONV unsafe "windows.h WaitForSingleObject"   waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD  waitForSingleObject :: HANDLE -> DWORD -> IO ()@@ -175,7 +180,7 @@     bad result   = not (result == 0 || result == wAIT_TIMEOUT)     wAIT_TIMEOUT = 0x00000102 -foreign import stdcall unsafe "windows.h CreateEventW"+foreign import CALLCONV unsafe "windows.h CreateEventW"   createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE  createEvent :: String -> IO HANDLE@@ -184,7 +189,7 @@     Win32.withTString name $       createEvent_ nullPtr False False -foreign import stdcall unsafe "windows.h OpenEventW"+foreign import CALLCONV unsafe "windows.h OpenEventW"   openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE  openEvent :: String -> IO HANDLE@@ -196,7 +201,7 @@     eVENT_MODIFY_STATE :: DWORD     eVENT_MODIFY_STATE = 0x0002 -foreign import stdcall unsafe "windows.h SetEvent"+foreign import CALLCONV unsafe "windows.h SetEvent"   setEvent_ :: HANDLE -> IO BOOL  setEvent :: HANDLE -> IO ()

cabal/cabal-install/Distribution/Client/World.hs view

@@ -49,8 +49,6 @@  import Data.List          ( unionBy, deleteFirstsBy, nubBy )-import Data.Maybe-         ( isJust, fromJust ) import System.IO.Error          ( isDoesNotExistError ) import qualified Data.ByteString.Lazy.Char8 as B@@ -113,9 +111,9 @@ getContents world = do   content <- safelyReadFile world   let result = map simpleParse (lines $ B.unpack content)-  if all isJust result-    then return $ map fromJust result-    else die "Could not parse world file."+  case sequence result of+    Nothing -> die "Could not parse world file."+    Just xs -> return xs   where   safelyReadFile :: FilePath -> IO B.ByteString   safelyReadFile file = B.readFile file `catchIO` handler

cabal/cabal-install/Main.hs view

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Main@@ -18,13 +20,14 @@          , ConfigFlags(..)          , ConfigExFlags(..), defaultConfigExFlags, configureExCommand          , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)-         , buildCommand, testCommand, benchmarkCommand+         , buildCommand, replCommand, testCommand, benchmarkCommand          , InstallFlags(..), defaultInstallFlags-         , installCommand, upgradeCommand+         , installCommand, upgradeCommand, uninstallCommand          , FetchFlags(..), fetchCommand          , FreezeFlags(..), freezeCommand          , GetFlags(..), getCommand, unpackCommand          , checkCommand+         , formatCommand          , updateCommand          , ListFlags(..), listCommand          , InfoFlags(..), infoCommand@@ -34,13 +37,16 @@          , InitFlags(initVerbosity), initCommand          , SDistFlags(..), SDistExFlags(..), sdistCommand          , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand+         , ActAsSetupFlags(..), actAsSetupCommand          , SandboxFlags(..), sandboxCommand+         , ExecFlags(..), execCommand+         , UserConfigFlags(..), userConfigCommand          , reportCommand          ) import Distribution.Simple.Setup-         ( HaddockFlags(..), haddockCommand+         ( HaddockFlags(..), haddockCommand, defaultHaddockFlags          , HscolourFlags(..), hscolourCommand-         , ReplFlags(..), replCommand+         , ReplFlags(..)          , CopyFlags(..), copyCommand          , RegisterFlags(..), registerCommand          , CleanFlags(..), cleanCommand@@ -52,7 +58,8 @@ import Distribution.Client.SetupWrapper          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Config-         ( SavedConfig(..), loadConfig, defaultConfigFile )+         ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff+         , userConfigUpdate ) import Distribution.Client.Targets          ( readUserTargets ) import qualified Distribution.Client.List as List@@ -61,12 +68,14 @@ import Distribution.Client.Install            (install) import Distribution.Client.Configure          (configure) import Distribution.Client.Update             (update)+import Distribution.Client.Exec               (exec) import Distribution.Client.Fetch              (fetch) import Distribution.Client.Freeze             (freeze) import Distribution.Client.Check as Check     (check) --import Distribution.Client.Clean            (clean) import Distribution.Client.Upload as Upload   (upload, check, report) import Distribution.Client.Run                (run, splitRunArgs)+import Distribution.Client.HttpUtils          (configureTransport) import Distribution.Client.SrcDist            (sdist) import Distribution.Client.Get                (get) import Distribution.Client.Sandbox            (sandboxInit@@ -79,6 +88,7 @@                                                ,getSandboxConfigFilePath                                               ,loadConfigOrSandboxConfig+                                              ,findSavedDistPref                                               ,initPackageDBIfNeeded                                               ,maybeWithSandboxDirOnSearchPath                                               ,maybeWithSandboxPackageInfo@@ -87,6 +97,7 @@                                               ,tryGetIndexFilePath                                               ,sandboxBuildDir                                               ,updateSandboxConfigFileFlag+                                              ,updateInstallDirs                                                ,configCompilerAux'                                               ,configPackageDB')@@ -95,13 +106,24 @@                                               ,userPackageEnvironmentFile) import Distribution.Client.Sandbox.Timestamp  (maybeAddCompilerTimestampRecord) import Distribution.Client.Sandbox.Types      (UseSandbox(..), whenUsingSandbox)+import Distribution.Client.Types              (Password (..)) import Distribution.Client.Init               (initCabal) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import Distribution.Client.Utils              (determineNumJobs+#if defined(mingw32_HOST_OS)+                                              ,relaxEncodingErrors+#endif                                               ,existsAndIsMoreRecentThan)  import Distribution.PackageDescription-         ( Executable(..) )+         ( BuildType(..), Executable(..), benchmarkName, benchmarkBuildInfo+         , testName, testBuildInfo, buildable )+import Distribution.PackageDescription.Parse+         ( readPackageDescription )+import Distribution.PackageDescription.PrettyPrint+         ( writeGenericPackageDescription )+import qualified Distribution.Simple as Simple+import qualified Distribution.Make as Make import Distribution.Simple.Build          ( startInterpreter ) import Distribution.Simple.Command@@ -111,13 +133,18 @@          ( Compiler(..) ) import Distribution.Simple.Configure          ( checkPersistBuildConfigOutdated, configCompilerAuxEx-         , ConfigStateFileErrorType(..), localBuildInfoFile+         , ConfigStateFileError(..), localBuildInfoFile          , getPersistBuildConfig, tryGetPersistBuildConfig ) import qualified Distribution.Simple.LocalBuildInfo as LBI-import Distribution.Simple.Program (defaultProgramConfiguration)+import Distribution.Simple.Program (defaultProgramConfiguration+                                   ,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, findPackageDesc )+         ( cabalVersion, die, notice, info, topHandler+         , findPackageDesc, tryFindPackageDesc ) import Distribution.Text          ( display ) import Distribution.Verbosity as Verbosity@@ -129,11 +156,18 @@ import System.Environment       (getArgs, getProgName) import System.Exit              (exitFailure) import System.FilePath          (splitExtension, takeExtension)-import System.IO                (BufferMode(LineBuffering),-                                 hSetBuffering, stdout)+import System.IO                ( BufferMode(LineBuffering), hSetBuffering+#ifdef mingw32_HOST_OS+                                , stderr+#endif+                                , stdout ) import System.Directory         (doesFileExist, getCurrentDirectory) import Data.List                (intercalate)+import Data.Maybe               (mapMaybe)+#if !MIN_VERSION_base(4,8,0) import Data.Monoid              (Monoid(..))+import Control.Applicative      (pure, (<$>))+#endif import Control.Monad            (when, unless)  -- | Entry point@@ -143,11 +177,18 @@   -- Enable line buffering so that we can get fast feedback even when piped.   -- This is especially important for CI and build systems.   hSetBuffering stdout LineBuffering+  -- The default locale encoding for Windows CLI is not UTF-8 and printing+  -- Unicode characters to it will fail unless we relax the handling of encoding+  -- errors when writing to stderr and stdout.+#ifdef mingw32_HOST_OS+  relaxEncodingErrors stdout+  relaxEncodingErrors stderr+#endif   getArgs >>= mainWorker  mainWorker :: [String] -> IO () mainWorker args = topHandler $-  case commandsRun globalCommand commands args of+  case commandsRun (globalCommand commands) commands args of     CommandHelp   help                 -> printGlobalHelp help     CommandList   opts                 -> printOptionsList opts     CommandErrors errs                 -> printErrors errs@@ -205,15 +246,14 @@       ,initCommand            `commandAddAction` initAction       ,configureExCommand     `commandAddAction` configureAction       ,buildCommand           `commandAddAction` buildAction-      ,replCommand defaultProgramConfiguration-                              `commandAddAction` replAction+      ,replCommand            `commandAddAction` replAction       ,sandboxCommand         `commandAddAction` sandboxAction+      ,haddockCommand         `commandAddAction` haddockAction+      ,execCommand            `commandAddAction` execAction+      ,userConfigCommand      `commandAddAction` userConfigAction+      ,cleanCommand           `commandAddAction` cleanAction       ,wrapperAction copyCommand                      copyVerbosity     copyDistPref-      ,wrapperAction haddockCommand-                     haddockVerbosity  haddockDistPref-      ,wrapperAction cleanCommand-                     cleanVerbosity    cleanDistPref       ,wrapperAction hscolourCommand                      hscolourVerbosity hscolourDistPref       ,wrapperAction registerCommand@@ -221,9 +261,15 @@       ,testCommand            `commandAddAction` testAction       ,benchmarkCommand       `commandAddAction` benchmarkAction       ,hiddenCommand $+       uninstallCommand       `commandAddAction` uninstallAction+      ,hiddenCommand $+       formatCommand          `commandAddAction` formatAction+      ,hiddenCommand $        upgradeCommand         `commandAddAction` upgradeAction       ,hiddenCommand $        win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction+      ,hiddenCommand $+       actAsSetupCommand`commandAddAction` actAsSetupAction       ]  wrapperAction :: Monoid flags@@ -233,13 +279,11 @@               -> Command (GlobalFlags -> IO ()) wrapperAction command verbosityFlag distPrefFlag =   commandAddAction command-    { commandDefaultFlags = mempty } $ \flags extraArgs _globalFlags -> do+    { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do     let verbosity = fromFlagOrDefault normal (verbosityFlag flags)-        setupScriptOptions = defaultSetupScriptOptions {-          useDistPref = fromFlagOrDefault-                          (useDistPref defaultSetupScriptOptions)-                          (distPrefFlag flags)-        }+    (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags+    distPref <- findSavedDistPref config (distPrefFlag flags)+    let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }     setupWrapper verbosity setupScriptOptions Nothing                  command (const flags) extraArgs @@ -248,8 +292,9 @@ configureAction (configFlags, configExFlags) extraArgs globalFlags = do   let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) -  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                          globalFlags (configUserInstall configFlags)+  (useSandbox, config) <- fmap+                          (updateInstallDirs (configUserInstall configFlags))+                          (loadConfigOrSandboxConfig verbosity globalFlags)   let configFlags'   = savedConfigureFlags   config `mappend` configFlags       configExFlags' = savedConfigureExFlags config `mappend` configExFlags       globalFlags'   = savedGlobalFlags      config `mappend` globalFlags@@ -265,6 +310,9 @@    whenUsingSandbox useSandbox $ \sandboxDir -> do     initPackageDBIfNeeded verbosity configFlags'' comp conf+    -- 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).      indexFile     <- tryGetIndexFilePath config     maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile@@ -278,17 +326,16 @@  buildAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO () buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do-  let distPref    = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)-                    (buildDistPref buildFlags)-      verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)+  let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)       noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck                     (buildOnly buildExFlags)    -- Calls 'configureAction' to do the real work, so nothing special has to be   -- done to support sandboxes.-  (useSandbox, config) <- reconfigure verbosity distPref-                          mempty [] globalFlags noAddSource-                          (buildNumJobs buildFlags) (const Nothing)+  (useSandbox, config, distPref) <- reconfigure verbosity+                                    (buildDistPref buildFlags)+                                    mempty [] globalFlags noAddSource+                                    (buildNumJobs buildFlags) (const Nothing)    maybeWithSandboxDirOnSearchPath useSandbox $     build verbosity config distPref buildFlags extraArgs@@ -331,8 +378,8 @@     numJobsCmdLineFlag = buildNumJobs buildFlags  -replAction :: ReplFlags -> [String] -> GlobalFlags -> IO ()-replAction replFlags extraArgs globalFlags = do+replAction :: (ReplFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()+replAction (replFlags, buildExFlags) extraArgs globalFlags = do   cwd     <- getCurrentDirectory   pkgDesc <- findPackageDesc cwd   either (const onNoPkgDesc) (const onPkgDesc) pkgDesc@@ -342,12 +389,17 @@     -- There is a .cabal file in the current directory: start a REPL and load     -- the project's modules.     onPkgDesc = do-      let distPref    = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)-                        (replDistPref replFlags)-          noAddSource = case replReload replFlags of-                          Flag True -> SkipAddSourceDepsCheck-                          _         -> DontSkipAddSourceDepsCheck-          progConf     = defaultProgramConfiguration+      let noAddSource = case replReload replFlags of+            Flag True -> SkipAddSourceDepsCheck+            _         -> fromFlagOrDefault DontSkipAddSourceDepsCheck+                         (buildOnly buildExFlags)+      -- 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           setupOptions = defaultSetupScriptOptions             { useCabalVersion = orLaterVersion $ Version [1,18,0] []             , useDistPref     = distPref@@ -356,11 +408,6 @@             { replVerbosity = toFlag verbosity             , replDistPref  = toFlag distPref             }-      -- Calls 'configureAction' to do the real work, so nothing special has to-      -- be done to support sandboxes.-      (useSandbox, _config) <- reconfigure verbosity distPref-                               mempty [] globalFlags noAddSource NoFlag-                               (const Nothing)        maybeWithSandboxDirOnSearchPath useSandbox $         setupWrapper verbosity setupOptions Nothing@@ -370,10 +417,13 @@     -- using the sandbox package DB).     onNoPkgDesc = do       (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags-                               mempty       let configFlags = savedConfigureFlags config       (comp, _platform, programDb) <- configCompilerAux' configFlags-      startInterpreter verbosity programDb comp (configPackageDB' configFlags)+      programDb' <- reconfigurePrograms verbosity+                                        (replProgramPaths replFlags)+                                        (replProgramArgs replFlags)+                                        programDb+      startInterpreter verbosity programDb' comp (configPackageDB' configFlags)  -- | Re-configure the package in the current directory if needed. Deciding -- when to reconfigure and with which options is convoluted:@@ -406,7 +456,7 @@ -- these required settings will be checked first upon determining that -- a previous configuration exists. reconfigure :: Verbosity    -- ^ Verbosity setting-            -> FilePath     -- ^ \"dist\" prefix+            -> 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@@ -432,13 +482,16 @@                             -- prefix setting is always required, it is checked                             -- automatically; this function need not check                             -- for it.-            -> IO (UseSandbox, SavedConfig)-reconfigure verbosity distPref     addConfigFlags extraArgs globalFlags+            -> 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-  case eLbi of-    Left (err, errCode) -> onNoBuildConfig err errCode-    Right lbi           -> onBuildConfig lbi+  config' <- case eLbi of+    Left err  -> onNoBuildConfig (useSandbox, config) distPref err+    Right lbi -> onBuildConfig (useSandbox, config) distPref lbi+  return (useSandbox, config', distPref)    where @@ -446,31 +499,41 @@     --     -- If we're in a sandbox: add-source deps don't have to be reinstalled     -- (since we don't know the compiler & platform).-    onNoBuildConfig :: String -> ConfigStateFileErrorType-                       -> IO (UseSandbox, SavedConfig)-    onNoBuildConfig err errCode = do-      let msg = case errCode of-            ConfigStateFileMissing    -> "Package has never been configured."-            ConfigStateFileCantParse  -> "Saved package config file seems "-                                         ++ "to be corrupt."-            ConfigStateFileBadVersion -> err-      case errCode of-        ConfigStateFileBadVersion -> info verbosity msg-        _                         -> do+    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+        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-      loadConfigOrSandboxConfig verbosity globalFlags mempty+      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 :: LBI.LocalBuildInfo -> IO (UseSandbox, SavedConfig)-    onBuildConfig lbi = do+    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@@ -488,14 +551,18 @@       when (skipAddSourceDepsCheck' == SkipAddSourceDepsCheck) $         info verbosity "Skipping add-source deps check..." -      (useSandbox, config, depsReinstalled) <-+      let (_, config') = updateInstallDirs+                         (configUserInstall flags)+                         (useSandbox, config)++      depsReinstalled <-         case skipAddSourceDepsCheck' of-        DontSkipAddSourceDepsCheck     ->-          maybeReinstallAddSourceDeps verbosity numJobsFlag flags globalFlags-        SkipAddSourceDepsCheck -> do-          (useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                                  globalFlags (configUserInstall flags)-          return (useSandbox, config, NoDepsReinstalled)+          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@@@ -505,36 +572,37 @@        -- Determine whether we need to reconfigure and which message to show to       -- the user if that is the case.-      mMsg <- determineMessageToShow lbi configFlags depsReinstalled-                                     isSandboxConfigNewer+      mMsg <- determineMessageToShow distPref lbi configFlags+                                     depsReinstalled isSandboxConfigNewer                                      isUserPackageEnvironmentFileNewer       case mMsg of          -- No message for the user indicates that reconfiguration         -- is not required.-        Nothing -> return (useSandbox, config)+        Nothing -> return config'          -- Show the message and reconfigure.         Just msg -> do           notice verbosity msg           configureAction (flags, defaultConfigExFlags)             extraArgs globalFlags-          return (useSandbox, config)+          return config'      -- Determine what message, if any, to display to the user if reconfiguration     -- is required.-    determineMessageToShow :: LBI.LocalBuildInfo -> ConfigFlags+    determineMessageToShow :: FilePath -> LBI.LocalBuildInfo -> ConfigFlags                             -> WereDepsReinstalled -> Bool -> Bool                             -> IO (Maybe String)-    determineMessageToShow _   _           _               True  _     =+    determineMessageToShow _ _   _           _               True  _     =       -- The sandbox was created after the package was already configured.       return $! Just $! sandboxConfigNewerMessage -    determineMessageToShow _   _           _               False True  =+    determineMessageToShow _ _   _           _               False True  =       -- The user package environment file was modified.       return $! Just $! userPackageEnvironmentFileModifiedMessage -    determineMessageToShow lbi configFlags depsReinstalled False False = do+    determineMessageToShow distPref lbi configFlags depsReinstalled+                           False False = do       let savedDistPref = fromFlagOrDefault                           (useDistPref defaultSetupScriptOptions)                           (configDistPref configFlags)@@ -563,11 +631,6 @@                             then Just $! outdatedMessage pdFile                             else Nothing -    defaultFlags = mappend addConfigFlags distVerbFlags-    distVerbFlags = mempty-        { configVerbosity = toFlag verbosity-        , configDistPref  = toFlag distPref-        }     reconfiguringMostRecent = " Re-configuring with most recently used options."     configureManually       = " If this fails, please run configure manually."     sandboxConfigNewerMessage =@@ -594,17 +657,20 @@  installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)               -> [String] -> GlobalFlags -> IO ()-installAction (configFlags, _, installFlags, _) _ _globalFlags-  | fromFlagOrDefault False (installOnly installFlags)-  = let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    in setupWrapper verbosity defaultSetupScriptOptions Nothing-         installCommand (const mempty) []+installAction (configFlags, _, installFlags, _) _ globalFlags+  | fromFlagOrDefault False (installOnly installFlags) = do+      let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+      (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags+      distPref <- findSavedDistPref config (configDistPref configFlags)+      let setupOpts = defaultSetupScriptOptions { useDistPref = distPref }+      setupWrapper verbosity setupOpts Nothing installCommand (const mempty) []  installAction (configFlags, configExFlags, installFlags, haddockFlags)               extraArgs globalFlags = do   let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity-                          globalFlags (configUserInstall configFlags)+  (useSandbox, config) <- fmap+                          (updateInstallDirs (configUserInstall configFlags))+                          (loadConfigOrSandboxConfig verbosity globalFlags)   targets <- readUserTargets verbosity extraArgs    -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to@@ -620,26 +686,33 @@   let sandboxDistPref = case useSandbox of         NoSandbox             -> NoFlag         UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir-      configFlags'    = savedConfigureFlags   config `mappend` configFlags+  distPref <- findSavedDistPref config+              (configDistPref configFlags `mappend` sandboxDistPref)++  let configFlags'    = maybeForceTests installFlags' $+                        savedConfigureFlags   config `mappend`+                        configFlags { configDistPref = toFlag distPref }       configExFlags'  = defaultConfigExFlags         `mappend`                         savedConfigureExFlags config `mappend` configExFlags       installFlags'   = defaultInstallFlags          `mappend`                         savedInstallFlags     config `mappend` installFlags+      haddockFlags'   = defaultHaddockFlags          `mappend`+                        savedHaddockFlags     config `mappend`+                        haddockFlags { haddockDistPref = toFlag distPref }       globalFlags'    = savedGlobalFlags      config `mappend` globalFlags   (comp, platform, conf) <- configCompilerAux' configFlags'+  -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the future.+  conf' <- configureAllKnownPrograms verbosity conf    -- 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   -- timestamp record for this compiler to the timestamp file.   configFlags'' <- case useSandbox of-        NoSandbox               -> configAbsolutePaths $ configFlags'-        (UseSandbox sandboxDir) ->-          return $ (setPackageDB sandboxDir comp platform configFlags') {-            configDistPref = sandboxDistPref-            }+    NoSandbox               -> configAbsolutePaths $ configFlags'+    (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform configFlags'    whenUsingSandbox useSandbox $ \sandboxDir -> do-    initPackageDBIfNeeded verbosity configFlags'' comp conf+    initPackageDBIfNeeded verbosity configFlags'' comp conf'      indexFile     <- tryGetIndexFilePath config     maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile@@ -656,39 +729,68 @@       install verbosity               (configPackageDB' configFlags'')               (globalRepos globalFlags')-              comp platform conf+              comp platform conf'               useSandbox mSandboxPkgInfo               globalFlags' configFlags'' configExFlags'-              installFlags' haddockFlags+              installFlags' haddockFlags'               targets +    where+      -- '--run-tests' implies '--enable-tests'.+      maybeForceTests installFlags' configFlags' =+        if fromFlagOrDefault False (installRunTests installFlags')+        then configFlags' { configTests = toFlag True }+        else configFlags'+ testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags-              -> IO ()+           -> IO () testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do   let verbosity      = fromFlagOrDefault normal (testVerbosity testFlags)-      distPref       = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)-                       (testDistPref testFlags)-      setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }       addConfigFlags = mempty { configTests = toFlag True }+      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."-      noAddSource    = fromFlagOrDefault DontSkipAddSourceDepsCheck-                       (buildOnly buildExFlags)    -- reconfigure also checks if we're in a sandbox and reinstalls add-source   -- deps if needed.-  (useSandbox, config) <- reconfigure verbosity distPref addConfigFlags []-                          globalFlags noAddSource-                          (buildNumJobs buildFlags) checkFlags+  (useSandbox, config, distPref) <-+    reconfigure verbosity (testDistPref testFlags)+                addConfigFlags [] globalFlags noAddSource+                (buildNumJobs buildFlags') checkFlags+  let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }+      testFlags'     = testFlags { testDistPref = toFlag distPref } -  maybeWithSandboxDirOnSearchPath useSandbox $-    build verbosity config distPref buildFlags extraArgs+  -- the package was just configured, so the LBI must be available+  lbi <- getPersistBuildConfig distPref+  let pkgDescr = LBI.localPkgDescr lbi+      nameTestsOnly =+        LBI.foldComponent+          (const Nothing)+          (const Nothing)+          (\t ->+            if buildable (testBuildInfo t)+              then Just (testName t)+            else Nothing)+          (const Nothing)+      tests = mapMaybe nameTestsOnly $ LBI.pkgComponents pkgDescr+      extraArgs'+        | null extraArgs = tests+        | otherwise = extraArgs -  maybeWithSandboxDirOnSearchPath useSandbox $-    setupWrapper verbosity setupOptions Nothing-      Cabal.testCommand (const testFlags) extraArgs+  if null tests+    then notice verbosity "Package has no buildable test suites."+    else do+      maybeWithSandboxDirOnSearchPath useSandbox $+        build verbosity config distPref buildFlags' extraArgs' +      maybeWithSandboxDirOnSearchPath useSandbox $+        setupWrapper verbosity setupOptions Nothing+          Cabal.testCommand (const testFlags') extraArgs'+ benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags)                    -> [String] -> GlobalFlags                    -> IO ()@@ -696,10 +798,9 @@                 extraArgs globalFlags = do   let verbosity      = fromFlagOrDefault normal                        (benchmarkVerbosity benchmarkFlags)-      distPref       = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)-                       (benchmarkDistPref benchmarkFlags)-      setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }       addConfigFlags = mempty { configBenchmarks = toFlag True }+      buildFlags'    = buildFlags+                       { buildVerbosity = benchmarkVerbosity benchmarkFlags }       checkFlags flags         | fromFlagOrDefault False (configBenchmarks flags) = Nothing         | otherwise = Just "Re-configuring with benchmarks enabled."@@ -708,21 +809,73 @@    -- reconfigure also checks if we're in a sandbox and reinstalls add-source   -- deps if needed.-  (useSandbox, config) <- reconfigure verbosity distPref addConfigFlags []-                          globalFlags noAddSource (buildNumJobs buildFlags)-                          checkFlags+  (useSandbox, config, distPref) <-+    reconfigure verbosity (benchmarkDistPref benchmarkFlags)+                addConfigFlags [] globalFlags noAddSource+                (buildNumJobs buildFlags') checkFlags+  let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }+      benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref } -  maybeWithSandboxDirOnSearchPath useSandbox $-    build verbosity config distPref buildFlags extraArgs+  -- the package was just configured, so the LBI must be available+  lbi <- getPersistBuildConfig distPref+  let pkgDescr = LBI.localPkgDescr lbi+      nameBenchsOnly =+        LBI.foldComponent+          (const Nothing)+          (const Nothing)+          (const Nothing)+          (\b ->+            if buildable (benchmarkBuildInfo b)+              then Just (benchmarkName b)+            else Nothing)+      benchs = mapMaybe nameBenchsOnly $ LBI.pkgComponents pkgDescr+      extraArgs'+        | null extraArgs = benchs+        | otherwise = extraArgs -  maybeWithSandboxDirOnSearchPath useSandbox $-    setupWrapper verbosity setupOptions Nothing-      Cabal.benchmarkCommand (const benchmarkFlags) extraArgs+  if null benchs+    then notice verbosity "Package has no buildable benchmarks."+    else do+      maybeWithSandboxDirOnSearchPath useSandbox $+        build verbosity config distPref buildFlags' extraArgs' +      maybeWithSandboxDirOnSearchPath useSandbox $+        setupWrapper verbosity setupOptions Nothing+          Cabal.benchmarkCommand (const benchmarkFlags') extraArgs'++haddockAction :: HaddockFlags -> [String] -> GlobalFlags -> IO ()+haddockAction haddockFlags extraArgs globalFlags = do+  let verbosity = fromFlag (haddockVerbosity haddockFlags)+  (_useSandbox, config, distPref) <-+    reconfigure verbosity (haddockDistPref haddockFlags)+                mempty [] globalFlags DontSkipAddSourceDepsCheck+                NoFlag (const Nothing)+  let haddockFlags' = defaultHaddockFlags      `mappend`+                      savedHaddockFlags config `mappend`+                      haddockFlags { haddockDistPref = toFlag distPref }+      setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }+  setupWrapper verbosity setupScriptOptions Nothing+    haddockCommand (const haddockFlags') extraArgs++cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO ()+cleanAction cleanFlags extraArgs globalFlags = do+  (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (cleanDistPref cleanFlags)+  let setupScriptOptions = defaultSetupScriptOptions+                           { useDistPref = distPref+                           , useWin32CleanHack = True+                           }+      cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref }+  setupWrapper verbosity setupScriptOptions Nothing+               cleanCommand (const cleanFlags') extraArgs+  where+    verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags)+ listAction :: ListFlags -> [String] -> GlobalFlags -> IO () listAction listFlags extraArgs globalFlags = do   let verbosity = fromFlag (listVerbosity listFlags)-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })   let configFlags' = savedConfigureFlags config       configFlags  = configFlags' {         configPackageDBs = configPackageDBs configFlags'@@ -742,7 +895,8 @@ infoAction infoFlags extraArgs globalFlags = do   let verbosity = fromFlag (infoVerbosity infoFlags)   targets <- readUserTargets verbosity extraArgs-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })   let configFlags' = savedConfigureFlags config       configFlags  = configFlags' {         configPackageDBs = configPackageDBs configFlags'@@ -764,9 +918,11 @@   unless (null extraArgs) $     die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs   let verbosity = fromFlag verbosityFlag-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })   let globalFlags' = savedGlobalFlags config `mappend` globalFlags-  update verbosity (globalRepos globalFlags')+  transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags'))+  update transport verbosity (globalRepos globalFlags')  upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)               -> [String] -> GlobalFlags -> IO ()@@ -787,7 +943,7 @@ fetchAction fetchFlags extraArgs globalFlags = do   let verbosity = fromFlag (fetchVerbosity fetchFlags)   targets <- readUserTargets verbosity extraArgs-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  config <- loadConfig verbosity (globalConfigFile globalFlags)   let configFlags  = savedConfigureFlags config       globalFlags' = savedGlobalFlags config `mappend` globalFlags   (comp, platform, conf) <- configCompilerAux' configFlags@@ -800,7 +956,7 @@ freezeAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () freezeAction freezeFlags _extraArgs globalFlags = do   let verbosity = fromFlag (freezeVerbosity freezeFlags)-  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags   let configFlags  = savedConfigureFlags config       globalFlags' = savedGlobalFlags config `mappend` globalFlags   (comp, platform, conf) <- configCompilerAux' configFlags@@ -818,17 +974,25 @@ uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO () uploadAction uploadFlags extraArgs globalFlags = do   let verbosity = fromFlag (uploadVerbosity uploadFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  config <- loadConfig verbosity (globalConfigFile globalFlags)   let uploadFlags' = savedUploadFlags config `mappend` uploadFlags       globalFlags' = savedGlobalFlags config `mappend` globalFlags       tarfiles     = extraArgs   checkTarFiles extraArgs+  maybe_password <-+    case uploadPasswordCmd uploadFlags'+    of Flag (xs:xss) -> Just . Password <$>+                        getProgramInvocationOutput verbosity+                        (simpleProgramInvocation xs xss)+       _             -> pure $ flagToMaybe $ uploadPassword uploadFlags'+  transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags'))   if fromFlag (uploadCheck uploadFlags')-    then Upload.check  verbosity tarfiles-    else upload verbosity+    then Upload.check transport verbosity tarfiles+    else upload transport+                verbosity                 (globalRepos globalFlags')                 (flagToMaybe $ uploadUsername uploadFlags')-                (flagToMaybe $ uploadPassword uploadFlags')+                maybe_password                 tarfiles   where     checkTarFiles tarfiles@@ -854,12 +1018,37 @@   allOk <- Check.check (fromFlag verbosityFlag)   unless allOk exitFailure +formatAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()+formatAction verbosityFlag extraArgs _globalFlags = do+  let verbosity = fromFlag verbosityFlag+  path <- case extraArgs of+    [] -> do cwd <- getCurrentDirectory+             tryFindPackageDesc cwd+    (p:_) -> return p+  pkgDesc <- readPackageDescription verbosity path+  -- Uses 'writeFileAtomic' under the hood.+  writeGenericPackageDescription path pkgDesc +uninstallAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()+uninstallAction _verbosityFlag extraArgs _globalFlags = do+  let package = case extraArgs of+        p:_ -> p+        _   -> "PACKAGE_NAME"+  die $ "This version of 'cabal-install' does not support the 'uninstall' operation. "+        ++ "It will likely be implemented at some point in the future; in the meantime "+        ++ "you're advised to use either 'ghc-pkg unregister " ++ package ++ "' or "+        ++ "'cabal sandbox hc-pkg -- unregister " ++ package ++ "'."++ sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> GlobalFlags -> IO ()-sdistAction (sdistFlags, sdistExFlags) extraArgs _globalFlags = do+sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do   unless (null extraArgs) $     die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs-  sdist sdistFlags sdistExFlags+  let verbosity = fromFlag (sDistVerbosity sdistFlags)+  (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  distPref <- findSavedDistPref config (sDistDistPref sdistFlags)+  let sdistFlags' = sdistFlags { sDistDistPref = toFlag distPref }+  sdist sdistFlags' sdistExFlags  reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO () reportAction reportFlags extraArgs globalFlags = do@@ -867,7 +1056,7 @@     die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs    let verbosity = fromFlag (reportVerbosity reportFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  config <- loadConfig verbosity (globalConfigFile globalFlags)   let globalFlags' = savedGlobalFlags config `mappend` globalFlags       reportFlags' = savedReportFlags config `mappend` reportFlags @@ -878,19 +1067,18 @@ runAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO () runAction (buildFlags, buildExFlags) extraArgs globalFlags = do   let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)-      distPref    = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)-                    (buildDistPref buildFlags)-      noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck+  let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck                     (buildOnly buildExFlags)    -- reconfigure also checks if we're in a sandbox and reinstalls add-source   -- deps if needed.-  (useSandbox, config) <- reconfigure verbosity distPref mempty []-                          globalFlags noAddSource (buildNumJobs buildFlags)-                          (const Nothing)+  (useSandbox, config, distPref) <-+    reconfigure verbosity (buildDistPref buildFlags) mempty []+                globalFlags noAddSource (buildNumJobs buildFlags)+                (const Nothing)    lbi <- getPersistBuildConfig distPref-  (exe, exeArgs) <- splitRunArgs lbi extraArgs+  (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs    maybeWithSandboxDirOnSearchPath useSandbox $     build verbosity config distPref buildFlags ["exe:" ++ exeName exe]@@ -902,7 +1090,8 @@ getAction getFlags extraArgs globalFlags = do   let verbosity = fromFlag (getVerbosity getFlags)   targets <- readUserTargets verbosity extraArgs-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })   let globalFlags' = savedGlobalFlags config `mappend` globalFlags   get verbosity     (globalRepos (savedGlobalFlags config))@@ -917,11 +1106,14 @@ initAction :: InitFlags -> [String] -> GlobalFlags -> IO () initAction initFlags _extraArgs globalFlags = do   let verbosity = fromFlag (initVerbosity initFlags)-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                           (globalFlags { globalRequireSandbox = Flag False })   let configFlags  = savedConfigureFlags config+  let globalFlags' = savedGlobalFlags    config `mappend` globalFlags   (comp, _, conf) <- configCompilerAux' configFlags   initCabal verbosity             (configPackageDB' configFlags)+            (globalRepos globalFlags')             comp             conf             initFlags@@ -937,6 +1129,12 @@         when (noExtraArgs extra) $           die "The 'sandbox add-source' command expects at least one argument"         sandboxAddSource verbosity extra sandboxFlags globalFlags+    ("delete-source":extra) -> do+        when (noExtraArgs extra) $+          die ("The 'sandbox delete-source' command expects " +++              "at least one argument")+        sandboxDeleteSource verbosity extra sandboxFlags globalFlags+    ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags      -- More advanced commands.     ("hc-pkg":extra) -> do@@ -946,12 +1144,6 @@     ["buildopts"] -> die "Not implemented!"      -- Hidden commands.-    ("delete-source":extra) -> do-        when (noExtraArgs extra) $-          die "The 'sandbox delete-source' command expects \-              \at least one argument"-        sandboxDeleteSource verbosity extra sandboxFlags globalFlags-    ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags     ["dump-pkgenv"]  -> dumpPackageEnvironment verbosity sandboxFlags globalFlags      -- Error handling.@@ -961,6 +1153,25 @@   where     noExtraArgs = (<1) . length +execAction :: ExecFlags -> [String] -> GlobalFlags -> IO ()+execAction execFlags extraArgs globalFlags = do+  let verbosity = fromFlag (execVerbosity execFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  let configFlags = savedConfigureFlags config+  (comp, platform, conf) <- configCompilerAux' configFlags+  exec verbosity useSandbox comp platform conf extraArgs++userConfigAction :: UserConfigFlags -> [String] -> GlobalFlags -> IO ()+userConfigAction ucflags extraArgs globalFlags = do+  let verbosity = fromFlag (userConfigVerbosity ucflags)+  case extraArgs of+    ("diff":_) -> mapM_ putStrLn =<< userConfigDiff globalFlags+    ("update":_) -> userConfigUpdate verbosity globalFlags+    -- Error handling.+    [] -> die $ "Please specify a subcommand (see 'help user-config')"+    _  -> die $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs++ -- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. -- win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags@@ -969,3 +1180,17 @@   let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags)   Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path win32SelfUpgradeAction _ _ _ = return ()++-- | Used as an entry point when cabal-install needs to invoke itself+-- as a setup script. This can happen e.g. when doing parallel builds.+--+actAsSetupAction :: ActAsSetupFlags -> [String] -> GlobalFlags -> IO ()+actAsSetupAction actAsSetupFlags args _globalFlags =+  let bt = fromFlag (actAsSetupBuildType actAsSetupFlags)+  in case bt of+    Simple    -> Simple.defaultMainArgs args+    Configure -> Simple.defaultMainWithHooksArgs+                  Simple.autoconfUserHooks args+    Make      -> Make.defaultMainArgs args+    Custom               -> error "actAsSetupAction Custom"+    (UnknownBuildType _) -> error "actAsSetupAction UnknownBuildType"

− cabal/cabal-install/README

@@ -1,143 +0,0 @@-The cabal-install package-=========================--[Cabal home page](http://www.haskell.org/cabal/)--The `cabal-install` package provides a command line tool called `cabal`. The-tool uses the `Cabal` library and provides a convenient user interface to the-Cabal/Hackage package build and distribution system. It can build and install-both local and remote packages, including dependencies.---Installation instructions for the cabal-install command line tool-=================================================================--The `cabal-install` package requires a number of other packages, most of which-come with a standard ghc installation. It requires the `network` package, which-is sometimes packaged separately by Linux distributions, for example on-debian or ubuntu it is in "libghc6-network-dev".--It requires a few other Haskell packages that are not always installed.-The exact list is specified in the `.cabal` file or in the `bootstrap.sh`-file. All these packages are available from-[Hackage](http://hackage.haskell.org).--Note that on some Unix systems you may need to install an additional zlib-development package using your system package manager, for example on-debian or ubuntu it is in "zlib1g-dev". It is needed is because the-Haskell zlib package uses the system zlib C library and header files.--The `cabal-install` package is now part of the Haskell Platform so you do not-usually need to install it separately. However if you are starting from a-minimal ghc installation then you need to install `cabal-install` manually.-Since it is just an ordinary Cabal package it can be built in the standard-way, but to make it a bit easier we have partly automated the process:---Quickstart on Unix systems-----------------------------As a convenience for users on Unix systems there is a `bootstrap.sh` script-which will download and install each of the dependencies in turn.--    $ ./bootstrap.sh--It will download and install the dependencies. The script will-install the library packages into `$HOME/.cabal/` and the `cabal` program will-be installed into `$HOME/.cabal/bin/`.--You then have two choices:-- * put `$HOME/.cabal/bin` on your `$PATH`- * move the `cabal` program somewhere that is on your `$PATH`--The next thing to do is to get the latest list of packages with:--    $ cabal update--This will also create a default config file (if it does not already echo exist)-at `$HOME/.cabal/config`--By default cabal will install programs to `$HOME/.cabal/bin`. If you do not-want to add this directory to your `$PATH` then you can change the setting in-the config file, for example you could use:--    symlink-bindir: $HOME/bin---Quickstart on Windows systems--------------------------------For Windows users we provide a pre-compiled [cabal.exe] program. Just download-it and put it somewhere on your `%PATH%`, for example-`C:\Program Files\Haskell\bin`.--[cabal.exe]: http://haskell.org/cabal/release/cabal-install-latest/cabal.exe--The next thing to do is to get the latest list of packages with--    cabal update--This will also create a default config file (if it does not already echo exist)-at `C:\Documents and Settings\username\Application Data\cabal\config`---Using cabal-install-===================--There are two sets of commands: commands for working with a local project build-tree and ones for working with distributed released packages from hackage.--For a list of the full set of commands and the flags for each command see--    $ cabal --help---Commands for developers for local build trees------------------------------------------------The commands for local project build trees are almost exactly the same as the-`runghc Setup` command line interface that many people are already familiar-with. In particular there are the commands--    cabal configure-    cabal build-    cabal haddock-    cabal clean-    cabal sdist--The `install` command is somewhat different. It is an all-in-one operation. If-you run--    $ cabal install--in your build tree it will configure, build and install. It takes all the flags-that `configure` takes such as `--global` and `--prefix`.--In addition, if any dependencies are not installed it will download and install-them. If can also rebuild packages to ensure a consistent set of dependencies.---Commands for released hackage packages-----------------------------------------    $ cabal update--This command gets the latest list of packages from the hackage server.-Currently this command has to be run manually occasionally, in particular if-you want to install a newly released package. ---    $ cabal install xmonad--This is the eponymous command. It installs one or more named packages (and all-their dependencies) from hackage.--By default it installs the latest available version however you can optionally-specify exact versions or version ranges. For example `cabal install alex-2.2`-or `cabal install parsec < 3`.--    $ cabal list xml--This does a search of the installed and available packages. It does a-case-insensitive substring match on the package name.

+ cabal/cabal-install/README.md view

@@ -0,0 +1,155 @@+The cabal-install package+=========================++See the [Cabal web site] for more information.++The `cabal-install` package provides a command line tool named `cabal`.+It uses the [Cabal] library and provides a user interface to the+Cabal/[Hackage] build automation and package management system. It can+build and install both local and remote packages, including+dependencies.++[Cabal web site]: http://www.haskell.org/cabal/+[Cabal]: ../Cabal/README.md++Installing the `cabal` command-line tool+========================================++The `cabal-install` package requires a number of other packages, most of+which come with a standard GHC installation. It requires the [network]+package, which is sometimes packaged separately by Linux distributions;+for example, on Debian or Ubuntu, it is located in the+"libghc6-network-dev" package.++`cabal` requires a few other Haskell packages that are not always+installed. The exact list is specified in the [.cabal] file or in the+[bootstrap.sh] file. All these packages are available from [Hackage].++Note that on some Unix systems you may need to install an additional+zlib development package using your system package manager; for example,+on Debian or Ubuntu, it is located in the "zlib1g-dev" package; on+Fedora, it is located in the "zlib-devel" package. It is required+because the Haskell zlib package uses the system zlib C library and+header files.++The `cabal-install` package is now part of the [Haskell Platform], so you+do not usually need to install it separately. However, if you are+starting from a minimal GHC installation, you need to install+`cabal-install` manually. Since it is an ordinary Cabal package,+`cabal-install` can be built the standard way; to facilitate this, the+process has been partially automated. It is described below.++[.cabal]: cabal-install.cabal+[network]: http://hackage.haskell.org/package/network+[Haskell Platform]: http://www.haskell.org/platform/++Quick start on Unix-like systems+--------------------------------++As a convenience for users on Unix-like systems, there is a+[bootstrap.sh] script that will download and install each of+`cabal-install`'s dependencies in turn.++    $ ./bootstrap.sh++It will download and install the dependencies. The script will install the+library packages (vanilla, profiling and shared) into `$HOME/.cabal/` and the+`cabal` program into `$HOME/.cabal/bin/`. If you don't want to install profiling+and shared versions of the libraries, use++    $ EXTRA_CONFIGURE_OPTS="" ./bootstrap.sh++You then have the choice either to place `$HOME/.cabal/bin` on your+`$PATH` or move the `cabal` program to somewhere on your `$PATH`. Next,+you can get the latest list of packages by running:++    $ cabal update++This will also create a default configuration file, if it does not+already exist, at `$HOME/.cabal/config`.++By default, `cabal` will install programs to `$HOME/.cabal/bin`. If you+do not want to add this directory to your `$PATH`, you can change+the setting in the config file; for example, you could use the+following:++    symlink-bindir: $HOME/bin+++Quick start on Windows systems+------------------------------++For Windows users, a precompiled program ([cabal.exe]) is provided.+Download and put it somewhere on your `%PATH%` (for example,+`C:\Program Files\Haskell\bin`.)++Next, you can get the latest list of packages by running:++    $ cabal update++This will also create a default configuration file (if it does not+already exist) at+`C:\Documents and Settings\%USERNAME%\Application Data\cabal\config`.++[cabal.exe]: http://www.haskell.org/cabal/release/cabal-install-latest/++Using `cabal`+=============++There are two sets of commands: commands for working with a local+project build tree and those for working with packages distributed+from [Hackage].++For the list of the full set of commands and flags for each command,+run:++    $ cabal help+++Commands for developers for local build trees+---------------------------------------------++The commands for local project build trees are almost the same as the+`runghc Setup` command-line interface you may already be familiar with.+In particular, it has the following commands:++  * `cabal configure`+  * `cabal build`+  * `cabal haddock`+  * `cabal clean`+  * `cabal sdist`++The `install` command is somewhat different; it is an all-in-one+operation. If you run `cabal install` in your build tree, it will+configure, build, and install. It takes all the flags that `configure`+takes such as `--global` and `--prefix`.++In addition, `cabal` will download and install any dependencies that are+not already installed. It can also rebuild packages to ensure a+consistent set of dependencies.+++Commands for released Hackage packages+--------------------------------------++    $ cabal update++This command gets the latest list of packages from the [Hackage] server.+On occasion, this command must be run manually--for instance, if you+want to install a newly released package.++    $ cabal install xmonad++This command installs one or more named packages, and all their+dependencies, from Hackage. By default, it installs the latest available+version; however, you may specify exact versions or version ranges. For+example, `cabal install alex-2.2` or `cabal install parsec < 3`.++    $ cabal list xml++This does a search of the installed and available packages. It does a+case-insensitive substring match on the package name.+++[Hackage]: http://hackage.haskell.org+[bootstrap.sh]: bootstrap.sh

cabal/cabal-install/bash-completion/cabal view

@@ -3,6 +3,56 @@ #                     "Duncan Coutts"     <dcoutts@gentoo.org> # +# List cabal targets by type, pass:+#   - test-suite for test suites+#   - benchmark for benchmarks+#   - executable for executables+#   - executable|test-suite|benchmark for the three+_cabal_list()+{+	cat *.cabal |+	grep -Ei "^[[:space:]]*($1)[[:space:]]" |+	sed -e "s/.* \([^ ]*\).*/\1/"+}++# List possible targets depending on the command supplied as parameter.  The+# ideal option would be to implement this via --list-options on cabal directly.+# 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+}++# List possible subcommands of a cabal subcommand.+#+# In example "sandbox" is a cabal subcommand that itself has subcommands. Since+# "cabal --list-options" doesn't work in such cases we have to get the list+# using other means.+_cabal_subcommands()+{+    local word+    for word in "$@"; do+        case "$word" in+          sandbox)+            # Get list of "cabal sandbox" subcommands from its help message.+            "$1" help sandbox |+            sed -n '1,/^Subcommands:$/d;/^Flags for sandbox:$/,$d;/^ /d;s/^\(.*\):/\1/p'+            break  # Terminate for loop.+            ;;+        esac+    done+}+ _cabal() {     # get the word currently being completed@@ -18,7 +68,7 @@     cmd[${COMP_CWORD}]="--list-options"      # the resulting completions should be put into this array-    COMPREPLY=( $( compgen -W "$( ${cmd[@]} )" -- $cur ) )+    COMPREPLY=( $( compgen -W "$( ${cmd[@]} ) $( _cabal_targets ${cmd[@]} ) $( _cabal_subcommands ${COMP_WORDS[@]} )" -- $cur ) ) }  complete -F _cabal -o default cabal

cabal/cabal-install/bootstrap.sh view

@@ -6,88 +6,219 @@ # HTTP packages. It then installs cabal-install itself. # It expects to be run inside the cabal-install directory. -# install settings, you can override these by setting environment vars+# Install settings, you can override these by setting environment vars. E.g. if+# you don't want profiling and dynamic versions of libraries to be installed in+# addition to vanilla, run 'EXTRA_CONFIGURE_OPTS="" ./bootstrap.sh'+ #VERBOSE-#EXTRA_CONFIGURE_OPTS+DEFAULT_CONFIGURE_OPTS="--enable-library-profiling --enable-shared"+EXTRA_CONFIGURE_OPTS=${EXTRA_CONFIGURE_OPTS-$DEFAULT_CONFIGURE_OPTS} #EXTRA_BUILD_OPTS #EXTRA_INSTALL_OPTS +die () { printf "\nError during cabal-install bootstrap:\n$1\n" >&2 && exit 2 ;}+ # programs, you can override these by setting environment vars-GHC=${GHC:-ghc}-GHC_PKG=${GHC_PKG:-ghc-pkg}-WGET=${WGET:-wget}-CURL=${CURL:-curl}-FETCH=${FETCH:-fetch}-TAR=${TAR:-tar}-GUNZIP=${GUNZIP:-gunzip}-SCOPE_OF_INSTALLATION="--user"+GHC="${GHC:-ghc}"+GHC_PKG="${GHC_PKG:-ghc-pkg}"+GHC_VER="$(${GHC} --numeric-version)"+HADDOCK=${HADDOCK:-haddock}+WGET="${WGET:-wget}"+CURL="${CURL:-curl}"+FETCH="${FETCH:-fetch}"+TAR="${TAR:-tar}"+GZIP_PROGRAM="${GZIP_PROGRAM:-gzip}"++# The variable SCOPE_OF_INSTALLATION can be set on the command line to+# use/install the libaries needed to build cabal-install to a custom package+# database instead of the user or global package database.+#+# Example:+#+# $ ghc-pkg init /my/package/database+# $ SCOPE_OF_INSTALLATION='--package-db=/my/package/database' ./bootstrap.sh+#+# You can also combine SCOPE_OF_INSTALLATION with PREFIX:+#+# $ ghc-pkg init /my/prefix/packages.conf.d+# $ SCOPE_OF_INSTALLATION='--package-db=/my/prefix/packages.conf.d' \+#   PREFIX=/my/prefix ./bootstrap.sh+#+# If you use the --global,--user or --sandbox arguments, this will+# override the SCOPE_OF_INSTALLATION setting and not use the package+# database you pass in the SCOPE_OF_INSTALLATION variable.++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 -for arg in $*-do-  case "${arg}" in+# 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 &&+  echo "Using $c for C compiler. If this is not what you want, set CC." >&2 &&+  break+done++# None found.+[ -"$CC"- = -""- ] && die 'C compiler not found (or could not be run).+  If a C compiler is installed make sure it is on your PATH, or set $CC.'++# 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+        done)"++# Fall back to "ld"... might work.+[ -$LINK- = -""- ] && LINK=ld++# And finally, see if we can compile and link something.+  echo 'int main(){}' | $CC -xc - -o /dev/null ||+    die "C compiler and linker could not compile a simple test program.+    Please check your toolchain."++# Warn that were's overriding $LD if set (if you want).+[ -"$LD"- != -""- ] && [ -"$LD"- != -"$LINK"- ] &&+  echo "Warning: value set in $LD is not the same as C compiler's $LINK." >&2+  echo "Using $LINK instead." >&2++# Set LD, overriding environment if necessary.+export LD=$LINK++# Check we're in the right directory, etc.+grep "cabal-install" ./cabal-install.cabal > /dev/null 2>&1 ||+  die "The bootstrap.sh script must be run in the cabal-install directory"++${GHC} --numeric-version > /dev/null 2>&1  ||+  die "${GHC} not found (or could not be run).+       If ghc is installed,  make sure it is on your PATH,+       or set the GHC and GHC_PKG vars."++${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."++while [ "$#" -gt 0 ]; do+  case "${1}" in     "--user")-      SCOPE_OF_INSTALLATION=${arg}+      SCOPE_OF_INSTALLATION="${1}"       shift;;     "--global")-      SCOPE_OF_INSTALLATION=${arg}+      SCOPE_OF_INSTALLATION="${1}"       DEFAULT_PREFIX="/usr/local"       shift;;+    "--sandbox")+      shift+      # check if there is another argument which doesn't start with --+      if [ "$#" -le 0 ] || [ ! -z $(echo "${1}" | grep "^--") ]+      then+          SANDBOX=".cabal-sandbox"+      else+          SANDBOX="${1}"+          shift+      fi;;+    "--no-doc")+      NO_DOCUMENTATION=1+      shift;;     *)-      echo "Unknown argument or option, quitting: ${arg}"+      echo "Unknown argument or option, quitting: ${1}"       echo "usage: bootstrap.sh [OPTION]"       echo       echo "options:"-      echo "   --user    Install for the local user (default)"-      echo "   --global  Install systemwide (must be run as root)"+      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 "\+           "packages"+      echo "   --sandbox       Install to a sandbox in the default location"\+           "(.cabal-sandbox)"+      echo "   --sandbox path  Install to a sandbox located at path"       exit;;   esac done +abspath () { case "$1" in /*)printf "%s\n" "$1";; *)printf "%s\n" "$PWD/$1";;+             esac; }++if [ ! -z "$SANDBOX" ]+then # set up variables for sandbox bootstrap+  # Make the sandbox path absolute since it will be used from+  # different working directories when the dependency packages are+  # installed.+  SANDBOX=$(abspath "$SANDBOX")+  # Get the name of the package database which cabal sandbox would use.+  GHC_ARCH=$(ghc --info |+    sed -n 's/.*"Target platform".*"\([^-]\+\)-[^-]\+-\([^"]\+\)".*/\1-\2/p')+  PACKAGEDB="$SANDBOX/${GHC_ARCH}-ghc-${GHC_VER}-packages.conf.d"+  # Assume that if the directory is already there, it is already a+  # package database. We will get an error immediately below if it+  # isn't. Uses -r to try to be compatible with Solaris, and allow+  # symlinks as well as a normal dir/file.+  [ ! -r "$PACKAGEDB" ] && ghc-pkg init "$PACKAGEDB"+  PREFIX="$SANDBOX"+  SCOPE_OF_INSTALLATION="--package-db=$PACKAGEDB"+  echo Bootstrapping in sandbox at \'$SANDBOX\'.+fi++# Check for haddock unless no documentation should be generated.+if [ ! ${NO_DOCUMENTATION} ]+then+  ${HADDOCK} --version     > /dev/null 2>&1  || die "${HADDOCK} not found."+fi+ PREFIX=${PREFIX:-${DEFAULT_PREFIX}}  # Versions of the packages to install. # The version regex says what existing installed versions are ok.-PARSEC_VER="3.1.4";    PARSEC_VER_REGEXP="[23]\."              # == 2.* || == 3.*-DEEPSEQ_VER="1.3.0.2"; DEEPSEQ_VER_REGEXP="1\.[1-9]\."         # >= 1.1 && < 2-TEXT_VER="1.0.0.0";    TEXT_VER_REGEXP="((1\.0\.)|(0\.([2-9]|(1[0-1]))\.))" # >= 0.2 && < 1.1-NETWORK_VER="2.4.2.1"; NETWORK_VER_REGEXP="2\."                # == 2.*-CABAL_VER="1.19.2";    CABAL_VER_REGEXP="1\.1[9]\."            # >= 1.19 && < 1.20-TRANS_VER="0.3.0.0";   TRANS_VER_REGEXP="0\.[23]\."            # >= 0.2.* && < 0.4.*-MTL_VER="2.1.2";       MTL_VER_REGEXP="[2]\."                  #  == 2.*-HTTP_VER="4000.2.10";  HTTP_VER_REGEXP="4000\.[012]\."         # == 4000.0.* || 4000.1.* || 4000.2.*-ZLIB_VER="0.5.4.1";    ZLIB_VER_REGEXP="0\.[45]\."             # == 0.4.* || == 0.5.*-TIME_VER="1.4.1"       TIME_VER_REGEXP="1\.[1234]\.?"          # >= 1.1 && < 1.5-RANDOM_VER="1.0.1.1"   RANDOM_VER_REGEXP="1\.0\."              # >= 1 && < 1.1-STM_VER="2.4.2";       STM_VER_REGEXP="2\."                    # == 2.*--HACKAGE_URL="http://hackage.haskell.org/packages/archive"--die () {-  echo-  echo "Error during cabal-install bootstrap:"-  echo $1 >&2-  exit 2-}+PARSEC_VER="3.1.9";    PARSEC_VER_REGEXP="[3]\.[01]\."+                       # >= 3.0 && < 3.2+DEEPSEQ_VER="1.4.1.1"; DEEPSEQ_VER_REGEXP="1\.[1-9]\."+                       # >= 1.1 && < 2+BINARY_VER="0.7.2.3";  BINARY_VER_REGEXP="[0]\.[7]\."+                       # == 0.7.*+TEXT_VER="1.2.1.1";    TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))"+                       # >= 0.2 && < 1.3+NETWORK_VER="2.6.2.0"; NETWORK_VER_REGEXP="2\.[0-6]\."+                       # >= 2.0 && < 2.7+NETWORK_URI_VER="2.6.0.3"; NETWORK_URI_VER_REGEXP="2\.6\."+                       # >= 2.6 && < 2.7+CABAL_VER="1.23.0.0";  CABAL_VER_REGEXP="1\.23\."+                       # >= 1.23 && < 1.24+TRANS_VER="0.4.2.0";   TRANS_VER_REGEXP="0\.[4]\."+                       # >= 0.2.* && < 0.5+MTL_VER="2.2.1";       MTL_VER_REGEXP="[2]\."+                       #  >= 2.0 && < 3+HTTP_VER="4000.2.19";  HTTP_VER_REGEXP="4000\.2\.([5-9]|1[0-9]|2[0-9])"+                       # >= 4000.2.5 < 4000.3+ZLIB_VER="0.5.4.2";    ZLIB_VER_REGEXP="0\.[45]\."+                       # == 0.4.* || == 0.5.*+TIME_VER="1.5.0.1"     TIME_VER_REGEXP="1\.[12345]\.?"+                       # >= 1.1 && < 1.6+RANDOM_VER="1.1"       RANDOM_VER_REGEXP="1\.[01]\.?"+                       # >= 1 && < 1.2+STM_VER="2.4.4";       STM_VER_REGEXP="2\."+                       # == 2.*+OLD_TIME_VER="1.1.0.3"; OLD_TIME_VER_REGEXP="1\.[01]\.?"+                       # >=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 -# Check we're in the right directory:-grep "cabal-install" ./cabal-install.cabal > /dev/null 2>&1 \-  || die "The bootstrap.sh script must be run in the cabal-install directory"+HACKAGE_URL="https://hackage.haskell.org/package" -${GHC} --numeric-version > /dev/null \-  || die "${GHC} not found (or could not be run). If ghc is installed make sure it is on your PATH or set the GHC and GHC_PKG vars."-${GHC_PKG} --version     > /dev/null \-  || 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"+# Haddock fails for network-2.5.0.0.+NO_DOCS_PACKAGES_VER_REGEXP="network-uri-2\.5\.[0-9]+\.[0-9]+"  # Cache the list of packages: echo "Checking installed packages for ghc-${GHC_VER}..."-${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg.list \-  || die "running '${GHC_PKG} list' failed"+${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg.list ||+  die "running '${GHC_PKG} list' failed"  # Will we need to install this package, or is a suitable version installed? need_pkg () {@@ -109,7 +240,12 @@    if need_pkg ${PKG} ${VER_MATCH}   then-    echo "${PKG}-${VER} will be downloaded and installed."+    if [ -r "${PKG}-${VER}.tar.gz" ]+    then+        echo "${PKG}-${VER} will be installed from local tarball."+    else+        echo "${PKG}-${VER} will be downloaded and installed."+    fi   else     echo "${PKG} is already installed and the version is ok."   fi@@ -119,10 +255,13 @@   PKG=$1   VER=$2 -  URL=${HACKAGE_URL}/${PKG}/${VER}/${PKG}-${VER}.tar.gz+  URL=${HACKAGE_URL}/${PKG}-${VER}/${PKG}-${VER}.tar.gz   if which ${CURL} > /dev/null   then-    ${CURL} -L --fail -C - -O ${URL} || die "Failed to download ${PKG}."+    # TODO: switch back to resuming curl command once+    #       https://github.com/haskell/hackage-server/issues/111 is resolved+    #${CURL} -L --fail -C - -O ${URL} || die "Failed to download ${PKG}."+    ${CURL} -L --fail -O ${URL} || die "Failed to download ${PKG}."   elif which ${WGET} > /dev/null   then     ${WGET} -c ${URL} || die "Failed to download ${PKG}."@@ -132,43 +271,53 @@   else     die "Failed to find a downloader. 'curl', 'wget' or 'fetch' is required."   fi-  [ -f "${PKG}-${VER}.tar.gz" ] \-    || die "Downloading ${URL} did not create ${PKG}-${VER}.tar.gz"+  [ -f "${PKG}-${VER}.tar.gz" ] ||+     die "Downloading ${URL} did not create ${PKG}-${VER}.tar.gz" }  unpack_pkg () {   PKG=$1   VER=$2 -  rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}"/-  ${GUNZIP} -f "${PKG}-${VER}.tar.gz" \-    || die "Failed to gunzip ${PKG}-${VER}.tar.gz"-  ${TAR} -xf "${PKG}-${VER}.tar" \-    || die "Failed to untar ${PKG}-${VER}.tar.gz"-  [ -d "${PKG}-${VER}" ] \-    || die "Unpacking ${PKG}-${VER}.tar.gz did not create ${PKG}-${VER}/"+  rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}"+  ${GZIP_PROGRAM} -d < "${PKG}-${VER}.tar.gz" | ${TAR} -xf -+  [ -d "${PKG}-${VER}" ] || die "Failed to unpack ${PKG}-${VER}.tar.gz" }  install_pkg () {   PKG=$1+  VER=$2    [ -x Setup ] && ./Setup clean   [ -f Setup ] && rm Setup -  ${GHC} --make Setup -o Setup \-    || die "Compiling the Setup script failed"+  ${GHC} --make Setup -o Setup ||+    die "Compiling the Setup script failed."+   [ -x Setup ] || die "The Setup script does not exist or cannot be run" -  ./Setup configure ${SCOPE_OF_INSTALLATION} "--prefix=${PREFIX}" \-    --with-compiler=${GHC} --with-hc-pkg=${GHC_PKG} \-    ${EXTRA_CONFIGURE_OPTS} ${VERBOSE} \-    || die "Configuring the ${PKG} package failed"+  args="${SCOPE_OF_INSTALLATION} --prefix=${PREFIX} --with-compiler=${GHC}"+  args="$args --with-hc-pkg=${GHC_PKG} --with-gcc=${CC} --with-ld=${LD}"+  args="$args ${EXTRA_CONFIGURE_OPTS} ${VERBOSE}" -  ./Setup build ${EXTRA_BUILD_OPTS} ${VERBOSE} \-    || die "Building the ${PKG} package failed"+  ./Setup configure $args || die "Configuring the ${PKG} package failed." -  ./Setup install ${SCOPE_OF_INSTALLATION} ${EXTRA_INSTALL_OPTS} ${VERBOSE} \-    || die "Installing the ${PKG} package failed"+  ./Setup build ${EXTRA_BUILD_OPTS} ${VERBOSE} ||+     die "Building the ${PKG} package failed."++  if [ ! ${NO_DOCUMENTATION} ]+  then+    if echo "${PKG}-${VER}" | egrep ${NO_DOCS_PACKAGES_VER_REGEXP} > /dev/null 2>&1+    then+      echo "Skipping documentation for the ${PKG} package."+    else+      ./Setup haddock --with-ghc=${GHC} --with-haddock=${HADDOCK} ${VERBOSE} ||+        die "Documenting the ${PKG} package failed."+    fi+  fi++  ./Setup install ${EXTRA_INSTALL_OPTS} ${VERBOSE} ||+     die "Installing the ${PKG} package failed." }  do_pkg () {@@ -179,8 +328,13 @@   if need_pkg ${PKG} ${VER_MATCH}   then     echo-    echo "Downloading ${PKG}-${VER}..."-    fetch_pkg ${PKG} ${VER}+    if [ -r "${PKG}-${VER}.tar.gz" ]+    then+        echo "Using local tarball for ${PKG}-${VER}."+    else+        echo "Downloading ${PKG}-${VER}..."+        fetch_pkg ${PKG} ${VER}+    fi     unpack_pkg ${PKG} ${VER}     cd "${PKG}-${VER}"     install_pkg ${PKG} ${VER}@@ -188,9 +342,29 @@   fi } +# Replicate the flag selection logic for network-uri in the .cabal file.+do_network_uri_pkg () {+  # Refresh installed package list.+  ${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg-stage2.list \+    || die "running '${GHC_PKG} list' failed"++  NETWORK_URI_DUMMY_VER="2.5.0.0"; NETWORK_URI_DUMMY_VER_REGEXP="2\.5\." # < 2.6+  if egrep " network-2\.[6-9]\." ghc-pkg-stage2.list > /dev/null 2>&1+  then+    # Use network >= 2.6 && network-uri >= 2.6+    info_pkg "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP}+    do_pkg   "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP}+  else+    # Use network < 2.6 && network-uri < 2.6+    info_pkg "network-uri" ${NETWORK_URI_DUMMY_VER} ${NETWORK_URI_DUMMY_VER_REGEXP}+    do_pkg   "network-uri" ${NETWORK_URI_DUMMY_VER} ${NETWORK_URI_DUMMY_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}@@ -198,12 +372,15 @@ info_pkg "text"         ${TEXT_VER}    ${TEXT_VER_REGEXP} info_pkg "parsec"       ${PARSEC_VER}  ${PARSEC_VER_REGEXP} info_pkg "network"      ${NETWORK_VER} ${NETWORK_VER_REGEXP}+info_pkg "old-locale"   ${OLD_LOCALE_VER} ${OLD_LOCALE_VER_REGEXP}+info_pkg "old-time"     ${OLD_TIME_VER} ${OLD_TIME_VER_REGEXP} info_pkg "HTTP"         ${HTTP_VER}    ${HTTP_VER_REGEXP} info_pkg "zlib"         ${ZLIB_VER}    ${ZLIB_VER_REGEXP} info_pkg "random"       ${RANDOM_VER}  ${RANDOM_VER_REGEXP} info_pkg "stm"          ${STM_VER}     ${STM_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} do_pkg   "transformers" ${TRANS_VER}   ${TRANS_VER_REGEXP}@@ -211,12 +388,24 @@ do_pkg   "text"         ${TEXT_VER}    ${TEXT_VER_REGEXP} do_pkg   "parsec"       ${PARSEC_VER}  ${PARSEC_VER_REGEXP} do_pkg   "network"      ${NETWORK_VER} ${NETWORK_VER_REGEXP}++# We conditionally install network-uri, depending on the network version.+do_network_uri_pkg++do_pkg   "old-locale"   ${OLD_LOCALE_VER} ${OLD_LOCALE_VER_REGEXP}+do_pkg   "old-time"     ${OLD_TIME_VER} ${OLD_TIME_VER_REGEXP} do_pkg   "HTTP"         ${HTTP_VER}    ${HTTP_VER_REGEXP} do_pkg   "zlib"         ${ZLIB_VER}    ${ZLIB_VER_REGEXP} do_pkg   "random"       ${RANDOM_VER}  ${RANDOM_VER_REGEXP} do_pkg   "stm"          ${STM_VER}     ${STM_VER_REGEXP}  install_pkg "cabal-install"++# Use the newly built cabal to turn the prefix/package database into a+# legit cabal sandbox. This works because 'cabal sandbox init' will+# reuse the already existing package database and other files if they+# are in the expected locations.+[ ! -z "$SANDBOX" ] && $SANDBOX/bin/cabal sandbox init --sandbox $SANDBOX  echo echo "==========================================="

cabal/cabal-install/cabal-install.cabal view

@@ -1,5 +1,5 @@ Name:               cabal-install-Version:            1.19.2+Version:            1.23.0.0 Synopsis:           The command-line interface for Cabal and Hackage. Description:     The \'cabal\' command-line program simplifies the process of managing@@ -22,9 +22,13 @@                     2007-2012 Duncan Coutts <duncan@community.haskell.org> Category:           Distribution Build-type:         Simple-Extra-Source-Files: README bash-completion/cabal bootstrap.sh-Cabal-Version:      >= 1.8+Cabal-Version:      >= 1.10+Extra-Source-Files:+  README.md bash-completion/cabal bootstrap.sh changelog +  -- Generated with '../Cabal/misc/gen-extra-source-files.sh | sort'+  tests/PackageTests/Freeze/my.cabal+ source-repository head   type:     git   location: https://github.com/haskell/cabal/@@ -34,6 +38,10 @@   description:  Use directory < 1.2 and old-time   default:      False +Flag network-uri+  description:  Get Network.URI from the network-uri package+  default:      True+ executable cabal     main-is:        Main.hs     ghc-options:    -Wall -fwarn-tabs@@ -43,6 +51,7 @@         Distribution.Client.BuildReports.Types         Distribution.Client.BuildReports.Upload         Distribution.Client.Check+        Distribution.Client.ComponentDeps         Distribution.Client.Config         Distribution.Client.Configure         Distribution.Client.Dependency@@ -60,6 +69,7 @@         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@@ -69,6 +79,7 @@         Distribution.Client.Dependency.Modular.Tree         Distribution.Client.Dependency.Modular.Validate         Distribution.Client.Dependency.Modular.Version+        Distribution.Client.Exec         Distribution.Client.Fetch         Distribution.Client.FetchUtils         Distribution.Client.Freeze@@ -89,6 +100,7 @@         Distribution.Client.PackageIndex         Distribution.Client.PackageUtils         Distribution.Client.ParseUtils+        Distribution.Client.PlanIndex         Distribution.Client.Run         Distribution.Client.Sandbox         Distribution.Client.Sandbox.Index@@ -104,9 +116,9 @@         Distribution.Client.Update         Distribution.Client.Upload         Distribution.Client.Utils+        Distribution.Client.Utils.LabeledGraph         Distribution.Client.World         Distribution.Client.Win32SelfUpgrade-        Distribution.Client.Compat.Environment         Distribution.Client.Compat.ExecutablePath         Distribution.Client.Compat.FilePerms         Distribution.Client.Compat.Process@@ -120,25 +132,32 @@         array      >= 0.1      && < 0.6,         base       >= 4.3      && < 5,         bytestring >= 0.9      && < 1,-        Cabal      == 1.19.2,+        Cabal      >= 1.23     && < 1.24,         containers >= 0.1      && < 0.6,-        filepath   >= 1.0      && < 1.4,-        HTTP       >= 4000.0.8 && < 4001,+        filepath   >= 1.0      && < 1.5,+        HTTP       >= 4000.1.5 && < 4000.3,         mtl        >= 2.0      && < 3,-        network    >= 1        && < 3,         pretty     >= 1        && < 1.2,-        random     >= 1        && < 1.1,+        random     >= 1        && < 1.2,         stm        >= 2.0      && < 3,-        time       >= 1.1      && < 1.5,-        zlib       >= 0.5.3    && < 0.6+        time       >= 1.1      && < 1.6,+        zlib       >= 0.5.3    && < 0.7      if flag(old-directory)       build-depends: directory >= 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.3+                     process   >= 1.1.0.2  && < 1.4 +    -- NOTE: you MUST include the network dependency even when network-uri+    -- is pulled in, otherwise the constraint solver doesn't have enough+    -- information+    if flag(network-uri)+      build-depends: network-uri >= 2.6, network >= 2.6+    else+      build-depends: network     >= 2.4 && < 2.6+     if os(windows)       build-depends: Win32 >= 2 && < 3       cpp-options: -DWIN32@@ -146,14 +165,15 @@       build-depends: unix >= 2.0 && < 2.8      if arch(arm) && impl(ghc < 7.6)-       -- older ghc on arm does not supprt -threaded+       -- older ghc on arm does not support -threaded        cc-options:  -DCABAL_NO_THREADED     else        ghc-options: -threaded      c-sources: cbits/getnumcores.c-+    default-language: Haskell2010 +-- Small, fast running tests. Test-Suite unit-tests   type: exitcode-stdio-1.0   main-is: UnitTests.hs@@ -162,7 +182,11 @@   other-modules:     UnitTests.Distribution.Client.Targets     UnitTests.Distribution.Client.Dependency.Modular.PSQ+    UnitTests.Distribution.Client.Dependency.Modular.Solver+    UnitTests.Distribution.Client.Dependency.Modular.DSL+    UnitTests.Distribution.Client.GZipUtils     UnitTests.Distribution.Client.Sandbox+    UnitTests.Distribution.Client.UserConfig   build-depends:         base,         array,@@ -170,26 +194,29 @@         Cabal,         containers,         mtl,-        network,         pretty,         process,         directory,         filepath,         stm,         time,-        network,         HTTP,         zlib,--        test-framework,-        test-framework-hunit,-        test-framework-quickcheck2 >= 0.3,-        HUnit,+        random,+        tasty,+        tasty-hunit,+        tasty-quickcheck,+        tagged,         QuickCheck >= 2.5    if flag(old-directory)     build-depends: old-time +  if flag(network-uri)+    build-depends: network-uri >= 2.6, network >= 2.6+  else+    build-depends: network-uri < 2.6, network < 2.6+   if os(windows)     build-depends: Win32     cpp-options: -DWIN32@@ -200,3 +227,42 @@     cc-options:  -DCABAL_NO_THREADED   else     ghc-options: -threaded+  default-language: Haskell2010++-- Large, system tests that build packages.+test-suite package-tests+  type: exitcode-stdio-1.0+  hs-source-dirs: tests+  main-is: PackageTests.hs+  other-modules:+    PackageTests.Exec.Check+    PackageTests.Freeze.Check+    PackageTests.MultipleSource.Check+    PackageTests.PackageTester+  build-depends:+    Cabal,+    QuickCheck >= 2.1.0.1 && < 2.9,+    base,+    bytestring,+    directory,+    extensible-exceptions,+    filepath,+    process,+    regex-posix,+    tasty,+    tasty-hunit,+    tasty-quickcheck++  if os(windows)+    build-depends: Win32 >= 2 && < 3+    cpp-options: -DWIN32+  else+    build-depends: unix >= 2.0 && < 2.8++  if arch(arm)+    cc-options:  -DCABAL_NO_THREADED+  else+    ghc-options: -threaded++  ghc-options: -Wall+  default-language: Haskell2010

− cabal/cabal-install/cabal.config

@@ -1,1 +0,0 @@-ghc-options: -fno-ignore-asserts

cabal/cabal-install/changelog view

@@ -1,5 +1,73 @@ -*-change-log-*- +1.23.x.x (current development version)+	* If there are multiple remote repos, 'cabal update' now updates+	them in parallel (#2503).+	* New 'cabal upload' option '-P'/'--password-command' for reading+	Hackage password from arbitrary program output (#2506).+	* Better warning for 'cabal run' (#2510).+	* 'cabal init' now warns if the chosen package name is already+	registered in the source package index (#2436).+	* New 'cabal install' option: '--offline' (#2578).+	* Accept 'builddir' field in cabal.config (#2484)+	* Read 'builddir' option from 'CABAL_BUILDDIR' environment variable.+	* Remote repos may now be configured to use https URLs. This uses+	either curl or wget or, on Windows, PowerShell, under the hood (#2687).+	* Install target URLs can now use https e.g. 'cabal install+	https://example.com/foo-1.0.tar.gz'.+	* Automatically use https for cabal upload for the main+	hackage.haskell.org (other repos will use whatever they are+	configured to use).+	* Support for dependencies of custom Setup.hs scripts.+	* 'cabal' program itself now can be used as an external setup+	method. This fixes an issue when Cabal version mismatch caused+	unnecessary reconfigures (#2633).+	* Improved error message for unsatisfiable package constraints+	(#2727).+	* Fixed a space leak in 'cabal update' (#2826).++1.22.0.0 Johan Tibell <johan.tibell@gmail.com> January 2015+	* New command: user-config (#2159).+	* Implement 'cabal repl --only' (#2016).+	* Fix an issue when 'cabal repl' was doing unnecessary compilation+	(#1715).+	* Prompt the user to specify source directory in 'cabal init'+	(#1989).+	* Remove the self-upgrade check (#2090).+	* Don't redownload already downloaded packages when bootstrapping+	(#2133).+	* Support sandboxes in 'bootstrap.sh' (#2137).+	* Install profiling and shared libs by default in 'bootstrap.sh'+	(#2009).++1.20.0.3 Johan Tibell <johan.tibell@gmail.com> June 2014+	* Don't attempt to rename dist if it is already named correctly+	* Treat all flags of a package as interdependent.+	* Allow template-haskell to be upgradable again++1.20.0.2 Johan Tibell <johan.tibell@gmail.com> May 2014+	* Increase max-backjumps to 2000.+	* Fix solver bug which led to missed install plans.+	* Fix streaming test output.+	* Tweak solver heuristics to avoid reinstalls.++1.20.0.1 Johan Tibell <johan.tibell@gmail.com> May 2014+	* Fix cabal repl search path bug on Windows+	* Include OS and arch in cabal-install user agent+	* Revert --constraint flag behavior in configure to 1.18 behavior++1.20.0.0 Johan Tibell <johan.tibell@gmail.com> April 2014+	* Build only selected executables+	* Add -j flag to build/test/bench/run+	* Improve install log file+	* Don't symlink executables when in a sandbox+	* Add --package-db flag to 'list' and 'info'+	* Make upload more efficient+	* Add --require-sandbox option+	* Add experimental Cabal file format command+	* Add haddock section to config file+	* Add --main-is flag to init+ 0.14.0 Andres Loeh <andres@well-typed.com> April 2012 	* Works with ghc-7.4 	* Completely new modular dependency solver (default in most cases)

+ cabal/cabal-install/tests/PackageTests.hs view

@@ -0,0 +1,95 @@+-- | Groups black-box tests of cabal-install and configures them to test+-- the correct binary.+--+-- This file should do nothing but import tests from other modules and run+-- them with the path to the correct cabal-install binary.+module Main+       where++-- Modules from Cabal.+import Distribution.Simple.Configure (findDistPrefOrDefault)+import Distribution.Simple.Program.Builtin (ghcPkgProgram)+import Distribution.Simple.Program.Db+        (defaultProgramDb, requireProgram, setProgramSearchPath)+import Distribution.Simple.Program.Find+        (ProgramSearchPathEntry(ProgramSearchPathDir), defaultProgramSearchPath)+import Distribution.Simple.Program.Types+        ( Program(..), simpleProgram, programPath)+import Distribution.Simple.Setup ( Flag(..) )+import Distribution.Simple.Utils ( findProgramVersion )+import Distribution.Verbosity (normal)++-- Third party modules.+import qualified Control.Exception.Extensible as E+import Distribution.Compat.Environment ( setEnv )+import System.Directory+        ( canonicalizePath, getCurrentDirectory, setCurrentDirectory+        , removeFile, doesFileExist )+import System.FilePath ((</>))+import Test.Tasty (TestTree, defaultMain, testGroup)+import Control.Monad ( when )++-- Module containing common test code.++import PackageTests.PackageTester ( TestsPaths(..)+                                  , packageTestsDirectory+                                  , packageTestsConfigFile )++-- Modules containing the tests.+import qualified PackageTests.Exec.Check+import qualified PackageTests.Freeze.Check+import qualified PackageTests.MultipleSource.Check++-- List of tests to run. Each test will be called with the path to the+-- cabal binary to use.+tests :: PackageTests.PackageTester.TestsPaths -> TestTree+tests paths = testGroup "Package Tests" $+    [ testGroup "Freeze"         $ PackageTests.Freeze.Check.tests         paths+    , testGroup "Exec"           $ PackageTests.Exec.Check.tests           paths+    , testGroup "MultipleSource" $ PackageTests.MultipleSource.Check.tests paths+    ]++cabalProgram :: Program+cabalProgram = (simpleProgram "cabal") {+    programFindVersion = findProgramVersion "--numeric-version" id+  }++main :: IO ()+main = do+    -- Find the builddir used to build Cabal+    distPref <- findDistPrefOrDefault NoFlag+    -- Use the default builddir for all of the subsequent package tests+    setEnv "CABAL_BUILDDIR" "dist"+    buildDir <- canonicalizePath (distPref </> "build/cabal")+    let programSearchPath = ProgramSearchPathDir buildDir : defaultProgramSearchPath+    (cabal, _) <- requireProgram normal cabalProgram+                      (setProgramSearchPath programSearchPath defaultProgramDb)+    (ghcPkg, _) <- requireProgram normal ghcPkgProgram defaultProgramDb+    canonicalConfigPath <- canonicalizePath $ "tests" </> packageTestsDirectory++    let testsPaths = TestsPaths {+          cabalPath = programPath cabal,+          ghcPkgPath = programPath ghcPkg,+          configPath = canonicalConfigPath </> packageTestsConfigFile+        }++    putStrLn $ "Using cabal: "   ++ cabalPath  testsPaths+    putStrLn $ "Using ghc-pkg: " ++ ghcPkgPath testsPaths++    cwd <- getCurrentDirectory+    let confFile = packageTestsDirectory </> "cabal-config"+        removeConf = do+          b <- doesFileExist confFile+          when b $ removeFile confFile+    let runTests = do+          setCurrentDirectory "tests"+          removeConf -- assert that there is no existing config file+                     -- (we want deterministic testing with the default+                     --  config values)+          defaultMain $ tests testsPaths+    runTests `E.finally` do+        -- remove the default config file that got created by the tests+        removeConf+        -- Change back to the old working directory so that the tests can be+        -- repeatedly run in `cabal repl` via `:main`.+        setCurrentDirectory cwd

+ cabal/cabal-install/tests/PackageTests/Exec/Check.hs view

@@ -0,0 +1,145 @@+{-# LANGUAGE CPP #-}+module PackageTests.Exec.Check+       ( tests+       ) where+++import PackageTests.PackageTester++import Test.Tasty+import Test.Tasty.HUnit++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Control.Monad (when)+import Data.List (intercalate, isInfixOf)+import System.FilePath ((</>))+import System.Directory (getDirectoryContents)++dir :: FilePath+dir = packageTestsDirectory </> "Exec"++tests :: TestsPaths -> [TestTree]+tests paths =+    [ testCase "exits with failure if given no argument" $ do+          result <- cabal_exec paths dir []+          assertExecFailed result++    , testCase "prints error message if given no argument" $ do+          result <- cabal_exec paths dir []+          assertExecFailed result+          let output = outputText result+              expected = "specify an executable to run"+              errMsg = "should have requested an executable be specified\n" +++                       output+          assertBool errMsg $+              expected `isInfixOf` (intercalate " " . lines $ output)++    , testCase "runs the given command" $ do+          result <- cabal_exec paths dir ["echo", "this", "string"]+          assertExecSucceeded result+          let output = outputText result+              expected = "this string"+              errMsg = "should have ran the given command\n" ++ output+          assertBool errMsg $+              expected `isInfixOf` (intercalate " " . lines $ output)++    , testCase "can run executables installed in the sandbox" $ do+          -- Test that an executable installed into the sandbox can be found.+          -- We do this by removing any existing sandbox. Checking that the+          -- executable cannot be found. Creating a new sandbox. Installing+          -- the executable and checking it can be run.++          cleanPreviousBuilds paths+          assertMyExecutableNotFound paths+          assertPackageInstall paths++          result <- cabal_exec paths dir ["my-executable"]+          assertExecSucceeded result+          let output = outputText result+              expected = "This is my-executable"+              errMsg = "should have found a my-executable\n" ++ output+          assertBool errMsg $+              expected `isInfixOf` (intercalate " " . lines $ output)++    , testCase "adds the sandbox bin directory to the PATH" $ do+          cleanPreviousBuilds paths+          assertMyExecutableNotFound paths+          assertPackageInstall paths++          result <- cabal_exec paths dir ["bash", "--", "-c", "my-executable"]+          assertExecSucceeded result+          let output = outputText result+              expected = "This is my-executable"+              errMsg = "should have found a my-executable\n" ++ output+          assertBool errMsg $+              expected `isInfixOf` (intercalate " " . lines $ output)++    , testCase "configures GHC to use the sandbox" $ do+          let libNameAndVersion = "my-0.1"++          cleanPreviousBuilds paths+          assertPackageInstall paths++          assertMyLibIsNotAvailableOutsideofSandbox paths libNameAndVersion++          result <- cabal_exec paths dir ["ghc-pkg", "list"]+          assertExecSucceeded result+          let output = outputText result+              errMsg = "my library should have been found"+          assertBool errMsg $+              libNameAndVersion `isInfixOf` (intercalate " " . lines $ output)+          ++    -- , testCase "can find executables built from the package" $ do++    , testCase "configures cabal to use the sandbox" $ do+          let libNameAndVersion = "my-0.1"++          cleanPreviousBuilds paths+          assertPackageInstall paths++          assertMyLibIsNotAvailableOutsideofSandbox paths libNameAndVersion++          result <- cabal_exec paths dir ["bash", "--", "-c", "cd subdir ; cabal sandbox hc-pkg list"]+          assertExecSucceeded result+          let output = outputText result+              errMsg = "my library should have been found"+          assertBool errMsg $+              libNameAndVersion `isInfixOf` (intercalate " " . lines $ output)+    ]++cleanPreviousBuilds :: TestsPaths -> IO ()+cleanPreviousBuilds paths = do+    sandboxExists <- not . null . filter (== "cabal.sandbox.config") <$>+                         getDirectoryContents dir+    assertCleanSucceeded   =<< cabal_clean paths dir []+    when sandboxExists $ do+        assertSandboxSucceeded =<< cabal_sandbox paths dir ["delete"]+++assertPackageInstall :: TestsPaths -> IO ()+assertPackageInstall paths = do+    assertSandboxSucceeded =<< cabal_sandbox paths dir ["init"]+    assertInstallSucceeded =<< cabal_install paths dir []+++assertMyExecutableNotFound :: TestsPaths -> IO ()+assertMyExecutableNotFound paths = do+    result <- cabal_exec paths dir ["my-executable"]+    assertExecFailed result+    let output = outputText result+        expected = "The program 'my-executable' is required but it " +++                   "could not be found"+        errMsg = "should not have found a my-executable\n" ++ output+    assertBool errMsg $+        expected `isInfixOf` (intercalate " " . lines $ output)++++assertMyLibIsNotAvailableOutsideofSandbox :: TestsPaths -> String -> IO ()+assertMyLibIsNotAvailableOutsideofSandbox paths libNameAndVersion = do+    (_, _, output) <- run (Just $ dir) (ghcPkgPath paths) ["list"]+    assertBool "my library should not have been found" $ not $+        libNameAndVersion `isInfixOf` (intercalate " " . lines $ output)

+ cabal/cabal-install/tests/PackageTests/Exec/Foo.hs view

@@ -0,0 +1,4 @@+module Foo where++foo :: String+foo = "foo"

+ cabal/cabal-install/tests/PackageTests/Exec/My.hs view

@@ -0,0 +1,5 @@+module Main where++main :: IO ()+main = do+    putStrLn "This is my-executable"

+ cabal/cabal-install/tests/PackageTests/Exec/my.cabal view

@@ -0,0 +1,14 @@+name:           my+version:        0.1+license:        BSD3+cabal-version:  >= 1.2+build-type:     Simple++library+    exposed-modules:    Foo+    build-depends:      base+++executable my-executable+    main-is:            My.hs+    build-depends:      base

+ cabal/cabal-install/tests/PackageTests/Exec/subdir/.gitkeep view

+ cabal/cabal-install/tests/PackageTests/Freeze/Check.hs view

@@ -0,0 +1,116 @@+{-# LANGUAGE ScopedTypeVariables #-}++module PackageTests.Freeze.Check+       ( tests+       ) where++import PackageTests.PackageTester++import Test.Tasty+import Test.Tasty.HUnit++import qualified Control.Exception.Extensible as E+import Data.List (intercalate, isInfixOf)+import System.Directory (doesFileExist, removeFile)+import System.FilePath ((</>))+import System.IO.Error (isDoesNotExistError)++dir :: FilePath+dir = packageTestsDirectory </> "Freeze"++tests :: TestsPaths -> [TestTree]+tests paths =+    [ testCase "runs without error" $ do+          removeCabalConfig+          result <- cabal_freeze paths dir []+          assertFreezeSucceeded result++    , testCase "freezes direct dependencies" $ do+          removeCabalConfig+          result <- cabal_freeze paths dir []+          assertFreezeSucceeded result+          c <- readCabalConfig+          assertBool ("should have frozen base\n" ++ c) $+              " base ==" `isInfixOf` (intercalate " " $ lines $ c)++    , testCase "freezes transitory dependencies" $ do+          removeCabalConfig+          result <- cabal_freeze paths dir []+          assertFreezeSucceeded result+          c <- readCabalConfig+          assertBool ("should have frozen ghc-prim\n" ++ c) $+              " ghc-prim ==" `isInfixOf` (intercalate " " $ lines $ c)++    , testCase "does not freeze packages which are not dependend upon" $ do+          -- TODO: Test this against a package installed in the sandbox but+          -- not depended upon.+          removeCabalConfig+          result <- cabal_freeze paths dir []+          assertFreezeSucceeded result+          c <- readCabalConfig+          assertBool ("should not have frozen exceptions\n" ++ c) $ not $+              " exceptions ==" `isInfixOf` (intercalate " " $ lines $ c)++    , testCase "does not include a constraint for the package being frozen" $ do+          removeCabalConfig+          result <- cabal_freeze paths dir []+          assertFreezeSucceeded result+          c <- readCabalConfig+          assertBool ("should not have frozen self\n" ++ c) $ not $+              " my ==" `isInfixOf` (intercalate " " $ lines $ c)++    , testCase "--dry-run does not modify the cabal.config file" $ do+          removeCabalConfig+          result <- cabal_freeze paths dir ["--dry-run"]+          assertFreezeSucceeded result+          c <- doesFileExist $ dir </> "cabal.config"+          assertBool "cabal.config file should not have been created" (not c)++    , testCase "--enable-tests freezes test dependencies" $ do+          removeCabalConfig+          result <- cabal_freeze paths dir ["--enable-tests"]+          assertFreezeSucceeded result+          c <- readCabalConfig+          assertBool ("should have frozen test-framework\n" ++ c) $+              " test-framework ==" `isInfixOf` (intercalate " " $ lines $ c)++    , testCase "--disable-tests does not freeze test dependencies" $ do+          removeCabalConfig+          result <- cabal_freeze paths dir ["--disable-tests"]+          assertFreezeSucceeded result+          c <- readCabalConfig+          assertBool ("should not have frozen test-framework\n" ++ c) $ not $+              " test-framework ==" `isInfixOf` (intercalate " " $ lines $ c)++    , testCase "--enable-benchmarks freezes benchmark dependencies" $ do+          removeCabalConfig+          result <- cabal_freeze paths dir ["--disable-benchmarks"]+          assertFreezeSucceeded result+          c <- readCabalConfig+          assertBool ("should not have frozen criterion\n" ++ c) $ not $+              " criterion ==" `isInfixOf` (intercalate " " $ lines $ c)++    , testCase "--disable-benchmarks does not freeze benchmark dependencies" $ do+          removeCabalConfig+          result <- cabal_freeze paths dir ["--disable-benchmarks"]+          assertFreezeSucceeded result+          c <- readCabalConfig+          assertBool ("should not have frozen criterion\n" ++ c) $ not $+              " criterion ==" `isInfixOf` (intercalate " " $ lines $ c)+    ]++removeCabalConfig :: IO ()+removeCabalConfig = do+    removeFile (dir </> "cabal.config")+    `E.catch` \ (e :: IOError) ->+        if isDoesNotExistError e+        then return ()+        else E.throw e+++readCabalConfig :: IO String+readCabalConfig = do+    config <- readFile $ dir </> "cabal.config"+    -- Ensure that the file is closed so that it can be+    -- deleted by the next test on Windows.+    length config `seq` return config

+ cabal/cabal-install/tests/PackageTests/Freeze/my.cabal view

@@ -0,0 +1,21 @@+name:           my+version:        0.1+license:        BSD3+cabal-version:  >= 1.20.0+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-framework++benchmark bench-Foo+    type:   exitcode-stdio-1.0+    hs-source-dirs: benchmarks+    main-is:    benchmark-Foo.hs+    build-depends: base, my, criterion

+ cabal/cabal-install/tests/PackageTests/MultipleSource/Check.hs view

@@ -0,0 +1,28 @@+module PackageTests.MultipleSource.Check+       ( tests+       ) where+++import PackageTests.PackageTester++import Test.Tasty+import Test.Tasty.HUnit++import Control.Monad    (void, when)+import System.Directory (doesDirectoryExist)+import System.FilePath  ((</>))++dir :: FilePath+dir = packageTestsDirectory </> "MultipleSource"++tests :: TestsPaths -> [TestTree]+tests paths =+    [ testCase "finds second source of multiple source" $ do+          sandboxExists <- doesDirectoryExist $ dir </> ".cabal-sandbox"+          when sandboxExists $+            void $ cabal_sandbox paths dir ["delete"]+          assertSandboxSucceeded =<< cabal_sandbox paths dir ["init"]+          assertSandboxSucceeded =<< cabal_sandbox paths dir ["add-source", "p"]+          assertSandboxSucceeded =<< cabal_sandbox paths dir ["add-source", "q"]+          assertInstallSucceeded =<< cabal_install paths dir ["q"]+    ]

+ cabal/cabal-install/tests/PackageTests/MultipleSource/p/LICENSE view

+ cabal/cabal-install/tests/PackageTests/MultipleSource/p/Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ cabal/cabal-install/tests/PackageTests/MultipleSource/p/p.cabal view

@@ -0,0 +1,11 @@+name:                p+version:             0.1.0.0+license-file:        LICENSE+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-install/tests/PackageTests/MultipleSource/q/LICENSE view

+ cabal/cabal-install/tests/PackageTests/MultipleSource/q/Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ cabal/cabal-install/tests/PackageTests/MultipleSource/q/q.cabal view

@@ -0,0 +1,11 @@+name:                q+version:             0.1.0.0+license-file:        LICENSE+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-install/tests/PackageTests/PackageTester.hs view

@@ -0,0 +1,232 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- TODO This module was originally based on the PackageTests.PackageTester+-- module in Cabal, however it has a few differences. I suspect that as+-- this module ages the two modules will diverge further. As such, I have+-- not attempted to merge them into a single module nor to extract a common+-- module from them.  Refactor this module and/or Cabal's+-- PackageTests.PackageTester to remove commonality.+--   2014-05-15 Ben Armston++-- | Routines for black-box testing cabal-install.+--+-- Instead of driving the tests by making library calls into+-- Distribution.Simple.* or Distribution.Client.* this module only every+-- executes the `cabal-install` binary.+--+-- You can set the following VERBOSE environment variable to control+-- the verbosity of the output generated by this module.+module PackageTests.PackageTester+    ( TestsPaths(..)+    , Result(..)++    , packageTestsDirectory+    , packageTestsConfigFile++    -- * Running cabal commands+    , cabal_clean+    , cabal_exec+    , cabal_freeze+    , cabal_install+    , cabal_sandbox+    , run++    -- * Test helpers+    , assertCleanSucceeded+    , assertExecFailed+    , assertExecSucceeded+    , assertFreezeSucceeded+    , assertInstallSucceeded+    , assertSandboxSucceeded+    ) where++import qualified Control.Exception.Extensible as E+import Control.Monad (when, unless)+import Data.Maybe (fromMaybe)+import System.Directory (canonicalizePath, doesFileExist)+import System.Environment (getEnv)+import System.Exit (ExitCode(ExitSuccess))+import System.FilePath ( (<.>)  )+import System.IO (hClose, hGetChar, hIsEOF)+import System.IO.Error (isDoesNotExistError)+import System.Process (runProcess, waitForProcess)+import Test.Tasty.HUnit (Assertion, assertFailure)++import Distribution.Simple.BuildPaths (exeExtension)+import Distribution.Simple.Utils (printRawCommandAndArgs)+import Distribution.Compat.CreatePipe (createPipe)+import Distribution.ReadE (readEOrFail)+import Distribution.Verbosity (Verbosity, flagToVerbosity, normal)++data Success = Failure+             -- | ConfigureSuccess+             -- | BuildSuccess+             -- | TestSuccess+             -- | BenchSuccess+             | CleanSuccess+             | ExecSuccess+             | FreezeSuccess+             | InstallSuccess+             | SandboxSuccess+             deriving (Eq, Show)++data TestsPaths = TestsPaths+    { cabalPath  :: FilePath -- ^ absolute path to cabal executable.+    , ghcPkgPath :: FilePath -- ^ absolute path to ghc-pkg executable.+    , configPath :: FilePath -- ^ absolute path of the default config file+                             --   to use for tests (tests are free to use+                             --   a different one).+    }++data Result = Result+    { successful :: Bool+    , success    :: Success+    , outputText :: String+    } deriving Show++nullResult :: Result+nullResult = Result True Failure ""++------------------------------------------------------------------------+-- * Config++packageTestsDirectory :: FilePath+packageTestsDirectory = "PackageTests"++packageTestsConfigFile :: FilePath+packageTestsConfigFile = "cabal-config"++------------------------------------------------------------------------+-- * Running cabal commands++recordRun :: (String, ExitCode, String) -> Success -> Result -> Result+recordRun (cmd, exitCode, exeOutput) thisSucc res =+    res { successful = successful res && exitCode == ExitSuccess+        , success    = if exitCode == ExitSuccess then thisSucc+                       else success res+        , outputText =+            (if null $ outputText res then "" else outputText res ++ "\n") +++            cmd ++ "\n" ++ exeOutput+        }++-- | Run the clean command and return its result.+cabal_clean :: TestsPaths -> FilePath -> [String] -> IO Result+cabal_clean paths dir args = do+    res <- cabal paths dir (["clean"] ++ args)+    return $ recordRun res CleanSuccess nullResult++-- | Run the exec command and return its result.+cabal_exec :: TestsPaths -> FilePath -> [String] -> IO Result+cabal_exec paths dir args = do+    res <- cabal paths dir (["exec"] ++ args)+    return $ recordRun res ExecSuccess nullResult++-- | Run the freeze command and return its result.+cabal_freeze :: TestsPaths -> FilePath -> [String] -> IO Result+cabal_freeze paths dir args = do+    res <- cabal paths dir (["freeze"] ++ args)+    return $ recordRun res FreezeSuccess nullResult++-- | Run the install command and return its result.+cabal_install :: TestsPaths -> FilePath -> [String] -> IO Result+cabal_install paths dir args = do+    res <- cabal paths dir (["install"] ++ args)+    return $ recordRun res InstallSuccess nullResult++-- | Run the sandbox command and return its result.+cabal_sandbox :: TestsPaths -> FilePath -> [String] -> IO Result+cabal_sandbox paths dir args = do+    res <- cabal paths dir (["sandbox"] ++ args)+    return $ recordRun res SandboxSuccess nullResult++-- | Returns the command that was issued, the return code, and the output text.+cabal :: TestsPaths -> FilePath -> [String] -> IO (String, ExitCode, String)+cabal paths dir cabalArgs = do+    run (Just dir) (cabalPath paths) args+  where+    args = configFileArg : cabalArgs+    configFileArg = "--config-file=" ++ configPath paths++-- | Returns the command that was issued, the return code, and the output text+run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String)+run cwd path args = do+    verbosity <- getVerbosity+    -- 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+                canonicalizePath (if pathExists then path else path <.> exeExtension)+    printRawCommandAndArgs verbosity path' args+    (readh, writeh) <- createPipe+    pid <- runProcess path' args cwd Nothing Nothing (Just writeh) (Just writeh)++    -- fork off a thread to start consuming the output+    out <- suckH [] readh+    hClose readh++    -- wait for the program to terminate+    exitcode <- waitForProcess pid+    let fullCmd = unwords (path' : args)+    return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, exitcode, out)+  where+    suckH output h = do+        eof <- hIsEOF h+        if eof+            then return (reverse output)+            else do+                c <- hGetChar h+                suckH (c:output) h++------------------------------------------------------------------------+-- * Test helpers++assertCleanSucceeded :: Result -> Assertion+assertCleanSucceeded result = unless (successful result) $+    assertFailure $+    "expected: \'cabal clean\' should succeed\n" +++    "  output: " ++ outputText result++assertExecSucceeded :: Result -> Assertion+assertExecSucceeded result = unless (successful result) $+    assertFailure $+    "expected: \'cabal exec\' should succeed\n" +++    "  output: " ++ outputText result++assertExecFailed :: Result -> Assertion+assertExecFailed result = when (successful result) $+    assertFailure $+    "expected: \'cabal exec\' should fail\n" +++    "  output: " ++ outputText result++assertFreezeSucceeded :: Result -> Assertion+assertFreezeSucceeded result = unless (successful result) $+    assertFailure $+    "expected: \'cabal freeze\' should succeed\n" +++    "  output: " ++ outputText result++assertInstallSucceeded :: Result -> Assertion+assertInstallSucceeded result = unless (successful result) $+    assertFailure $+    "expected: \'cabal install\' should succeed\n" +++    "  output: " ++ outputText result++assertSandboxSucceeded :: Result -> Assertion+assertSandboxSucceeded result = unless (successful result) $+    assertFailure $+    "expected: \'cabal sandbox\' should succeed\n" +++    "  output: " ++ outputText result++------------------------------------------------------------------------+-- Verbosity++lookupEnv :: String -> IO (Maybe String)+lookupEnv name =+    (fmap Just $ getEnv name)+    `E.catch` \ (e :: IOError) ->+        if isDoesNotExistError e+        then return Nothing+        else E.throw e++-- TODO: Convert to a "-v" flag instead.+getVerbosity :: IO Verbosity+getVerbosity = do+    maybe normal (readEOrFail flagToVerbosity) `fmap` lookupEnv "VERBOSE"

cabal/cabal-install/tests/UnitTests.hs view

@@ -1,21 +1,39 @@ module Main        where -import Test.Framework+import Test.Tasty+import Test.Tasty.Options  import qualified UnitTests.Distribution.Client.Sandbox+import qualified UnitTests.Distribution.Client.UserConfig import qualified UnitTests.Distribution.Client.Targets+import qualified UnitTests.Distribution.Client.GZipUtils import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ+import qualified UnitTests.Distribution.Client.Dependency.Modular.Solver -tests :: [Test]-tests = [-   testGroup "Distribution.Client.Sandbox"+tests :: TestTree+tests = testGroup "Unit Tests" [+   testGroup "UnitTests.Distribution.Client.UserConfig"+       UnitTests.Distribution.Client.UserConfig.tests+  ,testGroup "Distribution.Client.Sandbox"        UnitTests.Distribution.Client.Sandbox.tests   ,testGroup "Distribution.Client.Targets"        UnitTests.Distribution.Client.Targets.tests+  ,testGroup "Distribution.Client.GZipUtils"+       UnitTests.Distribution.Client.GZipUtils.tests   ,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   ] +-- Extra options for running the test suite+extraOptions :: [OptionDescription]+extraOptions = concat [+    UnitTests.Distribution.Client.Dependency.Modular.Solver.options+  ]+ main :: IO ()-main = defaultMain tests+main = defaultMainWithIngredients+         (includingOptions extraOptions : defaultIngredients)+         tests

+ cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs view

@@ -0,0 +1,322 @@+{-# LANGUAGE RecordWildCards #-}+-- | DSL for testing the modular solver+module UnitTests.Distribution.Client.Dependency.Modular.DSL (+    ExampleDependency(..)+  , ExampleDb+  , exAv+  , exInst+  , exResolve+  , extractInstallPlan+  , withSetupDeps+  ) where++-- base+import Data.Either (partitionEithers)+import Data.Maybe (catMaybes)+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 (HasInstalledPackageId(..))+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++-- 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.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 returned 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++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 [ExampleDependency] [ExampleDependency]++    -- | Dependency if tests are enabled+  | ExTest ExampleTestName [ExampleDependency]++data ExampleAvailable = ExAv {+    exAvName    :: ExamplePkgName+  , exAvVersion :: ExamplePkgVersion+  , exAvDeps    :: ComponentDeps [ExampleDependency]+  }++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+    }++data ExampleInstalled = ExInst {+    exInstName         :: ExamplePkgName+  , exInstVersion      :: ExamplePkgVersion+  , exInstHash         :: ExamplePkgHash+  , exInstBuildAgainst :: [ExampleInstalled]+  }++exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash+       -> [ExampleInstalled] -> ExampleInstalled+exInst = ExInst++type ExampleDb = [Either ExampleInstalled ExampleAvailable]++type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a++exDbPkgs :: ExampleDb -> [ExamplePkgName]+exDbPkgs = map (either exInstName exAvName)++exAvSrcPkg :: ExampleAvailable -> SourcePackage+exAvSrcPkg ex =+    let (libraryDeps, testSuites) = splitTopLevel (CD.libraryDeps (exAvDeps ex))+    in SourcePackage {+           packageInfoId        = exAvPkgId ex+         , packageSource        = LocalTarballPackage "<<path>>"+         , packageDescrOverride = Nothing+         , packageDescription   = C.GenericPackageDescription{+               C.packageDescription = C.emptyPackageDescription {+                   C.package        = exAvPkgId ex+                 , C.library        = 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 = concatMap extractFlags+                                   (CD.libraryDeps (exAvDeps ex))+             , C.condLibrary     = Just $ mkCondTree libraryDeps+             , C.condExecutables = []+             , C.condTestSuites  = map (\(t, deps) -> (t, mkCondTree deps))+                                   testSuites+             , C.condBenchmarks  = []+             }+         }+  where+    splitTopLevel :: [ExampleDependency]+                  -> ( [ExampleDependency]+                     , [(ExampleTestName, [ExampleDependency])]+                     )+    splitTopLevel []                = ([], [])+    splitTopLevel (ExTest t a:deps) =+      let (other, testSuites) = splitTopLevel deps+      in (other, (t, a):testSuites)+    splitTopLevel (dep:deps)        =+      let (other, testSuites) = splitTopLevel deps+      in (dep:other, testSuites)++    extractFlags :: ExampleDependency -> [C.Flag]+    extractFlags (ExAny _)      = []+    extractFlags (ExFix _ _)    = []+    extractFlags (ExFlag f a b) = C.MkFlag {+                                      C.flagName        = C.FlagName f+                                    , C.flagDescription = ""+                                    , C.flagDefault     = False+                                    , C.flagManual      = False+                                    }+                                : concatMap extractFlags (a ++ b)+    extractFlags (ExTest _ a)   = concatMap extractFlags a++    mkCondTree :: Monoid a => [ExampleDependency] -> DependencyTree a+    mkCondTree deps =+      let (directDeps, flaggedDeps) = splitDeps deps+      in C.CondNode {+             C.condTreeData        = mempty -- irrelevant to the solver+           , C.condTreeConstraints = map mkDirect  directDeps+           , C.condTreeComponents  = map mkFlagged 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+              => (ExampleFlagName, [ExampleDependency], [ExampleDependency])+              -> (C.Condition C.ConfVar+                 , DependencyTree a, Maybe (DependencyTree a))+    mkFlagged (f, a, b) = ( C.Var (C.Flag (C.FlagName f))+                          , mkCondTree a+                          , Just (mkCondTree b)+                          )++    splitDeps :: [ExampleDependency]+              -> ( [(ExamplePkgName, Maybe Int)]+                 , [(ExampleFlagName, [ExampleDependency], [ExampleDependency])]+                 )+    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 (ExTest _ _:_) =+      error "Unexpected nested test"++    -- Currently we only support simple setup 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.PackageName (exAvName ex)+    , pkgVersion = Version [exAvVersion ex, 0, 0] []+    }++exInstInfo :: ExampleInstalled -> C.InstalledPackageInfo+exInstInfo ex = C.emptyInstalledPackageInfo {+      C.installedPackageId = C.InstalledPackageId (exInstHash ex)+    , C.sourcePackageId    = exInstPkgId ex+    , C.packageKey         = exInstKey ex+    , C.depends            = map (C.InstalledPackageId . exInstHash)+                                 (exInstBuildAgainst ex)+    }++exInstPkgId :: ExampleInstalled -> C.PackageIdentifier+exInstPkgId ex = C.PackageIdentifier {+      pkgName    = C.PackageName (exInstName ex)+    , pkgVersion = Version [exInstVersion ex, 0, 0] []+    }++exInstLibName :: ExampleInstalled -> C.LibraryName+exInstLibName ex = C.packageKeyLibraryName (exInstPkgId ex) (exInstKey ex)++exInstKey :: ExampleInstalled -> C.PackageKey+exInstKey ex =+    C.mkPackageKey True+                   (exInstPkgId ex)+                   (map exInstLibName (exInstBuildAgainst ex))++exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex SourcePackage+exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg++exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex+exInstIdx = C.PackageIndex.fromList . map exInstInfo++exResolve :: ExampleDb+          -> [ExamplePkgName]+          -> Bool+          -> ([String], Either String CI.InstallPlan.InstallPlan)+exResolve db targets indepGoals = runProgress $+    resolveDependencies C.buildPlatform+                        (C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag)+                        Modular+                        params+  where+    (inst, avai) = partitionEithers db+    instIdx      = exInstIdx inst+    avaiIdx      = SourcePackageDb {+                       packageIndex       = exAvIdx avai+                     , packagePreferences = Map.empty+                     }+    enableTests  = map (\p -> PackageConstraintStanzas+                              (C.PackageName p) [TestStanzas])+                       (exDbPkgs db)+    targets'     = map (\p -> NamedPackage (C.PackageName p) []) targets+    params       = addConstraints (map toLpc enableTests)+                 $ (standardInstallPolicy instIdx avaiIdx targets') {+                       depResolverIndependentGoals = indepGoals+                     }+    toLpc     pc = LabeledPackageConstraint pc ConstraintSourceUnknown++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 -> (String, Int)+    srcPkg (ConfiguredPackage pkg _flags _stanzas _deps) =+      let C.PackageIdentifier (C.PackageName p) (Version (n:_) _) =+            packageInfoId pkg+      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 view

@@ -4,10 +4,10 @@  import Distribution.Client.Dependency.Modular.PSQ -import Test.Framework as TF (Test)-import Test.Framework.Providers.QuickCheck2+import Test.Tasty+import Test.Tasty.QuickCheck -tests :: [TF.Test]+tests :: [TestTree] tests = [ testProperty "splitsAltImplementation" splitsTest         ]

+ cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs view

@@ -0,0 +1,360 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+module UnitTests.Distribution.Client.Dependency.Modular.Solver (tests, options) where++-- base+import Control.Monad+import Data.Maybe (isNothing)+import Data.Proxy+import Data.Typeable++-- test-framework+import Test.Tasty as TF+import Test.Tasty.HUnit (testCase, assertEqual, assertBool)+import Test.Tasty.Options++-- cabal-install+import UnitTests.Distribution.Client.Dependency.Modular.DSL++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)])+        ]+    ]+  where+    indep test = test { testIndepGoals = True }++{-------------------------------------------------------------------------------+  Solver tests+-------------------------------------------------------------------------------}++data SolverTest = SolverTest {+    testLabel      :: String+  , testTargets    :: [String]+  , testResult     :: Maybe [(String, Int)]+  , testIndepGoals :: Bool+  , testDb         :: ExampleDb+  }++mkTest :: ExampleDb+       -> String+       -> [String]+       -> Maybe [(String, Int)]+       -> SolverTest+mkTest db label targets result = SolverTest {+    testLabel      = label+  , testTargets    = targets+  , testResult     = result+  , testIndepGoals = False+  , testDb         = db+  }++runTest :: SolverTest -> TF.TestTree+runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->+    testCase testLabel $ do+      let (_msgs, result) = exResolve testDb testTargets testIndepGoals+      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 exampleDb2, but the flag picks a different package rather than a+-- different package version+--+-- In exampleDb2 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 flagsB 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.B and therefore we cannot link 0.B to 1.B.+--+-- In exampleDb3 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.A, 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 [ExTest "testC" [ExAny "A"]]+  , Right $ exAv "D" 1 [ExTest "testD" [ExFix "B" 2]]+  , Right $ exAv "E" 1 [ExFix "A" 1, ExTest "testE" [ExAny "A"]]+  , Right $ exAv "F" 1 [ExFix "A" 1, ExTest "testF" [ExFix "A" 2]]+  , Right $ exAv "G" 1 [ExFix "A" 2, 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 [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]+    ]++{-------------------------------------------------------------------------------+  Test options+-------------------------------------------------------------------------------}++options :: [OptionDescription]+options = [+    Option (Proxy :: Proxy OptionShowSolverLog)+  ]++newtype OptionShowSolverLog = OptionShowSolverLog Bool+  deriving Typeable++instance IsOption OptionShowSolverLog where+  defaultValue   = OptionShowSolverLog False+  parseValue     = fmap OptionShowSolverLog . safeRead+  optionName     = return "show-solver-log"+  optionHelp     = return "Show full log from the solver"+  optionCLParser = flagCLParser Nothing (OptionShowSolverLog True)

+ cabal/cabal-install/tests/UnitTests/Distribution/Client/GZipUtils.hs view

@@ -0,0 +1,60 @@+module UnitTests.Distribution.Client.GZipUtils (+  tests+  ) where++import Codec.Compression.GZip          as GZip+import Codec.Compression.Zlib          as Zlib+import Control.Exception.Base                  (evaluate)+import Control.Exception                       (try, SomeException)+import Control.Monad                           (void)+import Data.ByteString                as BS    (null)+import Data.ByteString.Lazy           as BSL   (pack, toChunks)+import Data.ByteString.Lazy.Char8     as BSLL  (pack, init, length)+import Data.Monoid                             ((<>))+import Distribution.Client.GZipUtils           (maybeDecompress)+import Data.Word                               (Word8)++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++tests :: [TestTree]+tests = [ testCase "maybeDecompress" maybeDecompressUnitTest+        -- "decompress plain" property is non-trivial to state,+        -- maybeDecompress returns input bytestring only if error occurs right at the beginning of the decompression process+        -- generating such input would essentially duplicate maybeDecompress implementation+        , testProperty "decompress zlib"  prop_maybeDecompress_zlib+        , testProperty "decompress gzip"  prop_maybeDecompress_gzip+        ]++maybeDecompressUnitTest :: Assertion+maybeDecompressUnitTest =+        assertBool "decompress plain"            (maybeDecompress original              == original)+     >> assertBool "decompress zlib (with show)" (show (maybeDecompress compressedZlib) == show original)+     >> assertBool "decompress gzip (with show)" (show (maybeDecompress compressedGZip) == show original)+     >> assertBool "decompress zlib"             (maybeDecompress compressedZlib        == original)+     >> assertBool "decompress gzip"             (maybeDecompress compressedGZip        == original)+     >> assertBool "have no empty chunks"        (Prelude.all (not . BS.null) . BSL.toChunks . maybeDecompress $ compressedZlib)+     >> (runBrokenStream >>= assertBool "decompress broken stream" . isLeft)+  where+    original = BSLL.pack "original uncompressed input"+    compressedZlib = Zlib.compress original+    compressedGZip = GZip.compress original++    runBrokenStream :: IO (Either SomeException ())+    runBrokenStream = try . void . evaluate . BSLL.length $ maybeDecompress (BSLL.init compressedZlib <> BSLL.pack "*")++prop_maybeDecompress_zlib :: [Word8] -> Property+prop_maybeDecompress_zlib ws = property $ maybeDecompress compressedZlib === original+  where original = BSL.pack ws+        compressedZlib = Zlib.compress original++prop_maybeDecompress_gzip :: [Word8] -> Property+prop_maybeDecompress_gzip ws = property $ maybeDecompress compressedGZip === original+  where original = BSL.pack ws+        compressedGZip = GZip.compress original++-- (Only available from "Data.Either" since 7.8.)+isLeft :: Either a b -> Bool+isLeft (Right _) = False+isLeft (Left _) = True

cabal/cabal-install/tests/UnitTests/Distribution/Client/Sandbox.hs view

@@ -2,15 +2,14 @@   tests   ) where -import Distribution.Client.Sandbox    (withSandboxBinDirOnSearchPath)+import Distribution.Client.Sandbox (withSandboxBinDirOnSearchPath) -import Test.Framework                 as TF (Test)-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit                     (Assertion, assertBool, assertEqual)+import Test.Tasty+import Test.Tasty.HUnit -import System.FilePath                (getSearchPath, (</>))+import System.FilePath             (getSearchPath, (</>)) -tests :: [TF.Test]+tests :: [TestTree] tests = [ testCase "sandboxBinDirOnSearchPath" sandboxBinDirOnSearchPathTest         , testCase "oldSearchPathRestored" oldSearchPathRestoreTest         ]

cabal/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs view

@@ -8,13 +8,12 @@ import Distribution.ParseUtils         (parseCommaList) import Distribution.Text               (parse) -import Test.Framework                  as TF (Test)-import Test.Framework.Providers.HUnit  (testCase)-import Test.HUnit                      (Assertion, assertEqual)+import Test.Tasty+import Test.Tasty.HUnit  import Data.Char                       (isSpace) -tests :: [TF.Test]+tests :: [TestTree] tests = [ testCase "readUserConstraint" readUserConstraintTest         , testCase "parseUserConstraint" parseUserConstraintTest         , testCase "readUserConstraints" readUserConstraintsTest

+ cabal/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs view

@@ -0,0 +1,103 @@+{-# LANGUAGE CPP #-}+module UnitTests.Distribution.Client.UserConfig+    ( tests+    ) where++import Control.Exception (bracket)+import Data.List (sort, nub)+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif+import System.Directory (getCurrentDirectory, removeDirectoryRecursive, createDirectoryIfMissing)+import System.FilePath (takeDirectory)++import Test.Tasty+import Test.Tasty.HUnit++import Distribution.Compat.Environment (lookupEnv, setEnv)+import Distribution.Client.Config+import Distribution.Utils.NubList (fromNubList)+import Distribution.Client.Setup (GlobalFlags (..), InstallFlags (..))+import Distribution.Simple.Setup (ConfigFlags (..), fromFlag)+import Distribution.Verbosity (silent)++tests :: [TestTree]+tests = [ testCase "nullDiffOnCreate" nullDiffOnCreateTest+        , testCase "canDetectDifference" canDetectDifference+        , testCase "canUpdateConfig" canUpdateConfig+        , testCase "doubleUpdateConfig" doubleUpdateConfig+        ]++nullDiffOnCreateTest :: Assertion+nullDiffOnCreateTest = bracketTest . const $ do+    -- Create a new default config file in our test directory.+    _ <- loadConfig silent mempty+    -- Now we read it in and compare it against the default.+    diff <- userConfigDiff mempty+    assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff+++canDetectDifference :: Assertion+canDetectDifference = bracketTest . const $ do+    -- Create a new default config file in our test directory.+    _ <- loadConfig silent mempty+    cabalFile <- defaultConfigFile+    appendFile cabalFile "verbose: 0\n"+    diff <- userConfigDiff mempty+    assertBool (unlines $ "Should detect a difference:" : diff) $+        diff == [ "- verbose: 1", "+ verbose: 0" ]+++canUpdateConfig :: Assertion+canUpdateConfig = bracketTest . const $ do+    cabalFile <- defaultConfigFile+    createDirectoryIfMissing True $ takeDirectory cabalFile+    -- Write a trivial cabal file.+    writeFile cabalFile "tests: True\n"+    -- Update the config file.+    userConfigUpdate silent mempty+    -- Load it again.+    updated <- loadConfig silent mempty+    assertBool ("Field 'tests' should be True") $+        fromFlag (configTests $ savedConfigureFlags updated)+++doubleUpdateConfig :: Assertion+doubleUpdateConfig = bracketTest . const $ do+    -- Create a new default config file in our test directory.+    _ <- loadConfig silent mempty+    -- Update it.+    userConfigUpdate silent mempty+    userConfigUpdate silent mempty+    -- Load it again.+    updated <- loadConfig silent mempty++    assertBool ("Field 'remote-repo' doesn't contain duplicates") $+        listUnique (map show . fromNubList . globalRemoteRepos $ savedGlobalFlags updated)+    assertBool ("Field 'extra-prog-path' doesn't contain duplicates") $+        listUnique (map show . fromNubList . configProgramPathExtra $ savedConfigureFlags updated)+    assertBool ("Field 'build-summary' doesn't contain duplicates") $+        listUnique (map show . fromNubList . installSummaryFile $ savedInstallFlags updated)+++listUnique :: Ord a => [a] -> Bool+listUnique xs =+    let sorted = sort xs+    in nub sorted == xs+++bracketTest :: ((FilePath, FilePath) -> IO ()) -> Assertion+bracketTest =+    bracket testSetup testTearDown+  where+    testSetup :: IO (FilePath, FilePath)+    testSetup = do+        Just oldHome <- lookupEnv "HOME"+        testdir <- fmap (++ "/test-user-config") getCurrentDirectory+        setEnv "HOME" testdir+        return (oldHome, testdir)++    testTearDown :: (FilePath, FilePath) -> IO ()+    testTearDown (oldHome, testdir) = do+        setEnv "HOME" oldHome+        removeDirectoryRecursive testdir

+ cabal/setup-dev.sh view

@@ -0,0 +1,50 @@+#!/bin/bash -x+SCRIPT_DIR="`dirname $0`"++die() {+    echo "$*"+    exit 1+}++build_and_test() {+   # Find sandbox location+   local PACKAGEDB=`cabal exec -- sh -c 'echo $GHC_PACKAGE_PATH' | sed 's/:.*//'`+   echo "Cabal package DB location: $PACKAGEDB"+   # Do the building+  ./Setup configure --enable-tests --package-db="$PACKAGEDB" || die "$1 'configure' failed"+  ./Setup build || die "$1 'build' failed"+# Disabled for now: Tests fail on my system for some reason+#  ./Setup test || die "$1 'test' failed"+}++install_deps() {+   cabal install --only-dependencies --enable-tests || die "$1: Could not install needed dependencies"+}++create_setup() {+   ghc --make -threaded Setup.hs || die "$1: Could not create 'Setup' executable"+}++init_sandbox() {+   cabal sandbox delete # Ignore error status; probably just means sandbox doesn't exist+   cabal sandbox init || die "$1: Could not initialize sandbox"+}++setup_cabal() {+   init_sandbox Cabal+   install_deps Cabal+   create_setup Cabal+   build_and_test Cabal+}++setup_cabalinstall() {+   init_sandbox cabal-install+   cabal sandbox add-source ../Cabal/ || die "cabal-install: Failed to add ../Cabal source"+   install_deps cabal-install+   create_setup cabal-install+   build_and_test cabal-install+}++# Build+(cd ${SCRIPT_DIR}/Cabal         && setup_cabal       ) || die "Failed to build Cabal"+(cd ${SCRIPT_DIR}/cabal-install && setup_cabalinstall) || die "Failed to build cabal-install"

+ cabal/stack.yaml view

@@ -0,0 +1,39 @@+flags:+  text:+    integer-simple: false+packages:+- Cabal/+- cabal-install/+extra-deps:+- HTTP-4000.2.20+- mtl-2.2.1+- network-2.6.2.0+- network-uri-2.6.0.3+- old-locale-1.0.0.7+- old-time-1.1.0.3+- parsec-3.1.9+- 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-posix-0.95.2+- tagged-0.8.0.1+- tasty-0.10.1.2+- 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+- tf-random-0.5+- 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

hackport.cabal view

@@ -1,5 +1,5 @@ Name:           hackport-Version:        0.4.6+Version:        0.4.7 License:        GPL License-file:   LICENSE Author:         Henning Günther, Duncan Coutts, Lennart Kolmodin@@ -15,8 +15,6 @@   type: git   location: git://github.com/gentoo-haskell/hackport.git -Flag split-base- Executable    hackport   ghc-options: -Wall   ghc-prof-options: -caf-all -auto-all -rtsopts@@ -41,6 +39,9 @@     extensible-exceptions,     time,     -- cabal depends+    binary,+    random,+    stm,     unix    -- extensions due to hackport@@ -54,16 +55,13 @@     ForeignFunctionInterface,     PatternGuards -  if flag(split-base)-    Build-Depends:-      base >= 3 && < 5,-      directory,-      containers,-      process,-      old-time,-      bytestring-  else-     Build-Depends: base < 3+  Build-Depends:+    base >= 3 && < 5,+    directory,+    containers,+    process,+    old-time,+    bytestring    other-modules:     AnsiColor@@ -112,16 +110,13 @@   -- tar >= 0.3.0.0 && < 0.4     extensible-exceptions -  if flag(split-base)-    Build-Depends:-      base >= 3 && < 5,-      directory,-      containers,-      process,-      old-time,-      bytestring-  else-     Build-Depends: base < 3+  Build-Depends:+    base >= 3 && < 5,+    directory,+    containers,+    process,+    old-time,+    bytestring    other-modules:     Portage.GHCCore@@ -133,6 +128,7 @@   Main-Is:              tests/resolveCat.hs   Hs-Source-Dirs:       ., cabal, cabal/Cabal, cabal/cabal-install, tests   Build-Depends:        base >= 3 && < 5,+                        binary,                         deepseq >= 1.3,                         bytestring,                         containers,@@ -153,6 +149,7 @@   Main-Is:              tests/print_deps.hs   Hs-Source-Dirs:       ., cabal, cabal/Cabal, cabal/cabal-install, tests   Build-Depends:        base >= 3 && < 5,+                        binary,                         deepseq >= 1.3,                         bytestring,                         containers,@@ -173,6 +170,7 @@   Main-Is:              tests/normalize_deps.hs   Hs-Source-Dirs:       ., cabal, cabal/Cabal, cabal/cabal-install, tests   Build-Depends:        base >= 3 && < 5,+                        binary,                         deepseq >= 1.3,                         bytestring,                         containers,