diff --git a/.gitignore b/.gitignore deleted file mode 100644 --- a/.gitignore +++ /dev/null @@ -1,1 +0,0 @@ -dist/ diff --git a/Merge/Dependencies.hs b/Merge/Dependencies.hs --- a/Merge/Dependencies.hs +++ b/Merge/Dependencies.hs @@ -296,7 +296,9 @@ table :: [(String, (String, String))] table = - [("gconf-2.0", ("gnome-base", "gconf")) + [ + ("alsa", ("media-libs", "alsa-lib")) + ,("gconf-2.0", ("gnome-base", "gconf")) ,("gio-2.0", ("dev-libs", "glib:2")) ,("gio-unix-2.0", ("dev-libs", "glib:2")) @@ -307,13 +309,13 @@ ,("gobject-2.0", ("dev-libs", "glib:2")) ,("gthread-2.0", ("dev-libs", "glib:2")) - ,("gtk+-2.0", ("x11-libs", "gtk+")) -- should be slot 2 - ,("gdk-2.0", ("x11-libs", "gtk+")) - ,("gdk-pixbuf-2.0", ("x11-libs", "gtk+")) - ,("gdk-pixbuf-xlib-2.0", ("x11-libs", "gtk+")) - ,("gdk-x11-2.0", ("x11-libs", "gtk+")) - ,("gtk+-unix-print-2.0", ("x11-libs", "gtk+")) - ,("gtk+-x11-2.0", ("x11-libs", "gtk+")) + ,("gtk+-2.0", ("x11-libs", "gtk+:2")) + ,("gdk-2.0", ("x11-libs", "gtk+:2")) + ,("gdk-pixbuf-2.0", ("x11-libs", "gtk+:2")) + ,("gdk-pixbuf-xlib-2.0", ("x11-libs", "gtk+:2")) + ,("gdk-x11-2.0", ("x11-libs", "gtk+:2")) + ,("gtk+-unix-print-2.0", ("x11-libs", "gtk+:2")) + ,("gtk+-x11-2.0", ("x11-libs", "gtk+:2")) ,("cairo", ("x11-libs", "cairo")) -- need [svg] for dev-haskell/cairo ,("cairo-ft", ("x11-libs", "cairo")) @@ -333,7 +335,7 @@ ,("libglade-2.0", ("gnome-base", "libglade")) ,("gnome-vfs-2.0", ("gnome-base", "gnome-vfs")) ,("gnome-vfs-module-2.0", ("gnome-base", "gnome-vfs")) - ,("webkit-1.0", ("net-libs","webkit-gtk")) + ,("webkit-1.0", ("net-libs","webkit-gtk:2")) ,("gstreamer-0.10", ("media-libs", "gstreamer")) ,("gstreamer-base-0.10", ("media-libs", "gstreamer")) @@ -347,9 +349,9 @@ ,("gstreamer-video-0.10", ("media-libs", "gst-plugins-base")) ,("gstreamer-plugins-base-0.10", ("media-libs", "gst-plugins-base")) - ,("gtksourceview-2.0", ("x11-libs", "gtksourceview")) + ,("gtksourceview-2.0", ("x11-libs", "gtksourceview:2.0")) ,("librsvg-2.0", ("gnome-base","librsvg")) - ,("vte", ("x11-libs","vte")) + ,("vte", ("x11-libs","vte:0")) ,("gtkglext-1.0", ("x11-libs","gtkglext")) ,("curl", ("net-misc", "curl")) diff --git a/Portage/EBuild.hs b/Portage/EBuild.hs --- a/Portage/EBuild.hs +++ b/Portage/EBuild.hs @@ -11,6 +11,7 @@ import Distribution.License as Cabal +import Data.String.Utils import Data.Version(Version(..)) import qualified Paths_hackport(version) @@ -93,7 +94,7 @@ ss "MY_P=". quote "${MY_PN}-${PV}". nl. nl). ss "DESCRIPTION=". quote (description ebuild). nl. ss "HOMEPAGE=". quote (expandVars (homepage ebuild)). nl. - ss "SRC_URI=". quote (src_uri ebuild). nl. + ss "SRC_URI=". quote (toMirror $ src_uri ebuild). nl. nl. ss "LICENSE=". quote (convertLicense . license $ ebuild). (if null (licenseComment . license $ ebuild) then id @@ -111,6 +112,7 @@ where expandVars = replaceMultiVars [ ( name ebuild, "${PN}") , (hackage_name ebuild, "${HACKAGE_N}") ] + toMirror = replace "http://hackage.haskell.org/" "mirror://hackage/" ss :: String -> String -> String ss = showString diff --git a/Portage/GHCCore.hs b/Portage/GHCCore.hs --- a/Portage/GHCCore.hs +++ b/Portage/GHCCore.hs @@ -25,7 +25,7 @@ defaultGHC = let (g,pix) = ghc6123 in (g, packageNamesFromPackageIndex pix) ghcs :: [(CompilerId, PackageIndex)] -ghcs = [ghc682, ghc6101, ghc6104, ghc6121, ghc6122, ghc6123, ghc701] +ghcs = [ghc6104, ghc6121, ghc6122, ghc6123, ghc701, ghc742, ghc761] cabalFromGHC :: [Int] -> Maybe Version cabalFromGHC ver = lookup ver table @@ -43,6 +43,8 @@ ,([6,12,2], Version [1,8,0,4] []) ,([6,12,3], Version [1,8,0,6] []) ,([7,0,1], Version [1,10,0,0] []) + ,([7,4,2], Version [1,14,0] []) + ,([7,6,1], Version [1,16,0] []) ] platform :: Platform @@ -90,13 +92,17 @@ | pi@(PackageIdentifier name version) <- pids ] packageNamesFromPackageIndex :: PackageIndex -> [PackageName] -packageNamesFromPackageIndex pix = nub $ - [ (pkgName . sourcePackageId) p | (p:_) <- allPackagesByName pix ] +packageNamesFromPackageIndex pix = nub $ map fst $ allPackagesByName pix ghc :: [Int] -> CompilerId ghc nrs = CompilerId GHC (Version nrs []) --- | Core packages in GHC 7.0.1 as a 'PackageIndex'. +ghc761 :: (CompilerId, PackageIndex) +ghc761 = (ghc [7,6,1], mkIndex ghc761_pkgs) + +ghc742 :: (CompilerId, PackageIndex) +ghc742 = (ghc [7,4,2], mkIndex ghc742_pkgs) + ghc701 :: (CompilerId, PackageIndex) ghc701 = (ghc [7,0,1], mkIndex ghc701_pkgs) @@ -112,23 +118,70 @@ ghc6104 :: (CompilerId, PackageIndex) ghc6104 = (ghc [6,10,4], mkIndex ghc6104_pkgs) -ghc6101 :: (CompilerId, PackageIndex) -ghc6101 = (ghc [6,10,1], mkIndex ghc6101_pkgs) - -ghc682 :: (CompilerId, PackageIndex) -ghc682 = (ghc [6,8,2], mkIndex ghc682_pkgs) - -- | Non-upgradeable core packages -- Source: http://haskell.org/haskellwiki/Libraries_released_with_GHC + +ghc761_pkgs :: [PackageIdentifier] +ghc761_pkgs = + [ p "array" [0,4,0,1] + , p "base" [4,6,0,0] +-- , p "binary" [0,5,1,1] package is upgradeable + , p "bytestring" [0,10,0,8] +-- , p "Cabal" [1,16,0] package is upgradeable + , p "containers" [0,5,0,0] + , p "deepseq" [1,3,0,1] + , p "directory" [1,2,0,0] + , p "filepath" [1,3,0,1] + , p "ghc-prim" [0,3,0,0] + , p "haskell2010" [1,1,1,0] + , p "haskell98" [2,0,0,2] + , p "hoopl" [3,9,0,0] -- used by libghc + , p "hpc" [0,6,0,0] -- used by libghc + , p "integer-gmp" [0,5,0,0] + , p "old-locale" [1,0,0,5] + , p "old-time" [1,1,0,1] + , p "pretty" [1,1,1,0] + , p "process" [1,1,0,2] + , p "template-haskell" [2,8,0,0] -- used by libghc + , p "time" [1,4,0,1] -- used by haskell98 + , p "unix" [2,6,0,0] + ] + +ghc742_pkgs :: [PackageIdentifier] +ghc742_pkgs = + [ p "array" [0,4,0,0] + , p "base" [4,5,1,0] +-- , p "binary" [0,5,1,0] package is upgradeable + , p "bytestring" [0,9,1,8] +-- , p "Cabal" [1,14,0] package is upgradeable + , p "containers" [0,4,2,1] + , p "directory" [1,1,0,2] +-- , p "extensible-exceptions" [0,1,1,4] -- package is upgradeable, stopped shipping in 7.6 + , p "filepath" [1,3,0,0] + , p "ghc-prim" [0,2,0,0] + , p "haskell2010" [1,1,0,1] + , p "haskell98" [2,0,0,1] + , p "hoopl" [3,8,7,3] -- used by libghc + , p "hpc" [0,5,1,1] -- used by libghc + , p "integer-gmp" [0,4,0,0] + , p "old-locale" [1,0,0,4] + , p "old-time" [1,1,0,0] + , p "pretty" [1,1,1,0] + , p "process" [1,1,0,1] + , p "template-haskell" [2,7,0,0] -- used by libghc + , p "time" [1,4] -- used by haskell98 + , p "unix" [2,5,1,1] + ] + ghc701_pkgs :: [PackageIdentifier] -ghc701_pkgs = +ghc701_pkgs = [ p "array" [0,3,0,2] , p "base" [4,3,0,0] , p "bytestring" [0,9,1,8] -- , p "Cabal" [1,10,0,0] package is upgradeable , p "containers" [0,4,0,0] , p "directory" [1,1,0,0] - , p "extensible-exceptions" [0,1,1,2] +-- , p "extensible-exceptions" [0,1,1,2] -- package is upgradeable, stopped shipping in 7.6 , p "filepath" [1,2,0,0] , p "haskell2010" [1,0,0,0] , p "haskell98" [1,1,0,0] @@ -147,7 +200,7 @@ ] ghc6123_pkgs :: [PackageIdentifier] -ghc6123_pkgs = +ghc6123_pkgs = [ p "array" [0,3,0,1] , p "base" [3,0,3,2] , p "base" [4,2,0,2] @@ -155,7 +208,7 @@ -- , p "Cabal" [1,8,0,6] package is upgradeable , p "containers" [0,3,0,0] , p "directory" [1,0,1,1] - , p "extensible-exceptions" [0,1,1,1] +-- , p "extensible-exceptions" [0,1,1,1] -- package is upgradeable, stopped shipping in 7.6 , p "filepath" [1,1,0,4] , p "haskell98" [1,0,1,1] , p "hpc" [0,5,0,5] @@ -182,7 +235,7 @@ -- , p "Cabal" [1,8,0,4] package is upgradeable , p "containers" [0,3,0,0] , p "directory" [1,0,1,1] - , p "extensible-exceptions" [0,1,1,1] +-- , p "extensible-exceptions" [0,1,1,1] -- package is upgradeable, stopped shipping in 7.6 , p "filepath" [1,1,0,4] , p "haskell98" [1,0,1,1] , p "hpc" [0,5,0,5] @@ -201,7 +254,7 @@ ] ghc6121_pkgs :: [PackageIdentifier] -ghc6121_pkgs = +ghc6121_pkgs = [ p "array" [0,3,0,0] , p "base" [3,0,3,2] , p "base" [4,2,0,0] @@ -209,7 +262,7 @@ -- , p "Cabal" [1,8,0,2] package is upgradeable , p "containers" [0,3,0,0] , p "directory" [1,0,1,0] - , p "extensible-exceptions" [0,1,1,1] +-- , p "extensible-exceptions" [0,1,1,1] -- package is upgradeable, stopped shipping in 7.6 , p "filepath" [1,1,0,3] , p "haskell98" [1,0,1,1] , p "hpc" [0,5,0,4] @@ -236,7 +289,7 @@ -- , p "Cabal" [1,6,0,3] package is upgradeable , p "containers" [0,2,0,1 ] , p "directory" [1,0,0,3] - , p "extensible-exceptions" [0,1,1,0] +-- , p "extensible-exceptions" [0,1,1,0] -- package is upgradeable, stopped shipping in 7.6 , p "filepath" [1,1,0,2] , p "haskell98" [1,0,1,0] , p "hpc" [0,5,0,3] @@ -250,52 +303,6 @@ , p "template-haskell" [2,3,0,1] -- , p "time" [1,1,4] package is upgradeable , p "unix" [2,3,2,0] - ] - -ghc6101_pkgs :: [PackageIdentifier] -ghc6101_pkgs = - [ p "array" [0,2,0,0] - , p "base" [3,0,3,0] - , p "base" [4,0,0,0] - , p "bytestring" [0,9,1,4] --- , p "Cabal" [1,6,0,1] package is upgradeable - , p "containers" [0,2,0,0] - , p "directory" [1,0,0,2] - , p "extensible-exceptions" [0,1,0,0] - , p "filepath" [1,1,0,1] - , p "haskell98" [1,0,1,0] - , p "hpc" [0,5,0,2] - , p "old-locale" [1,0,0,1] - , p "old-time" [1,0,0,1] - , p "packedstring" [0,1,0,1] - , p "pretty" [1,0,1,0] - , p "process" [1,0,1,0] --- , p "random" [1,0,0,1] -- will not be shipped starting from ghc-7.2 --- , p "syb" [0,1,0,0] -- not distributed with ghc-7 - , p "template-haskell" [2,3,0,0] - , p "unix" [2,3,1,0] - ] - -ghc682_pkgs :: [PackageIdentifier] -ghc682_pkgs = - [ p "array" [0,1,0,0] - , p "base" [3,0,1,0] - , p "bytestring" [0,9,0,1] --- , p "Cabal" [1,2,3,0] package is upgradeable - , p "containers" [0,1,0,1] - , p "dictionary" [1,0,0,0] - , p "filepath" [1,1,0,0] - , p "haskell98" [1,0,1,0] - , p "hpc" [0,5,0,0] - , p "old-locale" [1,0,0,0] - , p "old-time" [1,0,0,0] - , p "packedstring" [0,1,0,0] - , p "pretty" [1,0,0,0] - , p "process" [1,0,0,0] --- , p "random" [1,0,0,0] -- will not be shipped starting from ghc-7.2 --- , p "readline" [1,0,1,0] - , p "template-haskell" [2,2,0,0] - , p "unix" [2,3,0,0] ] p :: String -> [Int] -> PackageIdentifier diff --git a/cabal/.darcs-boring b/cabal/.darcs-boring deleted file mode 100644 --- a/cabal/.darcs-boring +++ /dev/null @@ -1,6 +0,0 @@ -^dist(/|$) -^setup(/|$) -^GNUmakefile$ -^Makefile.local$ -^.depend(.bak)?$ -^doc/.depend(.bak)?$ diff --git a/cabal/Cabal/Cabal.cabal b/cabal/Cabal/Cabal.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Cabal.cabal @@ -0,0 +1,193 @@ +Name: Cabal +Version: 1.17.0 +Copyright: 2003-2006, Isaac Jones + 2005-2011, Duncan Coutts +License: BSD3 +License-File: LICENSE +Author: Isaac Jones + Duncan Coutts +Maintainer: cabal-devel@haskell.org +Homepage: http://www.haskell.org/cabal/ +bug-reports: https://github.com/haskell/cabal/issues +Synopsis: A framework for packaging Haskell software +Description: + The Haskell Common Architecture for Building Applications and + Libraries: a framework defining a common interface for authors to more + easily build their Haskell applications in a portable way. + . + The Haskell Cabal is part of a larger infrastructure for distributing, + organizing, and cataloging Haskell libraries and tools. +Category: Distribution +cabal-version: >=1.10 +Build-Type: Custom +-- Even though we do use the default Setup.lhs it's vital to bootstrapping +-- that we build Setup.lhs using our own local Cabal source code. + +Extra-Source-Files: + README changelog + +source-repository head + type: git + location: https://github.com/haskell/cabal/ + subdir: Cabal + +Flag base4 + Description: Choose the even newer, even smaller, split-up base package. + +Flag base3 + Description: Choose the new smaller, split-up base package. + +Flag bytestring-in-base + +Library + build-depends: base >= 2 && < 5, + deepseq >= 1.3 && < 1.4, + filepath >= 1 && < 1.4 + if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 } + if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 } + if flag(base3) + Build-Depends: directory >= 1 && < 1.3, + process >= 1 && < 1.2, + old-time >= 1 && < 1.2, + containers >= 0.1 && < 0.6, + array >= 0.1 && < 0.5, + pretty >= 1 && < 1.2 + if flag(bytestring-in-base) + Build-Depends: base >= 2.0 && < 2.2 + else + Build-Depends: base < 2.0 || >= 3.0, bytestring >= 0.9 + + if !os(windows) + Build-Depends: unix >= 2.0 && < 2.7 + + ghc-options: -Wall -fno-ignore-asserts + if impl(ghc >= 6.8) + ghc-options: -fwarn-tabs + nhc98-Options: -K4M + + Exposed-Modules: + Distribution.Compiler, + Distribution.InstalledPackageInfo, + Distribution.License, + Distribution.Make, + Distribution.ModuleName, + Distribution.Package, + Distribution.PackageDescription, + Distribution.PackageDescription.Configuration, + Distribution.PackageDescription.Parse, + Distribution.PackageDescription.Check, + Distribution.PackageDescription.PrettyPrint, + Distribution.ParseUtils, + Distribution.ReadE, + Distribution.Simple, + Distribution.Simple.Build, + Distribution.Simple.Build.Macros, + Distribution.Simple.Build.PathsModule, + Distribution.Simple.BuildPaths, + Distribution.Simple.Bench, + Distribution.Simple.Command, + Distribution.Simple.Compiler, + Distribution.Simple.Configure, + Distribution.Simple.GHC, + Distribution.Simple.LHC, + Distribution.Simple.Haddock, + Distribution.Simple.Hpc, + Distribution.Simple.Hugs, + Distribution.Simple.Install, + Distribution.Simple.InstallDirs, + Distribution.Simple.JHC, + Distribution.Simple.LocalBuildInfo, + Distribution.Simple.NHC, + Distribution.Simple.PackageIndex, + Distribution.Simple.PreProcess, + Distribution.Simple.PreProcess.Unlit, + Distribution.Simple.Program, + Distribution.Simple.Program.Ar, + Distribution.Simple.Program.Builtin, + Distribution.Simple.Program.Db, + Distribution.Simple.Program.GHC, + Distribution.Simple.Program.HcPkg, + Distribution.Simple.Program.Hpc, + Distribution.Simple.Program.Ld, + Distribution.Simple.Program.Run, + Distribution.Simple.Program.Script, + Distribution.Simple.Program.Types, + Distribution.Simple.Register, + Distribution.Simple.Setup, + Distribution.Simple.SrcDist, + Distribution.Simple.Test, + Distribution.Simple.UHC, + Distribution.Simple.UserHooks, + Distribution.Simple.Utils, + Distribution.System, + Distribution.TestSuite, + Distribution.Text, + Distribution.Verbosity, + Distribution.Version, + Distribution.Compat.ReadP, + Language.Haskell.Extension + + Other-Modules: + Distribution.GetOpt, + Distribution.Compat.Exception, + Distribution.Compat.CopyFile, + Distribution.Compat.TempFile, + Distribution.Simple.GHC.IPI641, + Distribution.Simple.GHC.IPI642, + Paths_Cabal + + Default-Language: Haskell98 + Default-Extensions: CPP + +-- Small, fast running tests. +test-suite unit-tests + type: exitcode-stdio-1.0 + main-is: UnitTests.hs + hs-source-dirs: tests + build-depends: + base, + test-framework, + test-framework-hunit, + test-framework-quickcheck2, + HUnit, + QuickCheck, + Cabal + Default-Language: Haskell98 + +-- Large, system tests that build packages. +test-suite package-tests + type: exitcode-stdio-1.0 + main-is: PackageTests.hs + other-modules: PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check, + PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check, + PackageTests.BuildDeps.InternalLibrary0.Check, + PackageTests.BuildDeps.InternalLibrary1.Check, + PackageTests.BuildDeps.InternalLibrary2.Check, + PackageTests.BuildDeps.InternalLibrary3.Check, + PackageTests.BuildDeps.InternalLibrary4.Check, + PackageTests.BuildDeps.TargetSpecificDeps1.Check, + PackageTests.BuildDeps.TargetSpecificDeps2.Check, + PackageTests.BuildDeps.TargetSpecificDeps3.Check, + PackageTests.BuildDeps.SameDepsAllRound.Check, + PackageTests.TestOptions.Check, + PackageTests.TestStanza.Check, + PackageTests.TestSuiteExeV10.Check, + PackageTests.BenchmarkStanza.Check, + PackageTests.TemplateHaskell.Check, + PackageTests.PackageTester + hs-source-dirs: tests + build-depends: + base, + test-framework, + test-framework-quickcheck2 >= 0.2.12, + test-framework-hunit, + HUnit, + QuickCheck >= 2.1.0.1, + Cabal, + process, + directory, + filepath, + extensible-exceptions, + bytestring, + unix + Default-Language: Haskell98 diff --git a/cabal/Cabal/DefaultSetup.hs b/cabal/Cabal/DefaultSetup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/DefaultSetup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/Cabal/Distribution/Compat/CopyFile.hs b/cabal/Cabal/Distribution/Compat/CopyFile.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Compat/CopyFile.hs @@ -0,0 +1,115 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +-- #hide +module Distribution.Compat.CopyFile ( + copyFile, + copyOrdinaryFile, + copyExecutableFile, + setFileOrdinary, + setFileExecutable, + setDirOrdinary, + ) where + +#ifdef __GLASGOW_HASKELL__ + +import Control.Monad + ( when ) +import Control.Exception + ( bracket, bracketOnError ) +import Distribution.Compat.Exception + ( catchIO ) +#if __GLASGOW_HASKELL__ >= 608 +import Distribution.Compat.Exception + ( throwIOIO ) +import System.IO.Error + ( ioeSetLocation ) +#endif +import System.Directory + ( renameFile, removeFile ) +import Distribution.Compat.TempFile + ( openBinaryTempFile ) +import System.FilePath + ( takeDirectory ) +import System.IO + ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf ) +import Foreign + ( allocaBytes ) +#endif /* __GLASGOW_HASKELL__ */ + +#ifndef mingw32_HOST_OS +#if __GLASGOW_HASKELL__ >= 611 +import System.Posix.Internals (withFilePath) +#else +import Foreign.C (withCString) +#endif +import System.Posix.Types + ( FileMode ) +import System.Posix.Internals + ( c_chmod ) +#if __GLASGOW_HASKELL__ >= 608 +import Foreign.C + ( throwErrnoPathIfMinus1_ ) +#else +import Foreign.C + ( throwErrnoIfMinus1_ ) +#endif +#endif /* mingw32_HOST_OS */ + +copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO () +copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest +copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest + +setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () +#ifndef mingw32_HOST_OS +setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- +setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x + +setFileMode :: FilePath -> FileMode -> IO () +setFileMode name m = +#if __GLASGOW_HASKELL__ >= 611 + withFilePath name $ \s -> do +#else + withCString name $ \s -> do +#endif +#if __GLASGOW_HASKELL__ >= 608 + throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) +#else + throwErrnoIfMinus1_ name (c_chmod s m) +#endif +#else +setFileOrdinary _ = return () +setFileExecutable _ = return () +#endif +-- This happens to be true on Unix and currently on Windows too: +setDirOrdinary = setFileExecutable + +copyFile :: FilePath -> FilePath -> IO () +#ifdef __GLASGOW_HASKELL__ +copyFile fromFPath toFPath = + copy +#if __GLASGOW_HASKELL__ >= 608 + `catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "copyFile")) +#endif + where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> + bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> + do allocaBytes bufferSize $ copyContents hFrom hTmp + hClose hTmp + renameFile tmpFPath toFPath + openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp" + cleanTmp (tmpFPath, hTmp) = do + hClose hTmp `catchIO` \_ -> return () + removeFile tmpFPath `catchIO` \_ -> return () + bufferSize = 4096 + + copyContents hFrom hTo buffer = do + count <- hGetBuf hFrom buffer bufferSize + when (count > 0) $ do + hPutBuf hTo buffer count + copyContents hFrom hTo buffer +#else +copyFile fromFPath toFPath = readFile fromFPath >>= writeFile toFPath +#endif diff --git a/cabal/Cabal/Distribution/Compat/Exception.hs b/cabal/Cabal/Distribution/Compat/Exception.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Compat/Exception.hs @@ -0,0 +1,61 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} + +#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610)) +#define NEW_EXCEPTION +#endif + +module Distribution.Compat.Exception ( + Exception.IOException, + onException, + catchIO, + catchExit, + throwIOIO, + tryIO, + ) where + +import System.Exit +import qualified Control.Exception as Exception + +onException :: IO a -> IO b -> IO a +#ifdef NEW_EXCEPTION +onException = Exception.onException +#else +onException io what = io `Exception.catch` \e -> do what + Exception.throw e +#endif + +throwIOIO :: Exception.IOException -> IO a +#ifdef NEW_EXCEPTION +throwIOIO = Exception.throwIO +#else +throwIOIO = Exception.throwIO . Exception.IOException +#endif + +tryIO :: IO a -> IO (Either Exception.IOException a) +#ifdef NEW_EXCEPTION +tryIO = Exception.try +#else +tryIO = Exception.tryJust Exception.ioErrors +#endif + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#ifdef NEW_EXCEPTION +catchIO = Exception.catch +#else +catchIO = Exception.catchJust Exception.ioErrors +#endif + +catchExit :: IO a -> (ExitCode -> IO a) -> IO a +#ifdef NEW_EXCEPTION +catchExit = Exception.catch +#else +catchExit = Exception.catchJust exitExceptions + where exitExceptions (Exception.ExitException ee) = Just ee + exitExceptions _ = Nothing +#endif + diff --git a/cabal/Cabal/Distribution/Compat/ReadP.hs b/cabal/Cabal/Distribution/Compat/ReadP.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Compat/ReadP.hs @@ -0,0 +1,381 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compat.ReadP +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This is a library of parser combinators, originally written by Koen Claessen. +-- It parses all alternatives in parallel, so it never keeps hold of +-- the beginning of the input string, a common source of space leaks with +-- other parsers. The '(+++)' choice combinator is genuinely commutative; +-- it makes no difference which branch is \"shorter\". +-- +-- See also Koen's paper /Parallel Parsing Processes/ +-- (). +-- +-- This version of ReadP has been locally hacked to make it H98, by +-- Martin Sjögren +-- +-- The unit tests have been moved to UnitTest.Distribution.Compat.ReadP, by +-- Mark Lentczner +----------------------------------------------------------------------------- + +module Distribution.Compat.ReadP + ( + -- * The 'ReadP' type + ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus + + -- * Primitive operations + get, -- :: ReadP Char + look, -- :: ReadP String + (+++), -- :: ReadP a -> ReadP a -> ReadP a + (<++), -- :: ReadP a -> ReadP a -> ReadP a + gather, -- :: ReadP a -> ReadP (String, a) + + -- * Other operations + pfail, -- :: ReadP a + satisfy, -- :: (Char -> Bool) -> ReadP Char + char, -- :: Char -> ReadP Char + string, -- :: String -> ReadP String + munch, -- :: (Char -> Bool) -> ReadP String + munch1, -- :: (Char -> Bool) -> ReadP String + skipSpaces, -- :: ReadP () + choice, -- :: [ReadP a] -> ReadP a + count, -- :: Int -> ReadP a -> ReadP [a] + between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a + option, -- :: a -> ReadP a -> ReadP a + optional, -- :: ReadP a -> ReadP () + many, -- :: ReadP a -> ReadP [a] + many1, -- :: ReadP a -> ReadP [a] + skipMany, -- :: ReadP a -> ReadP () + skipMany1, -- :: ReadP a -> ReadP () + sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a] + sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] + endBy, -- :: ReadP a -> ReadP sep -> ReadP [a] + endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] + chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a + chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a + chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a + chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a + manyTill, -- :: ReadP a -> ReadP end -> ReadP [a] + + -- * Running a parser + ReadS, -- :: *; = String -> [(a,String)] + readP_to_S, -- :: ReadP a -> ReadS a + readS_to_P -- :: ReadS a -> ReadP a + ) + where + +import Control.Monad( MonadPlus(..), liftM2 ) +import Data.Char (isSpace) + +infixr 5 +++, <++ + +-- --------------------------------------------------------------------------- +-- The P type +-- is representation type -- should be kept abstract + +data P s a + = Get (s -> P s a) + | Look ([s] -> P s a) + | Fail + | Result a (P s a) + | Final [(a,[s])] -- invariant: list is non-empty! + +-- Monad, MonadPlus + +instance Monad (P s) where + return x = Result x Fail + + (Get f) >>= k = Get (\c -> f c >>= k) + (Look f) >>= k = Look (\s -> f s >>= k) + Fail >>= _ = Fail + (Result x p) >>= k = k x `mplus` (p >>= k) + (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s] + + fail _ = Fail + +instance MonadPlus (P s) where + mzero = Fail + + -- most common case: two gets are combined + Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c) + + -- results are delivered as soon as possible + Result x p `mplus` q = Result x (p `mplus` q) + p `mplus` Result x q = Result x (p `mplus` q) + + -- fail disappears + Fail `mplus` p = p + p `mplus` Fail = p + + -- two finals are combined + -- final + look becomes one look and one final (=optimization) + -- final + sthg else becomes one look and one final + Final r `mplus` Final t = Final (r ++ t) + Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s)) + Final r `mplus` p = Look (\s -> Final (r ++ run p s)) + Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r)) + p `mplus` Final r = Look (\s -> Final (run p s ++ r)) + + -- two looks are combined (=optimization) + -- look + sthg else floats upwards + Look f `mplus` Look g = Look (\s -> f s `mplus` g s) + Look f `mplus` p = Look (\s -> f s `mplus` p) + p `mplus` Look f = Look (\s -> p `mplus` f s) + +-- --------------------------------------------------------------------------- +-- The ReadP type + +newtype Parser r s a = R ((a -> P s r) -> P s r) +type ReadP r a = Parser r Char a + +-- Functor, Monad, MonadPlus + +instance Functor (Parser r s) where + fmap h (R f) = R (\k -> f (k . h)) + +instance Monad (Parser r s) where + return x = R (\k -> k x) + fail _ = R (\_ -> Fail) + R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) + +--instance MonadPlus (Parser r s) where +-- mzero = pfail +-- mplus = (+++) + +-- --------------------------------------------------------------------------- +-- Operations over P + +final :: [(a,[s])] -> P s a +-- Maintains invariant for Final constructor +final [] = Fail +final r = Final r + +run :: P c a -> ([c] -> [(a, [c])]) +run (Get f) (c:s) = run (f c) s +run (Look f) s = run (f s) s +run (Result x p) s = (x,s) : run p s +run (Final r) _ = r +run _ _ = [] + +-- --------------------------------------------------------------------------- +-- Operations over ReadP + +get :: ReadP r Char +-- ^ Consumes and returns the next character. +-- Fails if there is no input left. +get = R Get + +look :: ReadP r String +-- ^ Look-ahead: returns the part of the input that is left, without +-- consuming it. +look = R Look + +pfail :: ReadP r a +-- ^ Always fails. +pfail = R (\_ -> Fail) + +(+++) :: ReadP r a -> ReadP r a -> ReadP r a +-- ^ Symmetric choice. +R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k) + +(<++) :: ReadP a a -> ReadP r a -> ReadP r a +-- ^ Local, exclusive, left-biased choice: If left parser +-- locally produces any result at all, then right parser is +-- not used. +R f <++ q = + do s <- look + probe (f return) s 0 + where + probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int) + probe (Look f') s n = probe (f' s) s n + probe p@(Result _ _) _ n = discard n >> R (p >>=) + probe (Final r) _ _ = R (Final r >>=) + probe _ _ _ = q + + discard 0 = return () + discard n = get >> discard (n-1 :: Int) + +gather :: ReadP (String -> P Char r) a -> ReadP r (String, a) +-- ^ Transforms a parser into one that does the same, but +-- in addition returns the exact characters read. +-- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument +-- is built using any occurrences of readS_to_P. +gather (R m) = + R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) + where + gath l (Get f) = Get (\c -> gath (l.(c:)) (f c)) + gath _ Fail = Fail + gath l (Look f) = Look (\s -> gath l (f s)) + gath l (Result k p) = k (l []) `mplus` gath l p + gath _ (Final _) = error "do not use readS_to_P in gather!" + +-- --------------------------------------------------------------------------- +-- Derived operations + +satisfy :: (Char -> Bool) -> ReadP r Char +-- ^ Consumes and returns the next character, if it satisfies the +-- specified predicate. +satisfy p = do c <- get; if p c then return c else pfail + +char :: Char -> ReadP r Char +-- ^ Parses and returns the specified character. +char c = satisfy (c ==) + +string :: String -> ReadP r String +-- ^ Parses and returns the specified string. +string this = do s <- look; scan this s + where + scan [] _ = do return this + scan (x:xs) (y:ys) | x == y = do get >> scan xs ys + scan _ _ = do pfail + +munch :: (Char -> Bool) -> ReadP r String +-- ^ Parses the first zero or more characters satisfying the predicate. +munch p = + do s <- look + scan s + where + scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s) + scan _ = do return "" + +munch1 :: (Char -> Bool) -> ReadP r String +-- ^ Parses the first one or more characters satisfying the predicate. +munch1 p = + do c <- get + if p c then do s <- munch p; return (c:s) + else pfail + +choice :: [ReadP r a] -> ReadP r a +-- ^ Combines all parsers in the specified list. +choice [] = pfail +choice [p] = p +choice (p:ps) = p +++ choice ps + +skipSpaces :: ReadP r () +-- ^ Skips all whitespace. +skipSpaces = + do s <- look + skip s + where + skip (c:s) | isSpace c = do _ <- get; skip s + skip _ = do return () + +count :: Int -> ReadP r a -> ReadP r [a] +-- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of +-- results is returned. +count n p = sequence (replicate n p) + +between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a +-- ^ @ between open close p @ parses @open@, followed by @p@ and finally +-- @close@. Only the value of @p@ is returned. +between open close p = do _ <- open + x <- p + _ <- close + return x + +option :: a -> ReadP r a -> ReadP r a +-- ^ @option x p@ will either parse @p@ or return @x@ without consuming +-- any input. +option x p = p +++ return x + +optional :: ReadP r a -> ReadP r () +-- ^ @optional p@ optionally parses @p@ and always returns @()@. +optional p = (p >> return ()) +++ return () + +many :: ReadP r a -> ReadP r [a] +-- ^ Parses zero or more occurrences of the given parser. +many p = return [] +++ many1 p + +many1 :: ReadP r a -> ReadP r [a] +-- ^ Parses one or more occurrences of the given parser. +many1 p = liftM2 (:) p (many p) + +skipMany :: ReadP r a -> ReadP r () +-- ^ Like 'many', but discards the result. +skipMany p = many p >> return () + +skipMany1 :: ReadP r a -> ReadP r () +-- ^ Like 'many1', but discards the result. +skipMany1 p = p >> skipMany p + +sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@. +-- Returns a list of values returned by @p@. +sepBy p sep = sepBy1 p sep +++ return [] + +sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@. +-- Returns a list of values returned by @p@. +sepBy1 p sep = liftM2 (:) p (many (sep >> p)) + +endBy :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended +-- by @sep@. +endBy p sep = many (do x <- p ; _ <- sep ; return x) + +endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended +-- by @sep@. +endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x) + +chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a +-- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a /right/ associative application of all +-- functions returned by @op@. If there are no occurrences of @p@, @x@ is +-- returned. +chainr p op x = chainr1 p op +++ return x + +chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a +-- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a /left/ associative application of all +-- functions returned by @op@. If there are no occurrences of @p@, @x@ is +-- returned. +chainl p op x = chainl1 p op +++ return x + +chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a +-- ^ Like 'chainr', but parses one or more occurrences of @p@. +chainr1 p op = scan + where scan = p >>= rest + rest x = do f <- op + y <- scan + return (f x y) + +++ return x + +chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a +-- ^ Like 'chainl', but parses one or more occurrences of @p@. +chainl1 p op = p >>= rest + where rest x = do f <- op + y <- p + rest (f x y) + +++ return x + +manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a] +-- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@ +-- succeeds. Returns a list of values returned by @p@. +manyTill p end = scan + where scan = (end >> return []) <++ (liftM2 (:) p scan) + +-- --------------------------------------------------------------------------- +-- Converting between ReadP and Read + +readP_to_S :: ReadP a a -> ReadS a +-- ^ Converts a parser into a Haskell ReadS-style function. +-- This is the main way in which you can \"run\" a 'ReadP' parser: +-- the expanded type is +-- @ readP_to_S :: ReadP a -> String -> [(a,String)] @ +readP_to_S (R f) = run (f return) + +readS_to_P :: ReadS a -> ReadP r a +-- ^ Converts a Haskell ReadS-style function into a parser. +-- Warning: This introduces local backtracking in the resulting +-- parser, and therefore a possible inefficiency. +readS_to_P r = + R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s'])) + + + diff --git a/cabal/Cabal/Distribution/Compat/TempFile.hs b/cabal/Cabal/Distribution/Compat/TempFile.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Compat/TempFile.hs @@ -0,0 +1,204 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +-- #hide +module Distribution.Compat.TempFile ( + openTempFile, + openBinaryTempFile, + openNewBinaryFile, + createTempDirectory, + ) where + + +import System.FilePath (()) +import Foreign.C (eEXIST) + +#if __NHC__ || __HUGS__ +import System.IO (openFile, openBinaryFile, + Handle, IOMode(ReadWriteMode)) +import System.Directory (doesFileExist) +import System.FilePath ((<.>), splitExtension) +import System.IO.Error (try, isAlreadyExistsError) +#else +import System.IO (Handle, openTempFile, openBinaryTempFile) +import Data.Bits ((.|.)) +import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR, + o_BINARY, o_NONBLOCK, o_NOCTTY) +import System.IO.Error (isAlreadyExistsError) +#if __GLASGOW_HASKELL__ >= 611 +import System.Posix.Internals (withFilePath) +#else +import Foreign.C (withCString) +#endif +import Foreign.C (CInt) +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.Handle.FD (fdToHandle) +#else +import GHC.Handle (fdToHandle) +#endif +import Distribution.Compat.Exception (onException, tryIO) +#endif +import Foreign.C (getErrno, errnoToIOError) + +#if __NHC__ +import System.Posix.Types (CPid(..)) +foreign import ccall unsafe "getpid" c_getpid :: IO CPid +#else +import System.Posix.Internals (c_getpid) +#endif + +#ifdef mingw32_HOST_OS +import System.Directory ( createDirectory ) +#else +import qualified System.Posix +#endif + +-- ------------------------------------------------------------ +-- * temporary files +-- ------------------------------------------------------------ + +-- 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 + +#if __NHC__ || __HUGS__ +-- use a temporary filename that doesn't already exist. +-- NB. *not* secure (we don't atomically lock the tmp file we get) +openTempFile :: FilePath -> String -> IO (FilePath, Handle) +openTempFile tmp_dir template + = do x <- getProcessID + findTempName x + where + (templateBase, templateExt) = splitExtension template + findTempName :: Int -> IO (FilePath, Handle) + findTempName x + = do let path = tmp_dir (templateBase ++ "-" ++ show x) <.> templateExt + b <- doesFileExist path + if b then findTempName (x+1) + else do hnd <- openFile path ReadWriteMode + return (path, hnd) + +openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) +openBinaryTempFile tmp_dir template + = do x <- getProcessID + findTempName x + where + (templateBase, templateExt) = splitExtension template + findTempName :: Int -> IO (FilePath, Handle) + findTempName x + = do let path = tmp_dir (templateBase ++ "-" ++ show x) <.> templateExt + b <- doesFileExist path + if b then findTempName (x+1) + else do hnd <- openBinaryFile path ReadWriteMode + return (path, hnd) + +openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) +openNewBinaryFile = openBinaryTempFile + +getProcessID :: IO Int +getProcessID = fmap fromIntegral c_getpid +#else +-- This is a copy/paste of the openBinaryTempFile definition, but +-- if uses 666 rather than 600 for the permissions. The base library +-- needs to be changed to make this better. +openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) +openNewBinaryFile dir template = do + pid <- c_getpid + findTempName pid + 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. + (prefix,suffix) = + case break (== '.') $ reverse template of + -- First case: template contains no '.'s. Just re-reverse it. + (rev_suffix, "") -> (reverse rev_suffix, "") + -- Second case: template contains at least one '.'. Strip the + -- dot from the prefix and prepend it to the suffix (if we don't + -- do this, the unique number will get added after the '.' and + -- thus be part of the extension, which is wrong.) + (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) + -- Otherwise, something is wrong, because (break (== '.')) should + -- always return a pair with either the empty string or a string + -- beginning with '.' as the second component. + _ -> error "bug in System.IO.openTempFile" + + oflags = rw_flags .|. o_EXCL .|. o_BINARY + +#if __GLASGOW_HASKELL__ < 611 + withFilePath = withCString +#endif + + findTempName x = do + fd <- withFilePath filepath $ \ f -> + c_open f oflags 0o666 + if fd < 0 + then do + errno <- getErrno + if errno == eEXIST + then findTempName (x+1) + else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) + else do + -- TODO: We want to tell fdToHandle what the filepath is, + -- as any exceptions etc will only be able to report the + -- fd currently + h <- +#if __GLASGOW_HASKELL__ >= 609 + fdToHandle fd +#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS) + -- fdToHandle is borked on Windows with ghc-6.6.x + openFd (fromIntegral fd) Nothing False filepath + ReadWriteMode True +#else + fdToHandle (fromIntegral fd) +#endif + `onException` c_close fd + return (filepath, h) + where + filename = prefix ++ show x ++ suffix + filepath = dir `combine` filename + + -- FIXME: bits copied from System.FilePath + combine a b + | null b = a + | null a = b + | last a == pathSeparator = a ++ b + | otherwise = a ++ [pathSeparator] ++ b + +-- FIXME: Should use filepath library +pathSeparator :: Char +#ifdef mingw32_HOST_OS +pathSeparator = '\\' +#else +pathSeparator = '/' +#endif + +-- FIXME: Copied from GHC.Handle +std_flags, output_flags, rw_flags :: CInt +std_flags = o_NONBLOCK .|. o_NOCTTY +output_flags = std_flags .|. o_CREAT +rw_flags = output_flags .|. o_RDWR +#endif + +createTempDirectory :: FilePath -> String -> IO FilePath +createTempDirectory dir template = do + pid <- c_getpid + findTempName pid + where + findTempName x = do + let dirpath = dir template ++ "-" ++ show x + r <- tryIO $ mkPrivateDir dirpath + case r of + Right _ -> return dirpath + Left e | isAlreadyExistsError e -> findTempName (x+1) + | otherwise -> ioError e + +mkPrivateDir :: String -> IO () +#ifdef mingw32_HOST_OS +mkPrivateDir s = createDirectory s +#else +mkPrivateDir s = System.Posix.createDirectory s 0o700 +#endif diff --git a/cabal/Cabal/Distribution/Compiler.hs b/cabal/Cabal/Distribution/Compiler.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Compiler.hs @@ -0,0 +1,158 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compiler +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This has an enumeration of the various compilers that Cabal knows about. It +-- also specifies the default compiler. Sadly you'll often see code that does +-- case analysis on this compiler flavour enumeration like: +-- +-- > case compilerFlavor comp of +-- > GHC -> GHC.getInstalledPackages verbosity packageDb progconf +-- > JHC -> JHC.getInstalledPackages verbosity packageDb progconf +-- +-- Obviously it would be better to use the proper 'Compiler' abstraction +-- because that would keep all the compiler-specific code together. +-- Unfortunately we cannot make this change yet without breaking the +-- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the +-- moment we just have to live with this deficiency. If you're interested, see +-- ticket #50. + +{- 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(..), + buildCompilerFlavor, + defaultCompilerFlavor, + parseCompilerFlavorCompat, + + -- * Compiler id + CompilerId(..), + ) where + +import Distribution.Version (Version(..)) + +import qualified System.Info (compilerName) +import Distribution.Text (Text(..), display) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>)) + +import qualified Data.Char as Char (toLower, isDigit, isAlphaNum) +import Control.Monad (when) + +data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC + | OtherCompiler String + deriving (Show, Read, Eq, Ord) + +knownCompilerFlavors :: [CompilerFlavor] +knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC] + +instance Text CompilerFlavor where + disp (OtherCompiler name) = Disp.text name + disp NHC = Disp.text "nhc98" + disp other = Disp.text (lowercase (show other)) + + parse = do + comp <- Parse.munch1 Char.isAlphaNum + when (all Char.isDigit comp) Parse.pfail + return (classifyCompilerFlavor comp) + +classifyCompilerFlavor :: String -> CompilerFlavor +classifyCompilerFlavor s = + case lookup (lowercase s) compilerMap of + Just compiler -> compiler + Nothing -> OtherCompiler s + where + compilerMap = [ (display compiler, compiler) + | compiler <- knownCompilerFlavors ] + + +--TODO: In some future release, remove 'parseCompilerFlavorCompat' and use +-- ordinary 'parse'. Also add ("nhc", NHC) to the above 'compilerMap'. + +-- | Like 'classifyCompilerFlavor' but compatible with the old ReadS parser. +-- +-- It is compatible in the sense that it accepts only the same strings, +-- eg "GHC" but not "ghc". However other strings get mapped to 'OtherCompiler'. +-- The point of this is that we do not allow extra valid values that would +-- upset older Cabal versions that had a stricter parser however we cope with +-- new values more gracefully so that we'll be able to introduce new value in +-- future without breaking things so much. +-- +parseCompilerFlavorCompat :: Parse.ReadP r CompilerFlavor +parseCompilerFlavorCompat = do + comp <- Parse.munch1 Char.isAlphaNum + when (all Char.isDigit comp) Parse.pfail + case lookup comp compilerMap of + Just compiler -> return compiler + Nothing -> return (OtherCompiler comp) + where + compilerMap = [ (show compiler, compiler) + | compiler <- knownCompilerFlavors + , compiler /= YHC ] + +buildCompilerFlavor :: CompilerFlavor +buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName + +-- | The default compiler flavour to pick when compiling stuff. This defaults +-- to the compiler used to build the Cabal lib. +-- +-- However if it's not a recognised compiler then it's 'Nothing' and the user +-- will have to specify which compiler they want. +-- +defaultCompilerFlavor :: Maybe CompilerFlavor +defaultCompilerFlavor = case buildCompilerFlavor of + OtherCompiler _ -> Nothing + _ -> Just buildCompilerFlavor + +-- ------------------------------------------------------------ +-- * Compiler Id +-- ------------------------------------------------------------ + +data CompilerId = CompilerId CompilerFlavor Version + deriving (Eq, Ord, Read, Show) + +instance Text CompilerId where + disp (CompilerId f (Version [] _)) = disp f + disp (CompilerId f v) = disp f <> Disp.char '-' <> disp v + + parse = do + flavour <- parse + version <- (Parse.char '-' >> parse) Parse.<++ return (Version [] []) + return (CompilerId flavour version) + +lowercase :: String -> String +lowercase = map Char.toLower diff --git a/cabal/Cabal/Distribution/GetOpt.hs b/cabal/Cabal/Distribution/GetOpt.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/GetOpt.hs @@ -0,0 +1,335 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.GetOpt +-- Copyright : (c) Sven Panne 2002-2005 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This library provides facilities for parsing the command-line options +-- in a standalone program. It is essentially a Haskell port of the GNU +-- @getopt@ library. +-- +----------------------------------------------------------------------------- + +{- +Sven Panne Oct. 1996 (small +changes Dec. 1997) + +Two rather obscure features are missing: The Bash 2.0 non-option hack +(if you don't already know it, you probably don't want to hear about +it...) and the recognition of long options with a single dash +(e.g. '-help' is recognised as '--help', as long as there is no short +option 'h'). + +Other differences between GNU's getopt and this implementation: + +* To enforce a coherent description of options and arguments, there + are explanation fields in the option/argument descriptor. + +* Error messages are now more informative, but no longer POSIX + compliant... :-( + +And a final Haskell advertisement: The GNU C implementation uses well +over 1100 lines, we need only 195 here, including a 46 line example! +:-) +-} + +-- #hide +module Distribution.GetOpt ( + -- * GetOpt + getOpt, getOpt', + usageInfo, + ArgOrder(..), + OptDescr(..), + ArgDescr(..), + + -- * Example + + -- $example +) where + +import Data.List ( isPrefixOf, intersperse, find ) + +-- |What to do with options following non-options +data ArgOrder a + = RequireOrder -- ^ no option processing after first non-option + | Permute -- ^ freely intersperse options and non-options + | ReturnInOrder (String -> a) -- ^ wrap non-options into options + +{-| +Each 'OptDescr' describes a single option. + +The arguments to 'Option' are: + +* list of short option characters + +* list of long option strings (without \"--\") + +* argument descriptor + +* explanation of option for user +-} +data OptDescr a = -- description of a single options: + Option [Char] -- list of short option characters + [String] -- list of long option strings (without "--") + (ArgDescr a) -- argument descriptor + String -- explanation of option for user + +-- |Describes whether an option takes an argument or not, and if so +-- how the argument is injected into a value of type @a@. +data ArgDescr a + = NoArg a -- ^ no argument expected + | ReqArg (String -> a) String -- ^ option requires argument + | OptArg (Maybe String -> a) String -- ^ optional argument + +data OptKind a -- kind of cmd line arg (internal use only): + = Opt a -- an option + | UnreqOpt String -- an un-recognized option + | NonOpt String -- a non-option + | EndOfOpts -- end-of-options marker (i.e. "--") + | OptErr String -- something went wrong... + +-- | Return a string describing the usage of a command, derived from +-- the header (first argument) and the options described by the +-- second argument. +usageInfo :: String -- header + -> [OptDescr a] -- option descriptors + -> String -- nicely formatted decription of options +usageInfo header optDescr = unlines (header:table) + where (ss,ls,ds) = unzip3 [ (sepBy ", " (map (fmtShort ad) sos) + ,concatMap (fmtLong ad) (take 1 los) + ,d) + | Option sos los ad d <- optDescr ] + ssWidth = (maximum . map length) ss + lsWidth = (maximum . map length) ls + dsWidth = 30 `max` (80 - (ssWidth + lsWidth + 3)) + table = [ " " ++ padTo ssWidth so' ++ + " " ++ padTo lsWidth lo' ++ + " " ++ d' + | (so,lo,d) <- zip3 ss ls ds + , (so',lo',d') <- fmtOpt dsWidth so lo d ] + padTo n x = take n (x ++ repeat ' ') + sepBy s = concat . intersperse s + +fmtOpt :: Int -> String -> String -> String -> [(String, String, String)] +fmtOpt descrWidth so lo descr = + case wrapText descrWidth descr of + [] -> [(so,lo,"")] + (d:ds) -> (so,lo,d) : [ ("","",d') | d' <- ds ] + +fmtShort :: ArgDescr a -> Char -> String +fmtShort (NoArg _ ) so = "-" ++ [so] +fmtShort (ReqArg _ _) so = "-" ++ [so] +fmtShort (OptArg _ _) so = "-" ++ [so] + +fmtLong :: ArgDescr a -> String -> String +fmtLong (NoArg _ ) lo = "--" ++ lo +fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad +fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" + +wrapText :: Int -> String -> [String] +wrapText width = map unwords . wrap 0 [] . words + where wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w:ws) + | length w + 1 > width + = wrap (length w) [w] ws + wrap col line (w:ws) + | col + length w + 1 > width + = reverse line : wrap 0 [] (w:ws) + wrap col line (w:ws) + = let col' = col + length w + 1 + in wrap col' (w:line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +{-| +Process the command-line, and return the list of values that matched +(and those that didn\'t). The arguments are: + +* The order requirements (see 'ArgOrder') + +* The option descriptions (see 'OptDescr') + +* The actual command line arguments (presumably got from + 'System.Environment.getArgs'). + +'getOpt' returns a triple consisting of the option arguments, a list +of non-options, and a list of error messages. +-} +getOpt :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a],[String],[String]) -- (options,non-options,error messages) +getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) + where (os,xs,us,es) = getOpt' ordering optDescr args + +{-| +This is almost the same as 'getOpt', but returns a quadruple +consisting of the option arguments, a list of non-options, a list of +unrecognized options, and a list of error messages. +-} +getOpt' :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) +getOpt' _ _ [] = ([],[],[],[]) +getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering + where procNextOpt (Opt o) _ = (o:os,xs,us,es) + procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) + procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) + procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) + procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) + procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) + procNextOpt EndOfOpts Permute = ([],rest,[],[]) + procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) + procNextOpt (OptErr e) _ = (os,xs,us,e:es) + + (opt,rest) = getNext arg args optDescr + (os,xs,us,es) = getOpt' ordering optDescr rest + +-- take a look at the next cmd line arg and decide what to do with it +getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) +getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr +getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr +getNext a rest _ = (NonOpt a,rest) + +-- handle long option +longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +longOpt ls rs optDescr = long ads arg rs + where (opt,arg) = break (=='=') ls + getWith p = [ o | o@(Option _ xs _ _) <- optDescr + , find (p opt) xs /= Nothing] + exact = getWith (==) + options = if null exact then getWith isPrefixOf else exact + ads = [ ad | Option _ _ ad _ <- options ] + optStr = ("--"++opt) + + long (_:_:_) _ rest = (errAmbig options optStr,rest) + long [NoArg a ] [] rest = (Opt a,rest) + long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) + long [ReqArg _ d] [] [] = (errReq d optStr,[]) + long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) + long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) + long [OptArg f _] [] rest = (Opt (f Nothing),rest) + long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) + long _ _ rest = (UnreqOpt ("--"++ls),rest) + +-- handle short option +shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +shortOpt y ys rs optDescr = short ads ys rs + where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] + ads = [ ad | Option _ _ ad _ <- options ] + optStr = '-':[y] + + short (_:_:_) _ rest = (errAmbig options optStr,rest) + short (NoArg a :_) [] rest = (Opt a,rest) + short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) + short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) + short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) + short (ReqArg f _:_) xs rest = (Opt (f xs),rest) + short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) + short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) + short [] [] rest = (UnreqOpt optStr,rest) + short [] xs rest = (UnreqOpt (optStr++xs),rest) + +-- miscellaneous error formatting + +errAmbig :: [OptDescr a] -> String -> OptKind a +errAmbig ods optStr = OptErr (usageInfo header ods) + where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" + +errReq :: String -> String -> OptKind a +errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") + +errUnrec :: String -> String +errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" + +errNoArg :: String -> OptKind a +errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") + +{- +----------------------------------------------------------------------------------------- +-- and here a small and hopefully enlightening example: + +data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show + +options :: [OptDescr Flag] +options = + [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", + Option ['V','?'] ["version","release"] (NoArg Version) "show version info", + Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", + Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] + +out :: Maybe String -> Flag +out Nothing = Output "stdout" +out (Just o) = Output o + +test :: ArgOrder Flag -> [String] -> String +test order cmdline = case getOpt order options cmdline of + (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" + (_,_,errs) -> concat errs ++ usageInfo header options + where header = "Usage: foobar [OPTION...] files..." + +-- example runs: +-- putStr (test RequireOrder ["foo","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["foo","-v"]) +-- ==> options=[Verbose] args=["foo"] +-- putStr (test (ReturnInOrder Arg) ["foo","-v"]) +-- ==> options=[Arg "foo", Verbose] args=[] +-- putStr (test Permute ["foo","--","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["-?o","--name","bar","--na=baz"]) +-- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] +-- putStr (test Permute ["--ver","foo"]) +-- ==> option `--ver' is ambiguous; could be one of: +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- Usage: foobar [OPTION...] files... +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- -o[FILE] --output[=FILE] use FILE for dump +-- -n USER --name=USER only dump USER's files +----------------------------------------------------------------------------------------- +-} + +{- $example + +To hopefully illuminate the role of the different data +structures, here\'s the command-line options for a (very simple) +compiler: + +> module Opts where +> +> import Distribution.GetOpt +> import Data.Maybe ( fromMaybe ) +> +> data Flag +> = Verbose | Version +> | Input String | Output String | LibDir String +> deriving Show +> +> options :: [OptDescr Flag] +> options = +> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" +> , Option ['V','?'] ["version"] (NoArg Version) "show version number" +> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE" +> , Option ['c'] [] (OptArg inp "FILE") "input FILE" +> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" +> ] +> +> inp,outp :: Maybe String -> Flag +> outp = Output . fromMaybe "stdout" +> inp = Input . fromMaybe "stdin" +> +> compilerOpts :: [String] -> IO ([Flag], [String]) +> compilerOpts argv = +> case getOpt Permute options argv of +> (o,n,[] ) -> return (o,n) +> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) +> where header = "Usage: ic [OPTION...] files..." + +-} diff --git a/cabal/Cabal/Distribution/InstalledPackageInfo.hs b/cabal/Cabal/Distribution/InstalledPackageInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/InstalledPackageInfo.hs @@ -0,0 +1,294 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.InstalledPackageInfo +-- Copyright : (c) The University of Glasgow 2004 +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This is the information about an /installed/ package that +-- is communicated to the @ghc-pkg@ program in order to register +-- a package. @ghc-pkg@ now consumes this package format (as of version +-- 6.4). This is specific to GHC at the moment. +-- +-- The @.cabal@ file format is for describing a package that is not yet +-- installed. It has a lot of flexibility, like conditionals and dependency +-- ranges. As such, that format is not at all suitable for describing a package +-- that has already been built and installed. By the time we get to that stage, +-- we have resolved all conditionals and resolved dependency version +-- constraints to exact versions of dependent packages. So, this module defines +-- the 'InstalledPackageInfo' data structure that contains all the info we keep +-- about an installed package. There is a parser and pretty printer. The +-- 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, + ParseResult(..), PError(..), PWarning, + emptyInstalledPackageInfo, + parseInstalledPackageInfo, + showInstalledPackageInfo, + showInstalledPackageInfoField, + fieldsInstalledPackageInfo, + ) where + +import Distribution.ParseUtils + ( FieldDescr(..), ParseResult(..), PError(..), PWarning + , simpleField, listField, parseLicenseQ + , showFields, showSingleNamedField, parseFieldsFlat + , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ + , showFilePath, showToken, boolField, parseOptVersion + , parseFreeText, showFreeText ) +import Distribution.License ( License(..) ) +import Distribution.Package + ( PackageName(..), PackageIdentifier(..), PackageId, InstalledPackageId(..) + , packageName, packageVersion ) +import qualified Distribution.Package as Package + ( Package(..) ) +import Distribution.ModuleName + ( ModuleName ) +import Distribution.Version + ( Version(..) ) +import Distribution.Text + ( Text(disp, parse) ) + +-- ----------------------------------------------------------------------------- +-- The InstalledPackageInfo type + +data InstalledPackageInfo_ m + = InstalledPackageInfo { + -- these parts are exactly the same as PackageDescription + installedPackageId :: InstalledPackageId, + sourcePackageId :: PackageId, + license :: License, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + homepage :: String, + pkgUrl :: String, + synopsis :: String, + description :: String, + category :: String, + -- these parts are required by an installed package only: + exposed :: Bool, + exposedModules :: [m], + hiddenModules :: [m], + trusted :: Bool, + importDirs :: [FilePath], -- contain sources in case of Hugs + libraryDirs :: [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] + } + deriving (Read, Show) + +instance Package.Package (InstalledPackageInfo_ str) where + packageId = sourcePackageId + +type InstalledPackageInfo = InstalledPackageInfo_ ModuleName + +emptyInstalledPackageInfo :: InstalledPackageInfo_ m +emptyInstalledPackageInfo + = InstalledPackageInfo { + installedPackageId = InstalledPackageId "", + sourcePackageId = PackageIdentifier (PackageName "") noVersion, + license = AllRightsReserved, + copyright = "", + maintainer = "", + author = "", + stability = "", + homepage = "", + pkgUrl = "", + synopsis = "", + description = "", + category = "", + exposed = False, + exposedModules = [], + hiddenModules = [], + trusted = False, + importDirs = [], + libraryDirs = [], + hsLibraries = [], + extraLibraries = [], + extraGHCiLibraries= [], + includeDirs = [], + includes = [], + depends = [], + hugsOptions = [], + ccOptions = [], + ldOptions = [], + frameworkDirs = [], + frameworks = [], + haddockInterfaces = [], + haddockHTMLs = [] + } + +noVersion :: Version +noVersion = Version{ versionBranch=[], versionTags=[] } + +-- ----------------------------------------------------------------------------- +-- Parsing + +parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo +parseInstalledPackageInfo = + parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo + +-- ----------------------------------------------------------------------------- +-- Pretty-printing + +showInstalledPackageInfo :: InstalledPackageInfo -> String +showInstalledPackageInfo = showFields fieldsInstalledPackageInfo + +showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) +showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo + +-- ----------------------------------------------------------------------------- +-- Description of the fields, for parsing/printing + +fieldsInstalledPackageInfo :: [FieldDescr InstalledPackageInfo] +fieldsInstalledPackageInfo = basicFieldDescrs ++ installedFieldDescrs + +basicFieldDescrs :: [FieldDescr InstalledPackageInfo] +basicFieldDescrs = + [ simpleField "name" + disp parsePackageNameQ + packageName (\name pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgName=name}}) + , simpleField "version" + disp parseOptVersion + packageVersion (\ver pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgVersion=ver}}) + , simpleField "id" + disp parse + installedPackageId (\ipid pkg -> pkg{installedPackageId=ipid}) + , simpleField "license" + disp parseLicenseQ + license (\l pkg -> pkg{license=l}) + , simpleField "copyright" + showFreeText parseFreeText + copyright (\val pkg -> pkg{copyright=val}) + , simpleField "maintainer" + showFreeText parseFreeText + maintainer (\val pkg -> pkg{maintainer=val}) + , simpleField "stability" + showFreeText parseFreeText + stability (\val pkg -> pkg{stability=val}) + , simpleField "homepage" + showFreeText parseFreeText + homepage (\val pkg -> pkg{homepage=val}) + , simpleField "package-url" + showFreeText parseFreeText + pkgUrl (\val pkg -> pkg{pkgUrl=val}) + , simpleField "synopsis" + showFreeText parseFreeText + synopsis (\val pkg -> pkg{synopsis=val}) + , simpleField "description" + showFreeText parseFreeText + description (\val pkg -> pkg{description=val}) + , simpleField "category" + showFreeText parseFreeText + category (\val pkg -> pkg{category=val}) + , simpleField "author" + showFreeText parseFreeText + author (\val pkg -> pkg{author=val}) + ] + +installedFieldDescrs :: [FieldDescr InstalledPackageInfo] +installedFieldDescrs = [ + boolField "exposed" + exposed (\val pkg -> pkg{exposed=val}) + , listField "exposed-modules" + disp parseModuleNameQ + exposedModules (\xs pkg -> pkg{exposedModules=xs}) + , listField "hidden-modules" + disp parseModuleNameQ + hiddenModules (\xs pkg -> pkg{hiddenModules=xs}) + , boolField "trusted" + trusted (\val pkg -> pkg{trusted=val}) + , listField "import-dirs" + showFilePath parseFilePathQ + importDirs (\xs pkg -> pkg{importDirs=xs}) + , listField "library-dirs" + showFilePath parseFilePathQ + libraryDirs (\xs pkg -> pkg{libraryDirs=xs}) + , listField "hs-libraries" + showFilePath parseTokenQ + hsLibraries (\xs pkg -> pkg{hsLibraries=xs}) + , listField "extra-libraries" + showToken parseTokenQ + extraLibraries (\xs pkg -> pkg{extraLibraries=xs}) + , listField "extra-ghci-libraries" + showToken parseTokenQ + extraGHCiLibraries (\xs pkg -> pkg{extraGHCiLibraries=xs}) + , listField "include-dirs" + showFilePath parseFilePathQ + includeDirs (\xs pkg -> pkg{includeDirs=xs}) + , listField "includes" + showFilePath parseFilePathQ + includes (\xs pkg -> pkg{includes=xs}) + , 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}) + , listField "ld-options" + showToken parseTokenQ + ldOptions (\path pkg -> pkg{ldOptions=path}) + , listField "framework-dirs" + showFilePath parseFilePathQ + frameworkDirs (\xs pkg -> pkg{frameworkDirs=xs}) + , listField "frameworks" + showToken parseTokenQ + frameworks (\xs pkg -> pkg{frameworks=xs}) + , listField "haddock-interfaces" + showFilePath parseFilePathQ + haddockInterfaces (\xs pkg -> pkg{haddockInterfaces=xs}) + , listField "haddock-html" + showFilePath parseFilePathQ + haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs}) + ] diff --git a/cabal/Cabal/Distribution/License.hs b/cabal/Cabal/Distribution/License.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/License.hs @@ -0,0 +1,146 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.License +-- Copyright : Isaac Jones 2003-2005 +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- The License datatype. For more information about these and other +-- open-source licenses, you may visit . +-- +-- 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', 'LGPL' 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. -} + +module Distribution.License ( + License(..), + knownLicenses, + ) where + +import Distribution.Version (Version(Version)) + +import Distribution.Text (Text(..), display) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>)) +import qualified Data.Char as Char (isAlphaNum) + +-- |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. +-- +data License = + +--TODO: * remove BSD4 + + -- | GNU Public License. Source code must accompany alterations. + GPL (Maybe Version) + + -- | Lesser GPL, Less restrictive than GPL, useful for libraries. + | LGPL (Maybe Version) + + -- | 3-clause BSD license, newer, no advertising clause. Very free license. + | BSD3 + + -- | 4-clause BSD license, older, with advertising clause. You almost + -- certainly want to use the BSD3 license instead. + | BSD4 + + -- | The MIT license, similar to the BSD3. Very free license. + | MIT + + -- | The Apache License. Version 2.0 is the current version, + -- previous versions are considered historical. + + | Apache (Maybe Version) + + -- | Holder makes no claim to ownership, least restrictive license. + | PublicDomain + + -- | No rights are granted to others. Undistributable. Most restrictive. + | AllRightsReserved + + -- | Some other license. + | OtherLicense + + -- | Not a recognised license. + -- Allows us to deal with future extensions more gracefully. + | UnknownLicense String + deriving (Read, Show, Eq) + +knownLicenses :: [License] +knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3]) + , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3]) + , BSD3, MIT + , Apache unversioned, Apache (version [2, 0]) + , PublicDomain, AllRightsReserved, OtherLicense] + where + unversioned = Nothing + 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 (Apache version) = Disp.text "Apache" <> dispOptVersion version + disp (UnknownLicense other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + name <- Parse.munch1 (\c -> Char.isAlphaNum c && c /= '-') + version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse) + return $! case (name, version :: Maybe Version) of + ("GPL", _ ) -> GPL version + ("LGPL", _ ) -> LGPL version + ("BSD3", Nothing) -> BSD3 + ("BSD4", Nothing) -> BSD4 + ("MIT", Nothing) -> MIT + ("Apache", _ ) -> Apache version + ("PublicDomain", Nothing) -> PublicDomain + ("AllRightsReserved", Nothing) -> AllRightsReserved + ("OtherLicense", Nothing) -> OtherLicense + _ -> UnknownLicense $ name + ++ maybe "" (('-':) . display) version + +dispOptVersion :: Maybe Version -> Disp.Doc +dispOptVersion Nothing = Disp.empty +dispOptVersion (Just v) = Disp.char '-' <> disp v diff --git a/cabal/Cabal/Distribution/Make.hs b/cabal/Cabal/Distribution/Make.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Make.hs @@ -0,0 +1,213 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Make +-- Copyright : Martin Sjögren 2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is an alternative build system that delegates everything to the @make@ +-- program. All the commands just end up calling @make@ with appropriate +-- arguments. The intention was to allow preexisting packages that used +-- makefiles to be wrapped into Cabal packages. In practice essentially all +-- such packages were converted over to the \"Simple\" build system instead. +-- Consequently this module is not used much and it certainly only sees cursory +-- maintenance and no testing. Perhaps at some point we should stop pretending +-- 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 +-- assume that there is a configure script, and that after the ConfigCmd has +-- been run, there is a Makefile. Further assumptions: +-- +-- [ConfigCmd] We assume the configure script accepts +-- @--with-hc@, +-- @--with-hc-pkg@, +-- @--prefix@, +-- @--bindir@, +-- @--libdir@, +-- @--libexecdir@, +-- @--datadir@. +-- +-- [BuildCmd] We assume that the default Makefile target will build everything. +-- +-- [InstallCmd] We assume there is an @install@ target. Note that we assume that +-- this does *not* register the package! +-- +-- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@. +-- The @copy@ target should probably just invoke @make install@ +-- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix) +-- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make +-- install@ directly here is that we don\'t know the value of @$(prefix)@. +-- +-- [SDistCmd] We assume there is a @dist@ target. +-- +-- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@. +-- +-- [UnregisterCmd] We assume there is an @unregister@ target. +-- +-- [HaddockCmd] We assume there is a @docs@ or @doc@ target. + + +-- copy : +-- $(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(..), + defaultMain, defaultMainArgs, defaultMainNoRead + ) where + +-- local +import Distribution.Compat.Exception +import Distribution.Package --must not specify imports, since we're exporting moule. +import Distribution.Simple.Program(defaultProgramConfiguration) +import Distribution.PackageDescription +import Distribution.Simple.Setup +import Distribution.Simple.Command + +import Distribution.Simple.Utils (rawSystemExit, cabalVersion) + +import Distribution.License (License(..)) +import Distribution.Version + ( Version(..) ) +import Distribution.Text + ( display ) + +import System.Environment (getArgs, getProgName) +import Data.List (intersperse) +import System.Exit + +defaultMain :: IO () +defaultMain = getArgs >>= defaultMainArgs + +defaultMainArgs :: [String] -> IO () +defaultMainArgs = defaultMainHelper + +{-# DEPRECATED defaultMainNoRead "it ignores its PackageDescription arg" #-} +defaultMainNoRead :: PackageDescription -> IO () +defaultMainNoRead = const defaultMain + +defaultMainHelper :: [String] -> IO () +defaultMainHelper args = + case commandsRun globalCommand commands args of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (flags, commandParse) -> + case commandParse of + _ | fromFlag (globalVersion flags) -> printVersion + | fromFlag (globalNumericVersion flags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action + + where + printHelp help = getProgName >>= putStr . help + printOptionsList = putStr . unlines + printErrors errs = do + putStr (concat (intersperse "\n" errs)) + exitWith (ExitFailure 1) + printNumericVersion = putStrLn $ display cabalVersion + printVersion = putStrLn $ "Cabal library version " + ++ display cabalVersion + + progs = defaultProgramConfiguration + commands = + [configureCommand progs `commandAddAction` configureAction + ,buildCommand progs `commandAddAction` buildAction + ,installCommand `commandAddAction` installAction + ,copyCommand `commandAddAction` copyAction + ,haddockCommand `commandAddAction` haddockAction + ,cleanCommand `commandAddAction` cleanAction + ,sdistCommand `commandAddAction` sdistAction + ,registerCommand `commandAddAction` registerAction + ,unregisterCommand `commandAddAction` unregisterAction + ] + +configureAction :: ConfigFlags -> [String] -> IO () +configureAction flags args = do + noExtraFlags args + let verbosity = fromFlag (configVerbosity flags) + rawSystemExit verbosity "sh" $ + "configure" + : configureArgs backwardsCompatHack flags + where backwardsCompatHack = True + +copyAction :: CopyFlags -> [String] -> IO () +copyAction flags args = do + noExtraFlags args + let destArgs = case fromFlag $ copyDest flags of + NoCopyDest -> ["install"] + CopyTo path -> ["copy", "destdir=" ++ path] + rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs + +installAction :: InstallFlags -> [String] -> IO () +installAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"] + rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"] + +haddockAction :: HaddockFlags -> [String] -> IO () +haddockAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"] + `catchIO` \_ -> + rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] + +buildAction :: BuildFlags -> [String] -> IO () +buildAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ buildVerbosity flags) "make" [] + +cleanAction :: CleanFlags -> [String] -> IO () +cleanAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"] + +sdistAction :: SDistFlags -> [String] -> IO () +sdistAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"] + +registerAction :: RegisterFlags -> [String] -> IO () +registerAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"] + +unregisterAction :: RegisterFlags -> [String] -> IO () +unregisterAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"] diff --git a/cabal/Cabal/Distribution/ModuleName.hs b/cabal/Cabal/Distribution/ModuleName.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/ModuleName.hs @@ -0,0 +1,130 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ModuleName +-- Copyright : Duncan Coutts 2008 +-- +-- 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, + components, + toFilePath, + main, + simple, + ) where + +import Distribution.Text + ( Text(..) ) + +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 + ( intersperse ) + +-- | A valid Haskell module name. +-- +newtype ModuleName = ModuleName [String] + deriving (Eq, Ord, Read, Show) + +instance Text ModuleName where + disp (ModuleName ms) = + Disp.hcat (intersperse (Disp.char '.') (map Disp.text ms)) + + parse = do + ms <- Parse.sepBy1 component (Parse.char '.') + return (ModuleName ms) + + where + component = do + c <- Parse.satisfy Char.isUpper + cs <- Parse.munch validModuleChar + return (c:cs) + +validModuleChar :: Char -> Bool +validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\'' + +validModuleComponent :: String -> Bool +validModuleComponent [] = False +validModuleComponent (c:cs) = Char.isUpper c + && all validModuleChar cs + +{-# DEPRECATED simple "use ModuleName.fromString instead" #-} +simple :: String -> ModuleName +simple str = ModuleName [str] + +-- | Construct a 'ModuleName' from a valid module name 'String'. +-- +-- This is just a convenience function intended for valid module strings. It is +-- an error if it is used with a string that is not a valid module name. If you +-- are parsing user input then use 'Distribution.Text.simpleParse' instead. +-- +fromString :: String -> ModuleName +fromString string + | all validModuleComponent components' = ModuleName components' + | otherwise = error badName + + where + components' = split string + badName = "ModuleName.fromString: invalid module name " ++ show string + + split cs = case break (=='.') cs of + (chunk,[]) -> chunk : [] + (chunk,_:rest) -> chunk : split rest + +-- | The module name @Main@. +-- +main :: ModuleName +main = ModuleName ["Main"] + +-- | The individual components of a hierarchical module name. For example +-- +-- > components (fromString "A.B.C") = ["A", "B", "C"] +-- +components :: ModuleName -> [String] +components (ModuleName ms) = ms + +-- | Convert a module name to a file path, but without any file extension. +-- For example: +-- +-- > toFilePath (fromString "A.B.C") = "A/B/C" +-- +toFilePath :: ModuleName -> FilePath +toFilePath = concat . intersperse [pathSeparator] . components diff --git a/cabal/Cabal/Distribution/Package.hs b/cabal/Cabal/Distribution/Package.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Package.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Package +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Defines a package identifier along with a parser and pretty printer for it. +-- 'PackageIdentifier's consist of a name and an exact version. It also defines +-- 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(..), + PackageIdentifier(..), + PackageId, + + -- * Installed package identifiers + InstalledPackageId(..), + + -- * Package source dependencies + Dependency(..), + thisPackageVersion, + notThisPackageVersion, + simplifyDependency, + + -- * Package classes + Package(..), packageName, packageVersion, + PackageFixedDeps(..), + ) where + +import Distribution.Version + ( Version(..), VersionRange, anyVersion, thisVersion + , notThisVersion, simplifyVersionRange ) + +import Distribution.Text (Text(..)) +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 ( intersperse ) +import Data.Typeable ( Typeable ) + +newtype PackageName = PackageName String + deriving (Read, Show, Eq, Ord, Typeable) + +instance Text PackageName where + disp (PackageName n) = Disp.text n + parse = do + ns <- Parse.sepBy1 component (Parse.char '-') + return (PackageName (concat (intersperse "-" ns))) + where + component = do + cs <- Parse.munch1 Char.isAlphaNum + if all Char.isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +instance NFData PackageName where + rnf (PackageName pkg) = rnf pkg + +-- | Type alias so we can use the shorter name PackageId. +type PackageId = PackageIdentifier + +-- | The name and version of a package. +data PackageIdentifier + = PackageIdentifier { + 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) + +instance Text PackageIdentifier where + disp (PackageIdentifier n v) = case v of + Version [] _ -> disp n -- if no version, don't show version. + _ -> disp n <> Disp.char '-' <> disp v + + parse = do + n <- parse + v <- (Parse.char '-' >> parse) <++ return (Version [] []) + return (PackageIdentifier n v) + +instance NFData PackageIdentifier where + rnf (PackageIdentifier name version) = rnf name `seq` rnf version + +-- ------------------------------------------------------------ +-- * Installed Package Ids +-- ------------------------------------------------------------ + +-- | An InstalledPackageId uniquely identifies an instance of an installed package. +-- There can be at most one package with a given 'InstalledPackageId' +-- in a package database, or overlay of databases. +-- +newtype InstalledPackageId = InstalledPackageId String + deriving (Read,Show,Eq,Ord) + +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` ":-_." + +-- ------------------------------------------------------------ +-- * Package source dependencies +-- ------------------------------------------------------------ + +-- | Describes a dependency on a source package (API) +-- +data Dependency = Dependency PackageName VersionRange + deriving (Read, Show, Eq) + +instance Text Dependency where + disp (Dependency name ver) = + disp name <+> disp ver + + parse = do name <- parse + Parse.skipSpaces + ver <- parse <++ return anyVersion + Parse.skipSpaces + return (Dependency name ver) + +thisPackageVersion :: PackageIdentifier -> Dependency +thisPackageVersion (PackageIdentifier n v) = + Dependency n (thisVersion v) + +notThisPackageVersion :: PackageIdentifier -> Dependency +notThisPackageVersion (PackageIdentifier n v) = + Dependency n (notThisVersion v) + +-- | Simplify the 'VersionRange' expression in a 'Dependency'. +-- See 'simplifyVersionRange'. +-- +simplifyDependency :: Dependency -> Dependency +simplifyDependency (Dependency name range) = + Dependency name (simplifyVersionRange range) + +-- | Class of things that have a 'PackageIdentifier' +-- +-- Types in this class are all notions of a package. This allows us to have +-- different types for the different phases that packages go though, from +-- simple name\/id, package description, configured or installed packages. +-- +-- Not all kinds of packages can be uniquely identified by a +-- 'PackageIdentifier'. In particular, installed packages cannot, there may be +-- many installed instances of the same source package. +-- +class Package pkg where + packageId :: pkg -> PackageIdentifier + +packageName :: Package pkg => pkg -> PackageName +packageName = pkgName . packageId + +packageVersion :: Package pkg => pkg -> Version +packageVersion = pkgVersion . packageId + +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. +-- +class Package pkg => PackageFixedDeps pkg where + depends :: pkg -> [PackageIdentifier] diff --git a/cabal/Cabal/Distribution/PackageDescription.hs b/cabal/Cabal/Distribution/PackageDescription.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/PackageDescription.hs @@ -0,0 +1,1034 @@ +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines the data structure for the @.cabal@ file format. There are +-- several parts to this structure. It has top level info and then 'Library', +-- 'Executable', 'TestSuite', and 'Benchmark' sections each of which have +-- associated 'BuildInfo' data that's used to build the library, exe, test, or +-- benchmark. To further complicate things there is both a 'PackageDescription' +-- and a 'GenericPackageDescription'. This distinction relates to cabal +-- configurations. When we initially read a @.cabal@ file we get a +-- 'GenericPackageDescription' which has all the conditional sections. +-- Before actually building a package we have to decide +-- on each conditional. Once we've done that we get a 'PackageDescription'. +-- It was done this way initially to avoid breaking too much stuff when the +-- feature was introduced. It could probably do with being rationalised at some +-- point to make it simpler. + +{- 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(..), + emptyPackageDescription, + specVersion, + descCabalVersion, + BuildType(..), + knownBuildTypes, + + -- ** Libraries + Library(..), + emptyLibrary, + withLib, + hasLibs, + libModules, + + -- ** Executables + Executable(..), + emptyExecutable, + withExe, + hasExes, + exeModules, + + -- * Tests + TestSuite(..), + TestSuiteInterface(..), + TestType(..), + testType, + knownTestTypes, + emptyTestSuite, + hasTests, + withTest, + testModules, + enabledTests, + + -- * Benchmarks + Benchmark(..), + BenchmarkInterface(..), + BenchmarkType(..), + benchmarkType, + knownBenchmarkTypes, + emptyBenchmark, + hasBenchmarks, + withBenchmark, + benchmarkModules, + enabledBenchmarks, + + -- * Build information + BuildInfo(..), + emptyBuildInfo, + allBuildInfo, + allLanguages, + allExtensions, + usedExtensions, + hcOptions, + + -- ** Supplementary build information + HookedBuildInfo, + emptyHookedBuildInfo, + updatePackageDescription, + + -- * package configuration + GenericPackageDescription(..), + Flag(..), FlagName(..), FlagAssignment, + CondTree(..), ConfVar(..), Condition(..), + + -- * Source repositories + SourceRepo(..), + RepoKind(..), + RepoType(..), + knownRepoTypes, + ) where + +import Data.List (nub, intersperse) +import Data.Maybe (maybeToList) +import Data.Monoid (Monoid(mempty, mappend)) +import Data.Typeable ( Typeable ) +import Control.Monad (MonadPlus(mplus)) +import Text.PrettyPrint as Disp +import qualified Distribution.Compat.ReadP as Parse +import qualified Data.Char as Char (isAlphaNum, isDigit, toLower) + +import Distribution.Package + ( PackageName(PackageName), PackageIdentifier(PackageIdentifier) + , Dependency, Package(..) ) +import Distribution.ModuleName ( ModuleName ) +import Distribution.Version + ( Version(Version), VersionRange, anyVersion, orLaterVersion + , asVersionIntervals, LowerBound(..) ) +import Distribution.License (License(AllRightsReserved)) +import Distribution.Compiler (CompilerFlavor) +import Distribution.System (OS, Arch) +import Distribution.Text + ( Text(..), display ) +import Language.Haskell.Extension + ( Language, Extension ) + +-- ----------------------------------------------------------------------------- +-- The PackageDescription type + +-- | This data type is the internal representation of the file @pkg.cabal@. +-- It contains two kinds of information about the package: information +-- which is needed for all packages, such as the package name and version, and +-- information which is needed for the simple build system only, such as +-- the compiler options and library name. +-- +data PackageDescription + = PackageDescription { + -- the following are required by all packages: + package :: PackageIdentifier, + license :: License, + licenseFile :: FilePath, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + testedWith :: [(CompilerFlavor,VersionRange)], + homepage :: String, + pkgUrl :: String, + bugReports :: String, + sourceRepos :: [SourceRepo], + synopsis :: String, -- ^A one-line summary of this package + description :: String, -- ^A more verbose description of this package + category :: String, + customFieldsPD :: [(String,String)], -- ^Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + buildDepends :: [Dependency], + -- | The version of the Cabal spec that this package description uses. + -- For historical reasons this is specified with a version range but + -- only ranges of the form @>= v@ make sense. We are in the process of + -- transitioning to specifying just a single version, not a range. + specVersionRaw :: Either Version VersionRange, + buildType :: Maybe BuildType, + -- components + library :: Maybe Library, + executables :: [Executable], + testSuites :: [TestSuite], + benchmarks :: [Benchmark], + dataFiles :: [FilePath], + dataDir :: FilePath, + extraSrcFiles :: [FilePath], + extraTmpFiles :: [FilePath] + } + deriving (Show, Read, Eq) + +instance Package PackageDescription where + packageId = package + +-- | The version of the Cabal spec that this package should be interpreted +-- against. +-- +-- Historically we used a version range but we are switching to using a single +-- version. Currently we accept either. This function converts into a single +-- version by ignoring upper bounds in the version range. +-- +specVersion :: PackageDescription -> Version +specVersion pkg = case specVersionRaw pkg of + Left version -> version + Right versionRange -> case asVersionIntervals versionRange of + [] -> Version [0] [] + ((LowerBound version _, _):_) -> version + +-- | The range of versions of the Cabal tools that this package is intended to +-- work with. +-- +-- This function is deprecated and should not be used for new purposes, only to +-- support old packages that rely on the old interpretation. +-- +descCabalVersion :: PackageDescription -> VersionRange +descCabalVersion pkg = case specVersionRaw pkg of + Left version -> orLaterVersion version + Right versionRange -> versionRange +{-# DEPRECATED descCabalVersion "Use specVersion instead" #-} + +emptyPackageDescription :: PackageDescription +emptyPackageDescription + = PackageDescription { + package = PackageIdentifier (PackageName "") + (Version [] []), + license = AllRightsReserved, + licenseFile = "", + specVersionRaw = Right anyVersion, + buildType = Nothing, + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + buildDepends = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = "", + description = "", + category = "", + customFieldsPD = [], + library = Nothing, + executables = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = "", + extraSrcFiles = [], + extraTmpFiles = [] + } + +-- | The type of build system used by this package. +data BuildType + = Simple -- ^ calls @Distribution.Simple.defaultMain@ + | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, + -- which invokes @configure@ to generate additional build + -- information used by later phases. + | Make -- ^ calls @Distribution.Make.defaultMain@ + | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) + | UnknownBuildType String + -- ^ a package that uses an unknown build type cannot actually + -- be built. Doing it this way rather than just giving a + -- parse error means we get better error messages and allows + -- you to inspect the rest of the package description. + deriving (Show, Read, Eq) + +knownBuildTypes :: [BuildType] +knownBuildTypes = [Simple, Configure, Make, Custom] + +instance Text BuildType where + disp (UnknownBuildType other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + name <- Parse.munch1 Char.isAlphaNum + return $ case name of + "Simple" -> Simple + "Configure" -> Configure + "Custom" -> Custom + "Make" -> Make + _ -> UnknownBuildType name + +-- --------------------------------------------------------------------------- +-- The Library type + +data Library = Library { + exposedModules :: [ModuleName], + libExposed :: Bool, -- ^ Is the lib to be exposed by default? + libBuildInfo :: BuildInfo + } + deriving (Show, Eq, Read) + +instance Monoid Library where + mempty = Library { + exposedModules = mempty, + libExposed = True, + libBuildInfo = mempty + } + mappend a b = Library { + exposedModules = combine exposedModules, + libExposed = libExposed a && libExposed b, -- so False propagates + libBuildInfo = combine libBuildInfo + } + where combine field = field a `mappend` field b + +emptyLibrary :: Library +emptyLibrary = mempty + +-- |does this package have any libraries? +hasLibs :: PackageDescription -> Bool +hasLibs p = maybe False (buildable . libBuildInfo) (library p) + +-- |'Maybe' version of 'hasLibs' +maybeHasLibs :: PackageDescription -> Maybe Library +maybeHasLibs p = + library p >>= \lib -> if buildable (libBuildInfo lib) + then Just lib + else Nothing + +-- |If the package description has a library section, call the given +-- function with the library build info as argument. +withLib :: PackageDescription -> (Library -> IO ()) -> IO () +withLib pkg_descr f = + maybe (return ()) f (maybeHasLibs pkg_descr) + +-- | Get all the module names from the library (exposed and internal modules) +libModules :: Library -> [ModuleName] +libModules lib = exposedModules lib + ++ otherModules (libBuildInfo lib) + +-- --------------------------------------------------------------------------- +-- The Executable type + +data Executable = Executable { + exeName :: String, + modulePath :: FilePath, + buildInfo :: BuildInfo + } + deriving (Show, Read, Eq) + +instance Monoid Executable where + mempty = Executable { + exeName = mempty, + modulePath = mempty, + buildInfo = mempty + } + mappend a b = Executable{ + exeName = combine' exeName, + modulePath = combine modulePath, + buildInfo = combine buildInfo + } + where combine field = field a `mappend` field b + combine' field = case (field a, field b) of + ("","") -> "" + ("", x) -> x + (x, "") -> x + (x, y) -> error $ "Ambiguous values for executable field: '" + ++ x ++ "' and '" ++ y ++ "'" + +emptyExecutable :: Executable +emptyExecutable = mempty + +-- |does this package have any executables? +hasExes :: PackageDescription -> Bool +hasExes p = any (buildable . buildInfo) (executables p) + +-- | Perform the action on each buildable 'Executable' in the package +-- description. +withExe :: PackageDescription -> (Executable -> IO ()) -> IO () +withExe pkg_descr f = + sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)] + +-- | Get all the module names from an exe +exeModules :: Executable -> [ModuleName] +exeModules exe = otherModules (buildInfo exe) + +-- --------------------------------------------------------------------------- +-- The TestSuite type + +-- | A \"test-suite\" stanza in a cabal file. +-- +data TestSuite = TestSuite { + testName :: String, + testInterface :: TestSuiteInterface, + testBuildInfo :: BuildInfo, + testEnabled :: Bool + -- TODO: By having a 'testEnabled' field in the PackageDescription, we + -- are mixing build status information (i.e., arguments to 'configure') + -- with static package description information. This is undesirable, but + -- a better solution is waiting on the next overhaul to the + -- GenericPackageDescription -> PackageDescription resolution process. + } + deriving (Show, Read, Eq) + +-- | The test suite interfaces that are currently defined. Each test suite must +-- specify which interface it supports. +-- +-- More interfaces may be defined in future, either new revisions or totally +-- new interfaces. +-- +data TestSuiteInterface = + + -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form + -- of an executable. It returns a zero exit code for success, non-zero for + -- failure. The stdout and stderr channels may be logged. It takes no + -- command line parameters and nothing on stdin. + -- + TestSuiteExeV10 Version FilePath + + -- | Test interface \"detailed-0.9\". The test-suite takes the form of a + -- library containing a designated module that exports \"tests :: [Test]\". + -- + | TestSuiteLibV09 Version ModuleName + + -- | A test suite that does not conform to one of the above interfaces for + -- the given reason (e.g. unknown test type). + -- + | TestSuiteUnsupported TestType + deriving (Eq, Read, Show) + +instance Monoid TestSuite where + mempty = TestSuite { + testName = mempty, + testInterface = mempty, + testBuildInfo = mempty, + testEnabled = False + } + + mappend a b = TestSuite { + testName = combine' testName, + testInterface = combine testInterface, + testBuildInfo = combine testBuildInfo, + testEnabled = if testEnabled a then True else testEnabled b + } + where combine field = field a `mappend` field b + combine' f = case (f a, f b) of + ("", x) -> x + (x, "") -> x + (x, y) -> error "Ambiguous values for test field: '" + ++ x ++ "' and '" ++ y ++ "'" + +instance Monoid TestSuiteInterface where + mempty = TestSuiteUnsupported (TestTypeUnknown mempty (Version [] [])) + mappend a (TestSuiteUnsupported _) = a + mappend _ b = b + +emptyTestSuite :: TestSuite +emptyTestSuite = mempty + +-- | Does this package have any test suites? +hasTests :: PackageDescription -> Bool +hasTests = any (buildable . testBuildInfo) . testSuites + +-- | Get all the enabled test suites from a package. +enabledTests :: PackageDescription -> [TestSuite] +enabledTests = filter testEnabled . testSuites + +-- | Perform an action on each buildable 'TestSuite' in a package. +withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO () +withTest pkg_descr f = + mapM_ f $ filter (buildable . testBuildInfo) $ enabledTests pkg_descr + +-- | Get all the module names from a test suite. +testModules :: TestSuite -> [ModuleName] +testModules test = (case testInterface test of + TestSuiteLibV09 _ m -> [m] + _ -> []) + ++ otherModules (testBuildInfo test) + +-- | The \"test-type\" field in the test suite stanza. +-- +data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\" + | TestTypeLib Version -- ^ \"type: detailed-x.y\" + | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\" + deriving (Show, Read, Eq) + +knownTestTypes :: [TestType] +knownTestTypes = [ TestTypeExe (Version [1,0] []) + , TestTypeLib (Version [0,9] []) ] + +instance Text TestType where + disp (TestTypeExe ver) = text "exitcode-stdio-" <> disp ver + disp (TestTypeLib ver) = text "detailed-" <> disp ver + disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver + + parse = do + cs <- Parse.sepBy1 component (Parse.char '-') + _ <- Parse.char '-' + ver <- parse + let name = concat (intersperse "-" cs) + return $! case lowercase name of + "exitcode-stdio" -> TestTypeExe ver + "detailed" -> TestTypeLib ver + _ -> TestTypeUnknown name ver + + where + component = do + cs <- Parse.munch1 Char.isAlphaNum + if all Char.isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +testType :: TestSuite -> TestType +testType test = case testInterface test of + TestSuiteExeV10 ver _ -> TestTypeExe ver + TestSuiteLibV09 ver _ -> TestTypeLib ver + TestSuiteUnsupported testtype -> testtype + +-- --------------------------------------------------------------------------- +-- The Benchmark type + +-- | A \"benchmark\" stanza in a cabal file. +-- +data Benchmark = Benchmark { + benchmarkName :: String, + benchmarkInterface :: BenchmarkInterface, + benchmarkBuildInfo :: BuildInfo, + benchmarkEnabled :: Bool + -- TODO: See TODO for 'testEnabled'. + } + deriving (Show, Read, Eq) + +-- | The benchmark interfaces that are currently defined. Each +-- benchmark must specify which interface it supports. +-- +-- More interfaces may be defined in future, either new revisions or +-- totally new interfaces. +-- +data BenchmarkInterface = + + -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark + -- takes the form of an executable. It returns a zero exit code + -- for success, non-zero for failure. The stdout and stderr + -- channels may be logged. It takes no command line parameters + -- and nothing on stdin. + -- + BenchmarkExeV10 Version FilePath + + -- | A benchmark that does not conform to one of the above + -- interfaces for the given reason (e.g. unknown benchmark type). + -- + | BenchmarkUnsupported BenchmarkType + deriving (Eq, Read, Show) + +instance Monoid Benchmark where + mempty = Benchmark { + benchmarkName = mempty, + benchmarkInterface = mempty, + benchmarkBuildInfo = mempty, + benchmarkEnabled = False + } + + mappend a b = Benchmark { + benchmarkName = combine' benchmarkName, + benchmarkInterface = combine benchmarkInterface, + benchmarkBuildInfo = combine benchmarkBuildInfo, + benchmarkEnabled = if benchmarkEnabled a then True + else benchmarkEnabled b + } + where combine field = field a `mappend` field b + combine' f = case (f a, f b) of + ("", x) -> x + (x, "") -> x + (x, y) -> error "Ambiguous values for benchmark field: '" + ++ x ++ "' and '" ++ y ++ "'" + +instance Monoid BenchmarkInterface where + mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty (Version [] [])) + mappend a (BenchmarkUnsupported _) = a + mappend _ b = b + +emptyBenchmark :: Benchmark +emptyBenchmark = mempty + +-- | Does this package have any benchmarks? +hasBenchmarks :: PackageDescription -> Bool +hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks + +-- | Get all the enabled benchmarks from a package. +enabledBenchmarks :: PackageDescription -> [Benchmark] +enabledBenchmarks = filter benchmarkEnabled . benchmarks + +-- | Perform an action on each buildable 'Benchmark' in a package. +withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO () +withBenchmark pkg_descr f = + mapM_ f $ filter (buildable . benchmarkBuildInfo) $ enabledBenchmarks pkg_descr + +-- | Get all the module names from a benchmark. +benchmarkModules :: Benchmark -> [ModuleName] +benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark) + +-- | The \"benchmark-type\" field in the benchmark stanza. +-- +data BenchmarkType = BenchmarkTypeExe Version + -- ^ \"type: exitcode-stdio-x.y\" + | BenchmarkTypeUnknown String Version + -- ^ Some unknown benchmark type e.g. \"type: foo\" + deriving (Show, Read, Eq) + +knownBenchmarkTypes :: [BenchmarkType] +knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ] + +instance Text BenchmarkType where + disp (BenchmarkTypeExe ver) = text "exitcode-stdio-" <> disp ver + disp (BenchmarkTypeUnknown name ver) = text name <> char '-' <> disp ver + + parse = do + cs <- Parse.sepBy1 component (Parse.char '-') + _ <- Parse.char '-' + ver <- parse + let name = concat (intersperse "-" cs) + return $! case lowercase name of + "exitcode-stdio" -> BenchmarkTypeExe ver + _ -> BenchmarkTypeUnknown name ver + + where + component = do + cs <- Parse.munch1 Char.isAlphaNum + if all Char.isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +benchmarkType :: Benchmark -> BenchmarkType +benchmarkType benchmark = case benchmarkInterface benchmark of + BenchmarkExeV10 ver _ -> BenchmarkTypeExe ver + BenchmarkUnsupported benchmarktype -> benchmarktype + +-- --------------------------------------------------------------------------- +-- The BuildInfo type + +-- Consider refactoring into executable and library versions. +data BuildInfo = BuildInfo { + buildable :: Bool, -- ^ component is buildable here + buildTools :: [Dependency], -- ^ tools needed to build this bit + cppOptions :: [String], -- ^ options for pre-processing Haskell code + ccOptions :: [String], -- ^ options for C compiler + ldOptions :: [String], -- ^ options for linker + pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used + frameworks :: [String], -- ^support frameworks for Mac OS X + cSources :: [FilePath], + hsSourceDirs :: [FilePath], -- ^ where to look for the haskell module hierarchy + otherModules :: [ModuleName], -- ^ non-exposed or non-main modules + + defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified + otherLanguages :: [Language], -- ^ other languages used within the package + defaultExtensions :: [Extension], -- ^ language extensions used by all modules + otherExtensions :: [Extension], -- ^ other language extensions used within the package + oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions' + + extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package + 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], + customFieldsBI :: [(String,String)], -- ^Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + targetBuildDepends :: [Dependency] -- ^ Dependencies specific to a library or executable target + } + deriving (Show,Read,Eq) + +instance Monoid BuildInfo where + mempty = BuildInfo { + buildable = True, + buildTools = [], + cppOptions = [], + ccOptions = [], + ldOptions = [], + pkgconfigDepends = [], + frameworks = [], + cSources = [], + hsSourceDirs = [], + otherModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibDirs = [], + includeDirs = [], + includes = [], + installIncludes = [], + options = [], + ghcProfOptions = [], + ghcSharedOptions = [], + customFieldsBI = [], + targetBuildDepends = [] + } + mappend a b = BuildInfo { + buildable = buildable a && buildable b, + buildTools = combine buildTools, + cppOptions = combine cppOptions, + ccOptions = combine ccOptions, + ldOptions = combine ldOptions, + pkgconfigDepends = combine pkgconfigDepends, + frameworks = combineNub frameworks, + cSources = combineNub cSources, + hsSourceDirs = combineNub hsSourceDirs, + otherModules = combineNub otherModules, + defaultLanguage = combineMby defaultLanguage, + otherLanguages = combineNub otherLanguages, + defaultExtensions = combineNub defaultExtensions, + otherExtensions = combineNub otherExtensions, + oldExtensions = combineNub oldExtensions, + extraLibs = combine extraLibs, + extraLibDirs = combineNub extraLibDirs, + includeDirs = combineNub includeDirs, + includes = combineNub includes, + installIncludes = combineNub installIncludes, + options = combine options, + ghcProfOptions = combine ghcProfOptions, + ghcSharedOptions = combine ghcSharedOptions, + customFieldsBI = combine customFieldsBI, + targetBuildDepends = combineNub targetBuildDepends + } + where + combine field = field a `mappend` field b + combineNub field = nub (combine field) + combineMby field = field b `mplus` field a + +emptyBuildInfo :: BuildInfo +emptyBuildInfo = mempty + +-- | The 'BuildInfo' for the library (if there is one and it's buildable), and +-- all buildable executables, test suites and benchmarks. Useful for gathering +-- dependencies. +allBuildInfo :: PackageDescription -> [BuildInfo] +allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr] + , let bi = libBuildInfo lib + , buildable bi ] + ++ [ bi | exe <- executables pkg_descr + , let bi = buildInfo exe + , buildable bi ] + ++ [ bi | tst <- testSuites pkg_descr + , let bi = testBuildInfo tst + , buildable bi + , testEnabled tst ] + ++ [ bi | tst <- benchmarks pkg_descr + , let bi = benchmarkBuildInfo tst + , buildable bi + , benchmarkEnabled tst ] + --FIXME: many of the places where this is used, we actually want to look at + -- unbuildable bits too, probably need separate functions + +-- | The 'Language's used by this component +-- +allLanguages :: BuildInfo -> [Language] +allLanguages bi = maybeToList (defaultLanguage bi) + ++ otherLanguages bi + +-- | The 'Extension's that are used somewhere by this component +-- +allExtensions :: BuildInfo -> [Extension] +allExtensions bi = usedExtensions bi + ++ otherExtensions bi + +-- | The 'Extensions' that are used by all modules in this component +-- +usedExtensions :: BuildInfo -> [Extension] +usedExtensions bi = oldExtensions bi + ++ defaultExtensions bi + +type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)]) + +emptyHookedBuildInfo :: HookedBuildInfo +emptyHookedBuildInfo = (Nothing, []) + +-- |Select options for a particular Haskell compiler. +hcOptions :: CompilerFlavor -> BuildInfo -> [String] +hcOptions hc bi = [ opt | (hc',opts) <- options bi + , hc' == hc + , opt <- opts ] + +-- ------------------------------------------------------------ +-- * Source repos +-- ------------------------------------------------------------ + +-- | Information about the source revision control system for a package. +-- +-- When specifying a repo it is useful to know the meaning or intention of the +-- information as doing so enables automation. There are two obvious common +-- purposes: one is to find the repo for the latest development version, the +-- other is to find the repo for this specific release. The 'ReopKind' +-- specifies which one we mean (or another custom one). +-- +-- A package can specify one or the other kind or both. Most will specify just +-- a head repo but some may want to specify a repo to reconstruct the sources +-- for this package release. +-- +-- The required information is the 'RepoType' which tells us if it's using +-- 'Darcs', 'Git' for example. The 'repoLocation' and other details are +-- interpreted according to the repo type. +-- +data SourceRepo = SourceRepo { + -- | The kind of repo. This field is required. + repoKind :: RepoKind, + + -- | The type of the source repository system for this repo, eg 'Darcs' or + -- 'Git'. This field is required. + repoType :: Maybe RepoType, + + -- | The location of the repository. For most 'RepoType's this is a URL. + -- This field is required. + repoLocation :: Maybe String, + + -- | 'CVS' can put multiple \"modules\" on one server and requires a + -- module name in addition to the location to identify a particular repo. + -- Logically this is part of the location but unfortunately has to be + -- specified separately. This field is required for the 'CVS' 'RepoType' and + -- should not be given otherwise. + repoModule :: Maybe String, + + -- | The name or identifier of the branch, if any. Many source control + -- systems have the notion of multiple branches in a repo that exist in the + -- same location. For example 'Git' and 'CVS' use this while systems like + -- 'Darcs' use different locations for different branches. This field is + -- optional but should be used if necessary to identify the sources, + -- especially for the 'RepoThis' repo kind. + repoBranch :: Maybe String, + + -- | The tag identify a particular state of the repository. This should be + -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind. + -- + repoTag :: Maybe String, + + -- | Some repositories contain multiple projects in different subdirectories + -- This field specifies the subdirectory where this packages sources can be + -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted + -- relative to the root of the repository. This field is optional. If not + -- given the default is \".\" ie no subdirectory. + repoSubdir :: Maybe FilePath +} + deriving (Eq, Read, Show) + +-- | What this repo info is for, what it represents. +-- +data RepoKind = + -- | The repository for the \"head\" or development version of the project. + -- This repo is where we should track the latest development activity or + -- the usual repo people should get to contribute patches. + RepoHead + + -- | The repository containing the sources for this exact package version + -- or release. For this kind of repo a tag should be given to give enough + -- information to re-create the exact sources. + | RepoThis + + | RepoKindUnknown String + deriving (Eq, Ord, Read, Show) + +-- | An enumeration of common source control systems. The fields used in the +-- 'SourceRepo' depend on the type of repo. The tools and methods used to +-- obtain and track the repo depend on the repo type. +-- +data RepoType = Darcs | Git | SVN | CVS + | Mercurial | GnuArch | Bazaar | Monotone + | OtherRepoType String + deriving (Eq, Ord, Read, Show) + +knownRepoTypes :: [RepoType] +knownRepoTypes = [Darcs, Git, SVN, CVS + ,Mercurial, GnuArch, Bazaar, Monotone] + +repoTypeAliases :: RepoType -> [String] +repoTypeAliases Bazaar = ["bzr"] +repoTypeAliases Mercurial = ["hg"] +repoTypeAliases GnuArch = ["arch"] +repoTypeAliases _ = [] + +instance Text RepoKind where + disp RepoHead = Disp.text "head" + disp RepoThis = Disp.text "this" + disp (RepoKindUnknown other) = Disp.text other + + parse = do + name <- ident + return $ case lowercase name of + "head" -> RepoHead + "this" -> RepoThis + _ -> RepoKindUnknown name + +instance Text RepoType where + disp (OtherRepoType other) = Disp.text other + disp other = Disp.text (lowercase (show other)) + parse = fmap classifyRepoType ident + +classifyRepoType :: String -> RepoType +classifyRepoType s = + case lookup (lowercase s) repoTypeMap of + Just repoType' -> repoType' + Nothing -> OtherRepoType s + where + repoTypeMap = [ (name, repoType') + | repoType' <- knownRepoTypes + , name <- display repoType' : repoTypeAliases repoType' ] + +ident :: Parse.ReadP r String +ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') + +lowercase :: String -> String +lowercase = map Char.toLower + +-- ------------------------------------------------------------ +-- * Utils +-- ------------------------------------------------------------ + +updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription +updatePackageDescription (mb_lib_bi, exe_bi) p + = p{ executables = updateExecutables exe_bi (executables p) + , library = updateLibrary mb_lib_bi (library p) + } + where + updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library + updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib}) + updateLibrary Nothing mb_lib = mb_lib + updateLibrary (Just _) Nothing = Nothing + + updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)] + -> [Executable] -- ^list of executables to update + -> [Executable] -- ^list with exeNames updated + updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' + + updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo) + -> [Executable] -- ^list of executables to update + -> [Executable] -- ^libst with exeName updated + updateExecutable _ [] = [] + updateExecutable exe_bi'@(name,bi) (exe:exes) + | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes + | otherwise = exe : updateExecutable exe_bi' exes + +-- --------------------------------------------------------------------------- +-- The GenericPackageDescription type + +data GenericPackageDescription = + GenericPackageDescription { + packageDescription :: PackageDescription, + genPackageFlags :: [Flag], + condLibrary :: Maybe (CondTree ConfVar [Dependency] Library), + condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)], + condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)], + condBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] + } + deriving (Show, Eq, Typeable) + +instance Package GenericPackageDescription where + packageId = packageId . packageDescription + +--TODO: make PackageDescription an instance of Text. + +-- | A flag can represent a feature to be included, or a way of linking +-- a target against its dependencies, or in fact whatever you can think of. +data Flag = MkFlag + { flagName :: FlagName + , flagDescription :: String + , flagDefault :: Bool + , flagManual :: Bool + } + deriving (Show, Eq) + +-- | A 'FlagName' is the name of a user-defined configuration flag +newtype FlagName = FlagName String + deriving (Eq, Ord, Show, Read) + +-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to +-- 'Bool' flag values. It represents the flags chosen by the user or +-- discovered during configuration. For example @--flags=foo --flags=-bar@ +-- becomes @[("foo", True), ("bar", False)]@ +-- +type FlagAssignment = [(FlagName, Bool)] + +-- | A @ConfVar@ represents the variable type used. +data ConfVar = OS OS + | Arch Arch + | Flag FlagName + | Impl CompilerFlavor VersionRange + deriving (Eq, Show) + +--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 + | CNot (Condition c) + | COr (Condition c) (Condition c) + | CAnd (Condition c) (Condition c) + deriving (Show, Eq) + +--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] + +data CondTree v c a = CondNode + { condTreeData :: a + , condTreeConstraints :: c + , condTreeComponents :: [( Condition v + , CondTree v c a + , Maybe (CondTree v c a))] + } + deriving (Show, Eq) + +--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) diff --git a/cabal/Cabal/Distribution/PackageDescription/Check.hs b/cabal/Cabal/Distribution/PackageDescription/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/PackageDescription/Check.hs @@ -0,0 +1,1495 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Check +-- Copyright : Lennart Kolmodin 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This has code for checking for various problems in packages. There is one +-- set of checks that just looks at a 'PackageDescription' in isolation and +-- another set of checks that also looks at files in the package. Some of the +-- checks are basic sanity checks, others are portability standards that we'd +-- like to encourage. There is a 'PackageCheck' type that distinguishes the +-- 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 +-- 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(..), + checkPackage, + checkConfiguredPackage, + + -- ** Checking package contents + checkPackageFiles, + checkPackageContent, + CheckPackageContentOps(..), + checkPackageFileNames, + ) where + +import Data.Maybe + ( isNothing, isJust, catMaybes, maybeToList, fromMaybe ) +import Data.List (sort, group, isPrefixOf, nub, find) +import Control.Monad + ( filterM, liftM ) +import qualified System.Directory as System + ( doesFileExist, doesDirectoryExist ) + +import Distribution.Package ( pkgName ) +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription, finalizePackageDescription ) +import Distribution.Compiler + ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..) ) +import Distribution.System + ( OS(..), Arch(..), buildPlatform ) +import Distribution.License + ( License(..), knownLicenses ) +import Distribution.Simple.Utils + ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase ) + +import Distribution.Version + ( Version(..) + , VersionRange(..), foldVersionRange' + , anyVersion, noVersion, thisVersion, laterVersion, earlierVersion + , orLaterVersion, orEarlierVersion + , unionVersionRanges, intersectVersionRanges + , asVersionIntervals, UpperBound(..), isNoVersion ) +import Distribution.Package + ( PackageName(PackageName), packageName, packageVersion + , Dependency(..) ) + +import Distribution.Text + ( display, disp ) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>), (<+>)) + +import qualified Language.Haskell.Extension as Extension (deprecatedExtensions) +import Language.Haskell.Extension + ( Language(UnknownLanguage), knownLanguages, Extension(..), KnownExtension(..) ) +import System.FilePath + ( (), takeExtension, isRelative, isAbsolute + , splitDirectories, splitPath ) +import System.FilePath.Windows as FilePath.Windows + ( isValid ) + +-- | Results of some kind of failed package check. +-- +-- There are a range of severities, from merely dubious to totally insane. +-- All of them come with a human readable explanation. In future we may augment +-- them with more machine readable explanations, for example to help an IDE +-- suggest automatic corrections. +-- +data PackageCheck = + + -- | This package description is no good. There's no way it's going to + -- build sensibly. This should give an error at configure time. + PackageBuildImpossible { explanation :: String } + + -- | A problem that is likely to affect building the package, or an + -- issue that we'd like every package author to be aware of, even if + -- the package is never distributed. + | 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 + -- 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 + -- certain to be a portability problem for other environments. We can + -- quite legitimately refuse to publicly distribute packages with these + -- problems. + | PackageDistInexcusable { explanation :: String } + +instance Show PackageCheck where + show notice = explanation notice + +check :: Bool -> PackageCheck -> Maybe PackageCheck +check False _ = Nothing +check True pc = Just pc + +-- ------------------------------------------------------------ +-- * Standard checks +-- ------------------------------------------------------------ + +-- | Check for common mistakes and problems in package descriptions. +-- +-- This is the standard collection of checks covering all apsects except +-- for checks that require looking at files within the package. For those +-- see 'checkPackageFiles'. +-- +-- It requires the 'GenericPackageDescription' and optionally a particular +-- configuration of that package. If you pass 'Nothing' then we just check +-- a version of the generic description using 'flattenPackageDescription'. +-- +checkPackage :: GenericPackageDescription + -> Maybe PackageDescription + -> [PackageCheck] +checkPackage gpkg mpkg = + checkConfiguredPackage pkg + ++ checkConditionals gpkg + ++ checkPackageVersions gpkg + where + pkg = fromMaybe (flattenPackageDescription gpkg) mpkg + +--TODO: make this variant go away +-- we should alwaws know the GenericPackageDescription +checkConfiguredPackage :: PackageDescription -> [PackageCheck] +checkConfiguredPackage pkg = + checkSanity pkg + ++ checkFields pkg + ++ checkLicense pkg + ++ checkSourceRepos pkg + ++ checkGhcOptions pkg + ++ checkCCOptions pkg + ++ checkCPPOptions pkg + ++ checkPaths pkg + ++ checkCabalVersion pkg + + +-- ------------------------------------------------------------ +-- * Basic sanity checks +-- ------------------------------------------------------------ + +-- | Check that this package description is sane. +-- +checkSanity :: PackageDescription -> [PackageCheck] +checkSanity pkg = + catMaybes [ + + check (null . (\(PackageName n) -> n) . packageName $ pkg) $ + PackageBuildImpossible "No 'name' field." + + , check (null . versionBranch . packageVersion $ pkg) $ + PackageBuildImpossible "No 'version' field." + + , check (null (executables pkg) && isNothing (library pkg)) $ + PackageBuildImpossible + "No executables and no library 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. + + ++ maybe [] checkLibrary (library pkg) + ++ concatMap checkExecutable (executables pkg) + ++ concatMap (checkTestSuite pkg) (testSuites pkg) + ++ concatMap (checkBenchmark pkg) (benchmarks pkg) + + ++ catMaybes [ + + check (specVersion pkg > cabalVersion) $ + PackageBuildImpossible $ + "This package description follows version " + ++ display (specVersion pkg) ++ " of the Cabal specification. This " + ++ "tool only supports up to version " ++ display cabalVersion ++ "." + ] + where + exeNames = map exeName $ executables pkg + testNames = map testName $ testSuites pkg + bmNames = map benchmarkName $ benchmarks pkg + duplicateNames = dups $ exeNames ++ testNames ++ bmNames + +checkLibrary :: Library -> [PackageCheck] +checkLibrary lib = + catMaybes [ + + check (not (null moduleDuplicates)) $ + PackageBuildWarning $ + "Duplicate modules in library: " + ++ commaSep (map display moduleDuplicates) + ] + + where + moduleDuplicates = dups (libModules lib) + +checkExecutable :: Executable -> [PackageCheck] +checkExecutable exe = + catMaybes [ + + check (null (modulePath exe)) $ + PackageBuildImpossible $ + "No 'Main-Is' field found for executable " ++ exeName exe + + , check (not (null (modulePath exe)) + && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $ + PackageBuildImpossible $ + "The 'Main-Is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor)." + + , check (not (null moduleDuplicates)) $ + PackageBuildWarning $ + "Duplicate modules in executable '" ++ exeName exe ++ "': " + ++ commaSep (map display moduleDuplicates) + ] + where + moduleDuplicates = dups (exeModules exe) + +checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck] +checkTestSuite pkg test = + catMaybes [ + + case testInterface test of + TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a known type of test suite. " + ++ "The known test suite types are: " + ++ commaSep (map display knownTestTypes) + + TestSuiteUnsupported tt -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a supported test suite version. " + ++ "The known test suite types are: " + ++ commaSep (map display knownTestTypes) + _ -> Nothing + + , check (not $ null moduleDuplicates) $ + PackageBuildWarning $ + "Duplicate modules in test suite '" ++ testName test ++ "': " + ++ commaSep (map display moduleDuplicates) + + , check mainIsWrongExt $ + PackageBuildImpossible $ + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor)." + + -- Test suites might be built as (internal) libraries named after + -- the test suite and thus their names must not clash with the + -- name of the package. + , check libNameClash $ + PackageBuildImpossible $ + "The test suite " ++ testName test + ++ " has the same name as the package." + ] + where + moduleDuplicates = dups $ testModules test + + mainIsWrongExt = case testInterface test of + TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False + + libNameClash = testName test `elem` [ libName + | _lib <- maybeToList (library pkg) + , let PackageName libName = + pkgName (package pkg) ] + +checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck] +checkBenchmark pkg bm = + catMaybes [ + + case benchmarkInterface bm of + BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a known type of benchmark. " + ++ "The known benchmark types are: " + ++ commaSep (map display knownBenchmarkTypes) + + BenchmarkUnsupported tt -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a supported benchmark version. " + ++ "The known benchmark types are: " + ++ commaSep (map display knownBenchmarkTypes) + _ -> Nothing + + , check (not $ null moduleDuplicates) $ + PackageBuildWarning $ + "Duplicate modules in benchmark '" ++ benchmarkName bm ++ "': " + ++ commaSep (map display moduleDuplicates) + + , check mainIsWrongExt $ + PackageBuildImpossible $ + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor)." + + -- See comment for similar check on test suites. + , check libNameClash $ + PackageBuildImpossible $ + "The benchmark " ++ benchmarkName bm + ++ " has the same name as the package." + ] + where + moduleDuplicates = dups $ benchmarkModules bm + + mainIsWrongExt = case benchmarkInterface bm of + BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False + + libNameClash = benchmarkName bm `elem` [ libName + | _lib <- maybeToList (library pkg) + , let PackageName libName = + pkgName (package pkg) ] + +-- ------------------------------------------------------------ +-- * Additional pure checks +-- ------------------------------------------------------------ + +checkFields :: PackageDescription -> [PackageCheck] +checkFields pkg = + catMaybes [ + + check (not . FilePath.Windows.isValid . display . packageName $ pkg) $ + PackageDistInexcusable $ + "Unfortunately, the package name '" ++ display (packageName pkg) + ++ "' is one of the reserved system file names on Windows. Many tools " + ++ "need to convert package names to file names so using this name " + ++ "would cause problems." + + , check (isNothing (buildType pkg)) $ + PackageBuildWarning $ + "No 'build-type' specified. If you do not need a custom Setup.hs or " + ++ "./configure script then use 'build-type: Simple'." + + , case buildType pkg of + Just (UnknownBuildType unknown) -> Just $ + PackageBuildWarning $ + quote unknown ++ " is not a known 'build-type'. " + ++ "The known build types are: " + ++ commaSep (map display knownBuildTypes) + _ -> Nothing + + , check (not (null unknownCompilers)) $ + PackageBuildWarning $ + "Unknown compiler " ++ commaSep (map quote unknownCompilers) + ++ " in 'tested-with' field." + + , check (not (null unknownLanguages)) $ + PackageBuildWarning $ + "Unknown languages: " ++ commaSep unknownLanguages + + , check (not (null unknownExtensions)) $ + PackageBuildWarning $ + "Unknown extensions: " ++ commaSep unknownExtensions + + , check (not (null languagesUsedAsExtensions)) $ + PackageBuildWarning $ + "Languages listed as extensions: " + ++ commaSep languagesUsedAsExtensions + ++ ". Languages must be specified in either the 'default-language' " + ++ " or the 'other-languages' field." + + , check (not (null deprecatedExtensions)) $ + PackageDistSuspicious $ + "Deprecated extensions: " + ++ commaSep (map (quote . display . fst) deprecatedExtensions) + ++ ". " ++ intercalate " " + [ "Instead of '" ++ display ext + ++ "' use '" ++ display replacement ++ "'." + | (ext, Just replacement) <- deprecatedExtensions ] + + , check (null (category pkg)) $ + PackageDistSuspicious "No 'category' field." + + , check (null (maintainer pkg)) $ + PackageDistSuspicious "No 'maintainer' field." + + , check (null (synopsis pkg) && null (description pkg)) $ + PackageDistInexcusable $ "No 'synopsis' or 'description' field." + + , check (null (description pkg) && not (null (synopsis pkg))) $ + PackageDistSuspicious "No 'description' field." + + , check (null (synopsis pkg) && not (null (description pkg))) $ + PackageDistSuspicious "No 'synopsis' field." + + --TODO: recommend the bug reports url, author and homepage fields + --TODO: recommend not using the stability field + --TODO: recommend specifying a source repo + + , check (length (synopsis pkg) >= 80) $ + PackageDistSuspicious + "The 'synopsis' field is rather long (max 80 chars is recommended)." + + -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12" + , check (not (null testedWithImpossibleRanges)) $ + PackageDistInexcusable $ + "Invalid 'tested-with' version range: " + ++ commaSep (map display testedWithImpossibleRanges) + ++ ". To indicate that you have tested a package with multiple " + ++ "different versions of the same compiler use multiple entries, " + ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " + ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." + ] + where + unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] + unknownLanguages = [ name | bi <- allBuildInfo pkg + , UnknownLanguage name <- allLanguages bi ] + unknownExtensions = [ name | bi <- allBuildInfo pkg + , UnknownExtension name <- allExtensions bi + , name `notElem` map display knownLanguages ] + deprecatedExtensions = nub $ catMaybes + [ find ((==ext) . fst) Extension.deprecatedExtensions + | bi <- allBuildInfo pkg + , ext <- allExtensions bi ] + languagesUsedAsExtensions = + [ name | bi <- allBuildInfo pkg + , UnknownExtension name <- allExtensions bi + , name `elem` map display knownLanguages ] + + testedWithImpossibleRanges = + [ Dependency (PackageName (display compiler)) vr + | (compiler, vr) <- testedWith pkg + , isNoVersion vr ] + + +checkLicense :: PackageDescription -> [PackageCheck] +checkLicense pkg = + catMaybes [ + + check (license pkg == AllRightsReserved) $ + PackageDistInexcusable + "The 'license' field is missing or specified as AllRightsReserved." + + , case license pkg of + UnknownLicense l -> Just $ + PackageBuildWarning $ + quote ("license: " ++ l) ++ " is not a recognised license. The " + ++ "known licenses are: " + ++ commaSep (map display knownLicenses) + _ -> Nothing + + , check (license pkg == BSD4) $ + PackageDistSuspicious $ + "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " + ++ "refers to the old 4-clause BSD license with the advertising " + ++ "clause. 'BSD3' refers the new 3-clause BSD license." + + , case unknownLicenseVersion (license pkg) of + Just knownVersions -> Just $ + PackageDistSuspicious $ + "'license: " ++ display (license pkg) ++ "' is not a known " + ++ "version of that license. The known versions are " + ++ commaSep (map display knownVersions) + ++ ". If this is not a mistake and you think it should be a known " + ++ "version then please file a ticket." + _ -> Nothing + + , check (license pkg `notElem` [AllRightsReserved, PublicDomain] + -- AllRightsReserved and PublicDomain are not strictly + -- licenses so don't need license files. + && null (licenseFile pkg)) $ + PackageDistSuspicious "A 'license-file' is not specified." + ] + where + unknownLicenseVersion (GPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where knownVersions = [ v' | GPL (Just v') <- knownLicenses ] + unknownLicenseVersion (LGPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ] + unknownLicenseVersion (Apache (Just v)) + | v `notElem` knownVersions = Just knownVersions + where knownVersions = [ v' | Apache (Just v') <- knownLicenses ] + unknownLicenseVersion _ = Nothing + +checkSourceRepos :: PackageDescription -> [PackageCheck] +checkSourceRepos pkg = + catMaybes $ concat [[ + + case repoKind repo of + RepoKindUnknown kind -> Just $ PackageDistInexcusable $ + quote kind ++ " is not a recognised kind of source-repository. " + ++ "The repo kind is usually 'head' or 'this'" + _ -> Nothing + + , check (repoType repo == Nothing) $ + PackageDistInexcusable + "The source-repository 'type' is a required field." + + , check (repoLocation repo == Nothing) $ + PackageDistInexcusable + "The source-repository 'location' is a required field." + + , check (repoType repo == Just CVS && repoModule repo == Nothing) $ + PackageDistInexcusable + "For a CVS source-repository, the 'module' is a required field." + + , check (repoKind repo == RepoThis && repoTag repo == Nothing) $ + PackageDistInexcusable $ + "For the 'this' kind of source-repository, the 'tag' is a required " + ++ "field. It should specify the tag corresponding to this version " + ++ "or release of the package." + + , check (maybe False System.FilePath.isAbsolute (repoSubdir repo)) $ + PackageDistInexcusable + "The 'subdir' field of a source-repository must be a relative path." + ] + | repo <- sourceRepos pkg ] + +--TODO: check location looks like a URL for some repo types. + +checkGhcOptions :: PackageDescription -> [PackageCheck] +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"] $ + PackageDistInexcusable $ + "'ghc-options: -fasm' is unnecessary and will not work on CPU " + ++ "architectures other than x86, x86-64, ppc or sparc." + + , checkFlags ["-fvia-C"] $ + PackageDistSuspicious $ + "'ghc-options: -fvia-C' is usually unnecessary. If your package " + ++ "needs -via-C for correctness rather than performance then it " + ++ "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." + + , checkFlags ["-prof"] $ + PackageBuildWarning $ + "'ghc-options: -prof' is not necessary and will lead to problems " + ++ "when used on a library. Use the configure flag " + ++ "--enable-library-profiling and/or --enable-executable-profiling." + + , checkFlags ["-o"] $ + PackageBuildWarning $ + "'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." + + , checkFlags ["--make"] $ + PackageBuildWarning $ + "'ghc-options: --make' is never needed. Cabal uses this automatically." + + , checkFlags ["-main-is"] $ + PackageDistSuspicious $ + "'ghc-options: -main-is' is not portable." + + , checkFlags ["-O0", "-Onot"] $ + PackageDistSuspicious $ + "'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." + + , 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." + + , checkFlags ["-split-objs"] $ + PackageBuildWarning $ + "'ghc-options: -split-objs' is not needed. Use the --enable-split-objs configure flag." + + , checkFlags ["-optl-Wl,-s", "-optl-s"] $ + PackageDistInexcusable $ + "'ghc-options: -optl-Wl,-s' is not needed and is not portable to all" + ++ " operating systems. Cabal 1.4 and later automatically strip" + ++ " executables. Cabal also has a flag --disable-executable-stripping" + ++ " which is necessary when building packages for some Linux" + ++ " distributions and using '-optl-Wl,-s' prevents that from working." + + , checkFlags ["-fglasgow-exts"] $ + PackageDistSuspicious $ + "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use the 'extensions' field." + + , check ("-threaded" `elem` lib_ghc_options) $ + PackageDistSuspicious $ + "'ghc-options: -threaded' 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] ] + + , checkAlternatives "ghc-options" "extensions" + [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "cpp-options" $ + [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ] + ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "include-dirs" + [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "extra-libraries" + [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "extra-lib-dirs" + [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ] + ] + + 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) + + 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) + _ -> Nothing + ghcExtension "-cpp" = Just (EnableExtension CPP) + ghcExtension _ = Nothing + +checkCCOptions :: PackageDescription -> [PackageCheck] +checkCCOptions pkg = + catMaybes [ + + checkAlternatives "cc-options" "include-dirs" + [ (flag, dir) | flag@('-':'I':dir) <- all_ccOptions ] + + , checkAlternatives "cc-options" "extra-libraries" + [ (flag, lib) | flag@('-':'l':lib) <- all_ccOptions ] + + , checkAlternatives "cc-options" "extra-lib-dirs" + [ (flag, dir) | flag@('-':'L':dir) <- all_ccOptions ] + + , checkAlternatives "ld-options" "extra-libraries" + [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ] + + , checkAlternatives "ld-options" "extra-lib-dirs" + [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ] + + , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $ + PackageDistSuspicious $ + "'cc-options: -O[n]' is generally not needed. When building with " + ++ " optimisations Cabal automatically adds '-O2' for C code. " + ++ "Setting it yourself interferes with the --disable-optimization " + ++ "flag." + ] + + where all_ccOptions = [ opts | bi <- allBuildInfo pkg + , opts <- ccOptions bi ] + all_ldOptions = [ opts | bi <- allBuildInfo pkg + , opts <- ldOptions bi ] + + checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck + checkCCFlags flags = check (any (`elem` flags) all_ccOptions) + +checkCPPOptions :: PackageDescription -> [PackageCheck] +checkCPPOptions pkg = + catMaybes [ + checkAlternatives "cpp-options" "include-dirs" + [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions] + ] + where all_cppOptions = [ opts | bi <- allBuildInfo pkg + , opts <- cppOptions bi ] + +checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck +checkAlternatives badField goodField flags = + check (not (null badFlags)) $ + PackageBuildWarning $ + "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags) + ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags) + + where (badFlags, goodFlags) = unzip flags + +checkPaths :: PackageDescription -> [PackageCheck] +checkPaths pkg = + [ PackageBuildWarning $ + quote (kind ++ ": " ++ path) + ++ " is a relative path outside of the source tree. " + ++ "This will not work when generating a tarball with 'sdist'." + | (path, kind) <- relPaths ++ absPaths + , isOutsideTree path ] + ++ + [ PackageDistInexcusable $ + quote (kind ++ ": " ++ path) ++ " is an absolute directory." + | (path, kind) <- relPaths + , isAbsolute path ] + ++ + [ PackageDistInexcusable $ + quote (kind ++ ": " ++ path) ++ " points inside the 'dist' " + ++ "directory. This is not reliable because the location of this " + ++ "directory is configurable by the user (or package manager). In " + ++ "addition the layout of the 'dist' directory is subject to change " + ++ "in future versions of Cabal." + | (path, kind) <- relPaths ++ absPaths + , isInsideDist path ] + ++ + [ PackageDistInexcusable $ + "The 'ghc-options' contains the path '" ++ path ++ "' which points " + ++ "inside the 'dist' directory. This is not reliable because the " + ++ "location of this directory is configurable by the user (or package " + ++ "manager). In addition the layout of the 'dist' directory is subject " + ++ "to change in future versions of Cabal." + | bi <- allBuildInfo pkg + , (GHC, flags) <- options bi + , path <- flags + , isInsideDist path ] + where + isOutsideTree path = case splitDirectories path of + "..":_ -> True + ".":"..":_ -> True + _ -> False + isInsideDist path = case map lowercase (splitDirectories path) of + "dist" :_ -> True + ".":"dist":_ -> True + _ -> False + -- paths that must be relative + relPaths = + [ (path, "extra-src-files") | path <- extraSrcFiles pkg ] + ++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ] + ++ [ (path, "data-files") | path <- dataFiles pkg ] + ++ [ (path, "data-dir") | path <- [dataDir pkg]] + ++ concat + [ [ (path, "c-sources") | path <- cSources bi ] + ++ [ (path, "install-includes") | path <- installIncludes bi ] + ++ [ (path, "hs-source-dirs") | path <- hsSourceDirs bi ] + | bi <- allBuildInfo pkg ] + -- paths that are allowed to be absolute + absPaths = concat + [ [ (path, "includes") | path <- includes bi ] + ++ [ (path, "include-dirs") | path <- includeDirs bi ] + ++ [ (path, "extra-lib-dirs") | path <- extraLibDirs bi ] + | bi <- allBuildInfo pkg ] + +--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. + +--TODO: use the tar path checks on all the above paths + +-- | Check that the package declares the version in the @\"cabal-version\"@ +-- field correctly. +-- +checkCabalVersion :: PackageDescription -> [PackageCheck] +checkCabalVersion pkg = + catMaybes [ + + -- check syntax of cabal-version field + check (specVersion pkg >= Version [1,10] [] + && not simpleSpecVersionRangeSyntax) $ + PackageBuildWarning $ + "Packages relying on Cabal 1.10 or later must only specify a " + ++ "version range of the form 'cabal-version: >= x.y'. Use " + ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'." + + -- check syntax of cabal-version field + , check (specVersion pkg < Version [1,9] [] + && not simpleSpecVersionRangeSyntax) $ + PackageDistSuspicious $ + "It is recommended that the 'cabal-version' field only specify a " + ++ "version range of the form '>= x.y'. Use " + ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'. " + ++ "Tools based on Cabal 1.10 and later will ignore upper bounds." + + -- check syntax of cabal-version field + , checkVersion [1,12] simpleSpecVersionSyntax $ + PackageBuildWarning $ + "With Cabal 1.10 or earlier, the 'cabal-version' field must use " + ++ "range syntax rather than a simple version number. Use " + ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'." + + -- check use of test suite sections + , checkVersion [1,8] (not (null $ testSuites pkg)) $ + PackageDistInexcusable $ + "The 'test-suite' section is new in Cabal 1.10. " + ++ "Unfortunately it messes up the parser in older Cabal versions " + ++ "so you must specify at least 'cabal-version: >= 1.8', but note " + ++ "that only Cabal 1.10 and later can actually run such test suites." + + -- check use of default-language field + -- note that we do not need to do an equivalent check for the + -- other-language field since that one does not change behaviour + , checkVersion [1,10] (any isJust (buildInfoField defaultLanguage)) $ + PackageBuildWarning $ + "To use the 'default-language' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." + + , check (specVersion pkg >= Version [1,10] [] + && (any isNothing (buildInfoField defaultLanguage))) $ + PackageBuildWarning $ + "Packages using 'cabal-version: >= 1.10' must specify the " + ++ "'default-language' field for each component (e.g. Haskell98 or " + ++ "Haskell2010). If a component uses different languages in " + ++ "different modules then list the other ones in the " + ++ "'other-languages' field." + + -- 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)) $ + PackageBuildWarning $ + "To use the 'default-extensions' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." + + -- check use of extensions field + , check (specVersion pkg >= Version [1,10] [] + && (any (not . null) (buildInfoField oldExtensions))) $ + PackageBuildWarning $ + "For packages using 'cabal-version: >= 1.10' the 'extensions' " + ++ "field is deprecated. The new 'default-extensions' field lists " + ++ "extensions that are used in all modules in the component, while " + ++ "the 'other-extensions' field lists extensions that are used in " + ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." + + -- check use of "foo (>= 1.0 && < 1.4) || >=1.8 " version-range syntax + , checkVersion [1,8] (not (null versionRangeExpressions)) $ + PackageDistInexcusable $ + "The package uses full version-range expressions " + ++ "in a 'build-depends' field: " + ++ commaSep (map displayRawDependency versionRangeExpressions) + ++ ". To use this new syntax the package needs to specify at least " + ++ "'cabal-version: >= 1.8'. Alternatively, if broader compatibility " + ++ "is important, then convert to conjunctive normal form, and use " + ++ "multiple 'build-depends:' lines, one conjunct per line." + + -- check use of "build-depends: foo == 1.*" syntax + , checkVersion [1,6] (not (null depsUsingWildcardSyntax)) $ + PackageDistInexcusable $ + "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 " + ++ "is important then use: " ++ commaSep + [ display (Dependency name (eliminateWildcardSyntax versionRange)) + | Dependency name versionRange <- depsUsingWildcardSyntax ] + + -- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax + , checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $ + PackageDistInexcusable $ + "The package uses full version-range expressions " + ++ "in a 'tested-with' field: " + ++ commaSep (map displayRawDependency testedWithVersionRangeExpressions) + ++ ". To use this new syntax the package needs to specify at least " + ++ "'cabal-version: >= 1.8'." + + -- check use of "tested-with: GHC == 6.12.*" syntax + , checkVersion [1,6] (not (null testedWithUsingWildcardSyntax)) $ + PackageDistInexcusable $ + "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 " + ++ "is important then use: " ++ commaSep + [ display (Dependency name (eliminateWildcardSyntax versionRange)) + | Dependency name versionRange <- testedWithUsingWildcardSyntax ] + + -- check use of "data-files: data/*.txt" syntax + , checkVersion [1,6] (not (null dataFilesUsingGlobSyntax)) $ + PackageDistInexcusable $ + "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 " + ++ "versions then list all the files explicitly." + + -- check use of "extra-source-files: mk/*.in" syntax + , checkVersion [1,6] (not (null extraSrcFilesUsingGlobSyntax)) $ + PackageDistInexcusable $ + "Using wildcards like " + ++ 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 " + ++ "explicitly." + + -- check use of "source-repository" section + , checkVersion [1,6] (not (null (sourceRepos pkg))) $ + PackageDistInexcusable $ + "The 'source-repository' section is new in Cabal 1.6. " + ++ "Unfortunately it messes up the parser in earlier Cabal versions " + ++ "so you need to specify 'cabal-version: >= 1.6'." + + -- check for new licenses + , checkVersion [1,4] (license pkg `notElem` compatLicenses) $ + PackageDistInexcusable $ + "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'." + + -- check for new language extensions + , checkVersion [1,2,3] (not (null mentionedExtensionsThatNeedCabal12)) $ + PackageDistInexcusable $ + "Unfortunately the language extensions " + ++ 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 " + ++ "use an equivalent compiler-specific flag." + + , checkVersion [1,4] (not (null mentionedExtensionsThatNeedCabal14)) $ + PackageDistInexcusable $ + "Unfortunately the language extensions " + ++ 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 " + ++ "use an equivalent compiler-specific flag." + ] + where + -- Perform a check on packages that use a version of the spec less than + -- the version given. This is for cases where a new Cabal version adds + -- a new feature and we want to check that it is not used prior to that + -- version. + checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck + checkVersion ver cond pc + | specVersion pkg >= Version ver [] = Nothing + | otherwise = check cond pc + + buildInfoField field = map field (allBuildInfo pkg) + dataFilesUsingGlobSyntax = filter usesGlobSyntax (dataFiles pkg) + extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg) + usesGlobSyntax str = case parseFileGlob str of + Just (FileGlob _ _) -> True + _ -> False + + versionRangeExpressions = + [ dep | dep@(Dependency _ vr) <- buildDepends pkg + , usesNewVersionRangeSyntax vr ] + + testedWithVersionRangeExpressions = + [ Dependency (PackageName (display compiler)) vr + | (compiler, vr) <- testedWith pkg + , usesNewVersionRangeSyntax vr ] + + simpleSpecVersionRangeSyntax = + either (const True) + (foldVersionRange' + True + (\_ -> False) + (\_ -> False) (\_ -> False) + (\_ -> True) -- >= + (\_ -> False) + (\_ _ -> False) + (\_ _ -> False) (\_ _ -> False) + id) + (specVersionRaw pkg) + + -- is the cabal-version field a simple version number, rather than a range + simpleSpecVersionSyntax = + either (const True) (const False) (specVersionRaw pkg) + + usesNewVersionRangeSyntax :: VersionRange -> Bool + usesNewVersionRangeSyntax = + (> 2) -- uses the new syntax if depth is more than 2 + . foldVersionRange' + (1 :: Int) + (const 1) + (const 1) (const 1) + (const 1) (const 1) + (const (const 1)) + (+) (+) + (const 3) -- uses new ()'s syntax + + depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg + , usesWildcardSyntax vr ] + + testedWithUsingWildcardSyntax = [ Dependency (PackageName (display compiler)) vr + | (compiler, vr) <- testedWith pkg + , usesWildcardSyntax vr ] + + usesWildcardSyntax :: VersionRange -> Bool + usesWildcardSyntax = + foldVersionRange' + False (const False) + (const False) (const False) + (const False) (const False) + (\_ _ -> True) -- the wildcard case + (||) (||) id + + eliminateWildcardSyntax = + foldVersionRange' + anyVersion thisVersion + laterVersion earlierVersion + orLaterVersion orEarlierVersion + (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v')) + intersectVersionRanges unionVersionRanges id + + compatLicenses = [ GPL Nothing, LGPL Nothing, BSD3, BSD4 + , PublicDomain, AllRightsReserved, OtherLicense ] + + mentionedExtensions = [ ext | bi <- allBuildInfo pkg + , ext <- allExtensions bi ] + mentionedExtensionsThatNeedCabal12 = + nub (filter (`elem` compatExtensionsExtra) mentionedExtensions) + + -- As of Cabal-1.4 we can add new extensions without worrying about + -- breaking old versions of cabal. + mentionedExtensionsThatNeedCabal14 = + nub (filter (`notElem` compatExtensions) mentionedExtensions) + + -- The known extensions in Cabal-1.2.3 + compatExtensions = + map EnableExtension + [ OverlappingInstances, UndecidableInstances, IncoherentInstances + , RecursiveDo, ParallelListComp, MultiParamTypeClasses + , FunctionalDependencies, Rank2Types + , RankNTypes, PolymorphicComponents, ExistentialQuantification + , ScopedTypeVariables, ImplicitParams, FlexibleContexts + , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns + , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface + , Arrows, Generics, NamedFieldPuns, PatternGuards + , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms + , HereDocuments] ++ + map DisableExtension + [MonomorphismRestriction, ImplicitPrelude] ++ + compatExtensionsExtra + + -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6 + -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8) + compatExtensionsExtra = + map EnableExtension + [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving + , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms + , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields + , OverloadedStrings, GADTs, RelaxedPolyRec + , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable + , ConstrainedClassMethods + ] ++ + map DisableExtension + [MonoPatBinds] + +-- | 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! +-- +displayRawVersionRange :: VersionRange -> String +displayRawVersionRange = + Disp.render + . fst + . foldVersionRange' -- precedence: + -- All the same as the usual pretty printer, except for the parens + ( Disp.text "-any" , 0 :: Int) + (\v -> (Disp.text "==" <> disp v , 0)) + (\v -> (Disp.char '>' <> disp v , 0)) + (\v -> (Disp.char '<' <> disp v , 0)) + (\v -> (Disp.text ">=" <> disp v , 0)) + (\v -> (Disp.text "<=" <> disp v , 0)) + (\v _ -> (Disp.text "==" <> dispWild v , 0)) + (\(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 + dispWild (Version b _) = + Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) + <> Disp.text ".*" + punct p p' | p < p' = Disp.parens + | otherwise = id + +displayRawDependency :: Dependency -> String +displayRawDependency (Dependency pkg vr) = + display pkg ++ " " ++ displayRawVersionRange vr + + +-- ------------------------------------------------------------ +-- * Checks on the GenericPackageDescription +-- ------------------------------------------------------------ + +-- | Check the build-depends fields for any weirdness or bad practise. +-- +checkPackageVersions :: GenericPackageDescription -> [PackageCheck] +checkPackageVersions pkg = + catMaybes [ + + -- Check that the version of base is bounded above. + -- For example this bans "build-depends: base >= 3". + -- It should probably be "build-depends: base >= 3 && < 4" + -- which is the same as "build-depends: base == 3.*" + check (not (boundedAbove baseDependency)) $ + PackageDistInexcusable $ + "The dependency 'build-depends: base' does not specify an upper " + ++ "bound on the version number. Each major release of the 'base' " + ++ "package changes the API in various ways and most packages will " + ++ "need some changes to compile with it. The recommended practise " + ++ "is to specify an upper bound on the version of the 'base' " + ++ "package. This ensures your package will continue to build when a " + ++ "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'." + + ] + where + -- TODO: What we really want to do is test if there exists any + -- configuration in which the base version is unboudned above. + -- However that's a bit tricky because there are many possible + -- configurations. As a cheap easy and safe approximation we will + -- pick a single "typical" configuration and check if that has an + -- open upper bound. To get a typical configuration we finalise + -- using no package index and the current platform. + finalised = finalizePackageDescription + [] (const True) buildPlatform + (CompilerId buildCompilerFlavor (Version [] [])) + [] pkg + baseDependency = case finalised of + Right (pkg', _) | not (null baseDeps) -> + foldr intersectVersionRanges anyVersion baseDeps + where + baseDeps = + [ vr | Dependency (PackageName "base") vr <- buildDepends pkg' ] + + -- Just in case finalizePackageDescription fails for any reason, + -- or if the package doesn't depend on the base package at all, + -- then we will just skip the check, since boundedAbove noVersion = True + _ -> noVersion + + boundedAbove :: VersionRange -> Bool + boundedAbove vr = case asVersionIntervals vr of + [] -> True -- this is the inconsistent version range. + intervals -> case last intervals of + (_, UpperBound _ _) -> True + (_, NoUpperBound ) -> False + + +checkConditionals :: GenericPackageDescription -> [PackageCheck] +checkConditionals pkg = + catMaybes [ + + check (not $ null unknownOSs) $ + PackageDistInexcusable $ + "Unknown operating system name " + ++ commaSep (map quote unknownOSs) + + , check (not $ null unknownArches) $ + PackageDistInexcusable $ + "Unknown architecture name " + ++ commaSep (map quote unknownArches) + + , check (not $ null unknownImpls) $ + PackageDistInexcusable $ + "Unknown compiler name " + ++ commaSep (map quote unknownImpls) + ] + where + unknownOSs = [ os | OS (OtherOS os) <- conditions ] + unknownArches = [ arch | Arch (OtherArch arch) <- conditions ] + unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ] + conditions = maybe [] freeVars (condLibrary pkg) + ++ concatMap (freeVars . snd) (condExecutables pkg) + freeVars (CondNode _ _ ifs) = concatMap compfv ifs + compfv (c, ct, mct) = condfv c ++ freeVars ct ++ maybe [] freeVars mct + condfv c = case c of + Var v -> [v] + Lit _ -> [] + CNot c1 -> condfv c1 + COr c1 c2 -> condfv c1 ++ condfv c2 + CAnd c1 c2 -> condfv c1 ++ condfv c2 + +-- ------------------------------------------------------------ +-- * 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. +-- +checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck] +checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg + where + checkFilesIO = CheckPackageContentOps { + doesFileExist = System.doesFileExist . relative, + doesDirectoryExist = System.doesDirectoryExist . relative + } + relative path = root path + +-- | A record of operations needed to check the contents of packages. +-- Used by 'checkPackageContent'. +-- +data CheckPackageContentOps m = CheckPackageContentOps { + doesFileExist :: FilePath -> m Bool, + doesDirectoryExist :: FilePath -> m Bool + } + +-- | Sanity check things that requires looking at files in the package. +-- This is a generalised version of 'checkPackageFiles' that can work in any +-- monad for which you can provide 'CheckPackageContentOps' operations. +-- +-- The point of this extra generality is to allow doing checks in some virtual +-- file system, for example a tarball in memory. +-- +checkPackageContent :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkPackageContent ops pkg = do + licenseError <- checkLicenseExists ops pkg + setupError <- checkSetupExists ops pkg + configureError <- checkConfigureExists ops pkg + localPathErrors <- checkLocalPathsExist ops pkg + vcsLocation <- checkMissingVcsInfo ops pkg + + return $ catMaybes [licenseError, 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." + + where + file = licenseFile pkg + +checkSetupExists :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkSetupExists ops _ = do + hsexists <- doesFileExist ops "Setup.hs" + lhsexists <- doesFileExist ops "Setup.lhs" + return $ check (not hsexists && not lhsexists) $ + PackageDistInexcusable $ + "The package is missing a Setup.hs or Setup.lhs script." + +checkConfigureExists :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkConfigureExists ops PackageDescription { buildType = Just Configure } = do + exists <- doesFileExist ops "configure" + return $ check (not exists) $ + PackageBuildWarning $ + "The 'build-type' is 'Configure' but there is no 'configure' script." +checkConfigureExists _ _ = return Nothing + +checkLocalPathsExist :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkLocalPathsExist ops pkg = do + let dirs = [ (dir, kind) + | bi <- allBuildInfo pkg + , (dir, kind) <- + [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ] + ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] + ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ] + , isRelative dir ] + missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs + return [ PackageBuildWarning { + explanation = quote (kind ++ ": " ++ dir) + ++ " directory does not exist." + } + | (dir, kind) <- missing ] + +checkMissingVcsInfo :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do + vcsInUse <- liftM or $ mapM (doesDirectoryExist ops) repoDirnames + if vcsInUse + then return [ PackageDistSuspicious message ] + else return [] + where + repoDirnames = [ dirname | repo <- knownRepoTypes + , dirname <- repoTypeDirname repo ] + message = "When distributing packages it is encouraged to specify source " + ++ "control information in the .cabal file using one or more " + ++ "'source-repository' sections. See the Cabal user guide for " + ++ "details." + +checkMissingVcsInfo _ _ = return [] + +repoTypeDirname :: RepoType -> [FilePath] +repoTypeDirname Darcs = ["_darcs"] +repoTypeDirname Git = [".git"] +repoTypeDirname SVN = [".svn"] +repoTypeDirname CVS = ["CVS"] +repoTypeDirname Mercurial = [".hg"] +repoTypeDirname GnuArch = [".arch-params"] +repoTypeDirname Bazaar = [".bzr"] +repoTypeDirname Monotone = ["_MTN"] +repoTypeDirname _ = [] + +-- ------------------------------------------------------------ +-- * Checks involving files in the package +-- ------------------------------------------------------------ + +-- | Check the names of all files in a package for portability problems. This +-- should be done for example when creating or validating a package tarball. +-- +checkPackageFileNames :: [FilePath] -> [PackageCheck] +checkPackageFileNames files = + (take 1 . catMaybes . map checkWindowsPath $ files) + ++ (take 1 . catMaybes . map checkTarPath $ files) + -- If we get any of these checks triggering then we're likely to get + -- many, and that's probably not helpful, so return at most one. + +checkWindowsPath :: FilePath -> Maybe PackageCheck +checkWindowsPath path = + check (not $ FilePath.Windows.isValid path') $ + PackageDistInexcusable $ + "Unfortunately, the file " ++ quote path ++ " is not a valid file " + ++ "name on Windows which would cause portability problems for this " + ++ "package. Windows file names cannot contain any of the characters " + ++ "\":*?<>|\" and there are a few reserved names including \"aux\", " + ++ "\"nul\", \"con\", \"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." + where + path' = ".\\" ++ path + -- force a relative name to catch invalid file names like "f:oo" which + -- otherwise parse as file "oo" in the current directory on the 'f' drive. + +-- | Check a file name is valid for the portable POSIX tar format. +-- +-- The POSIX tar format has a restriction on the length of file names. It is +-- unfortunately not a simple restriction like a maximum length. The exact +-- restriction is that either the whole path be 100 characters or less, or it +-- be possible to split the path on a directory separator such that the first +-- part is 155 characters or less and the second part 100 characters or less. +-- +checkTarPath :: FilePath -> Maybe PackageCheck +checkTarPath path + | length path > 255 = Just longPath + | otherwise = case pack nameMax (reverse (splitPath path)) of + Left err -> Just err + Right [] -> Nothing + Right (first:rest) -> case pack prefixMax remainder of + Left err -> Just err + Right [] -> Nothing + Right (_:_) -> Just noSplit + where + -- drop the '/' between the name and prefix: + remainder = init first : rest + + where + nameMax, prefixMax :: Int + nameMax = 100 + prefixMax = 155 + + pack _ [] = Left emptyName + pack maxLen (c:cs) + | n > maxLen = Left longName + | otherwise = Right (pack' maxLen n cs) + where n = length c + + pack' maxLen n (c:cs) + | n' <= maxLen = pack' maxLen n' cs + where n' = n + length c + pack' _ _ cs = cs + + longPath = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length is 255 ASCII characters.\n" + ++ "The file in question is:\n " ++ path + longName = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length for the name part (including " + ++ "extension) is 100 ASCII characters. The maximum length for any " + ++ "individual directory component is 155.\n" + ++ "The file in question is:\n " ++ path + noSplit = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. While the total length is less than 255 ASCII " + ++ "characters, there are unfortunately further restrictions. It has to " + ++ "be possible to split the file path on a directory separator into " + ++ "two parts such that the first part fits in 155 characters or less " + ++ "and the second part fits in 100 characters or less. Basically you " + ++ "have to make the file name or directory names shorter, or you could " + ++ "split a long directory name into nested subdirectories with shorter " + ++ "names.\nThe file in question is:\n " ++ path + emptyName = PackageDistInexcusable $ + "Encountered a file with an empty name, something is very wrong! " + ++ "Files with an empty name cannot be stored in a tar archive or in " + ++ "standard file systems." + +-- ------------------------------------------------------------ +-- * Utils +-- ------------------------------------------------------------ + +quote :: String -> String +quote s = "'" ++ s ++ "'" + +commaSep :: [String] -> String +commaSep = intercalate ", " + +dups :: Ord a => [a] -> [a] +dups xs = [ x | (x:_:_) <- group (sort xs) ] diff --git a/cabal/Cabal/Distribution/PackageDescription/Configuration.hs b/cabal/Cabal/Distribution/PackageDescription/Configuration.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/PackageDescription/Configuration.hs @@ -0,0 +1,652 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +-- -fno-warn-deprecations for use of Map.foldWithKey +{-# OPTIONS_GHC -cpp -fno-warn-deprecations #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Configuration +-- Copyright : Thomas Schilling, 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is about the cabal configurations feature. It exports +-- 'finalizePackageDescription' and 'flattenPackageDescription' which are +-- functions for converting 'GenericPackageDescription's down to +-- 'PackageDescription's. It has code for working with the tree of conditions +-- and resolving or flattening conditions. + +{- 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, + + -- Utils + parseCondition, + freeVars, + mapCondTree, + mapTreeData, + mapTreeConds, + mapTreeConstrs, + ) where + +import Distribution.Package + ( PackageName, Dependency(..) ) +import Distribution.PackageDescription + ( GenericPackageDescription(..), PackageDescription(..) + , Library(..), Executable(..), BuildInfo(..) + , Flag(..), FlagName(..), FlagAssignment + , Benchmark(..), CondTree(..), ConfVar(..), Condition(..) + , TestSuite(..) ) +import Distribution.Version + ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) +import Distribution.Compiler + ( CompilerId(CompilerId) ) +import Distribution.System + ( Platform(..), OS, Arch ) +import Distribution.Simple.Utils + ( currentDir, lowercase ) + +import Distribution.Text + ( Text(parse) ) +import Distribution.Compat.ReadP as ReadP hiding ( char ) +import Control.Arrow (first) +import qualified Distribution.Compat.ReadP as ReadP ( char ) + +import Data.Char ( isAlphaNum ) +import Data.Maybe ( catMaybes, maybeToList ) +import Data.Map ( Map, fromListWith, toList ) +import qualified Data.Map as Map +import Data.Monoid + +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606) +import qualified Text.Read as R +import qualified Text.Read.Lex as L +#endif + +------------------------------------------------------------------------------ + +-- | Simplify the condition and return its free variables. +simplifyCondition :: Condition c + -> (c -> Either d Bool) -- ^ (partial) variable assignment + -> (Condition d, [d]) +simplifyCondition cond i = fv . walk $ cond + where + walk cnd = case cnd of + Var v -> either Var Lit (i v) + Lit b -> Lit b + CNot c -> case walk c of + Lit True -> Lit False + Lit False -> Lit True + c' -> CNot c' + COr c d -> case (walk c, walk d) of + (Lit False, d') -> d' + (Lit True, _) -> Lit True + (c', Lit False) -> c' + (_, Lit True) -> Lit True + (c',d') -> COr c' d' + CAnd c d -> case (walk c, walk d) of + (Lit False, _) -> Lit False + (Lit True, d') -> d' + (_, Lit False) -> Lit False + (c', Lit True) -> c' + (c',d') -> CAnd c' d' + -- gather free vars + fv c = (c, fv' c) + fv' c = case c of + Var v -> [v] + Lit _ -> [] + CNot c' -> fv' c' + 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 +-- the names of all the flags occurring in the condition. +simplifyWithSysParams :: OS -> Arch -> CompilerId -> Condition ConfVar + -> (Condition FlagName, [FlagName]) +simplifyWithSysParams os arch (CompilerId comp compVer) 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 + +-- TODO: Add instances and check +-- +-- prop_sC_idempotent cond a o = cond' == cond'' +-- where +-- cond' = simplifyCondition cond a o +-- cond'' = simplifyCondition cond' a o +-- +-- prop_sC_noLits cond a o = isLit res || not (hasLits res) +-- where +-- res = simplifyCondition cond a o +-- hasLits (Lit _) = True +-- hasLits (CNot c) = hasLits c +-- hasLits (COr l r) = hasLits l || hasLits r +-- hasLits (CAnd l r) = hasLits l || hasLits r +-- hasLits _ = False +-- + +-- | Parse a configuration condition from a string. +parseCondition :: ReadP r (Condition ConfVar) +parseCondition = condOr + where + condOr = sepBy1 condAnd (oper "||") >>= return . foldl1 COr + condAnd = sepBy1 cond (oper "&&")>>= return . foldl1 CAnd + cond = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond + +++ archCond +++ flagCond +++ implCond ) + inparens = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp) + notCond = ReadP.char '!' >> sp >> cond >>= return . CNot + osCond = string "os" >> sp >> inparens osIdent >>= return . Var + archCond = string "arch" >> sp >> inparens archIdent >>= return . Var + flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var + implCond = string "impl" >> sp >> inparens implIdent >>= return . Var + boolLiteral = fmap Lit parse + archIdent = fmap Arch parse + osIdent = fmap OS parse + flagIdent = fmap (Flag . FlagName . lowercase) (munch1 isIdentChar) + isIdentChar c = isAlphaNum c || c == '_' || c == '-' + oper s = sp >> string s >> sp + sp = skipSpaces + implIdent = do i <- parse + vr <- sp >> option anyVersion parse + return $ Impl i vr + +------------------------------------------------------------------------------ + +mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) + -> CondTree v c a -> CondTree w d b +mapCondTree fa fc fcnd (CondNode a c ifs) = + CondNode (fa a) (fc c) (map g ifs) + where + g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t, + fmap (mapCondTree fa fc fcnd) me) + +mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a +mapTreeConstrs f = mapCondTree id f id + +mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a +mapTreeConds f = mapCondTree id id f + +mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b +mapTreeData f = mapCondTree f id id + +-- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for +-- clarity. +data DepTestRslt d = DepOk | MissingDeps d + +instance Monoid d => Monoid (DepTestRslt d) where + mempty = DepOk + mappend DepOk x = x + mappend x DepOk = x + mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d') + + +data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree + + +-- | Try to find a flag assignment that satisfies the constaints of all trees. +-- +-- Returns either the missing dependencies, or a tuple containing the +-- resulting data, the associated dependencies, and the chosen flag +-- assignments. +-- +-- In case of failure, the _smallest_ number of of missing dependencies is +-- returned. [TODO: Could also be specified with a function argument.] +-- +-- TODO: The current algorithm is rather naive. A better approach would be to: +-- +-- * Rule out possible paths, by taking a look at the associated dependencies. +-- +-- * Infer the required values for the conditions of these paths, and +-- calculate the required domains for the variables used in these +-- conditions. Then picking a flag assignment would be linear (I guess). +-- +-- This would require some sort of SAT solving, though, thus it's not +-- implemented unless we really need it. +-- +resolveWithFlags :: + [(FlagName,[Bool])] + -- ^ 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 + -> [Dependency] -- ^ Additional constraints + -> [CondTree ConfVar [Dependency] PDTagged] + -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function. + -> Either [Dependency] (TargetSet PDTagged, FlagAssignment) + -- ^ Either the missing dependencies (error case), or a pair of + -- (set of build targets with dependencies, chosen flag assignments) +resolveWithFlags dom os arch impl constrs trees checkDeps = + case try dom [] of + Right r -> Right r + Left dbt -> Left $ findShortest dbt + where + extraConstrs = toDepMap constrs + + -- simplify trees by (partially) evaluating all conditions and converting + -- dependencies to dependency maps. + simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps + . mapTreeConds (fst . simplifyWithSysParams os arch impl)) + trees + + -- @try@ recursively tries all possible flag assignments in the domain and + -- either succeeds or returns a binary tree with the missing dependencies + -- encountered in each run. Since the tree is constructed lazily, we + -- avoid some computation overhead in the successful case. + try [] flags = + let targetSet = TargetSet $ flip map simplifiedTrees $ + -- apply additional constraints to all dependencies + first (`constrainBy` extraConstrs) . + simplifyCondTree (env flags) + deps = overallDependencies targetSet + in case checkDeps (fromDepMap deps) of + DepOk -> Right (targetSet, flags) + MissingDeps mds -> Left (BTN mds) + + try ((n, vals):rest) flags = + tryAll $ map (\v -> try rest ((n, v):flags)) vals + + tryAll = foldr mp mz + + -- special version of `mplus' for our local purposes + mp (Left xs) (Left ys) = (Left (BTB xs ys)) + mp (Left _) m@(Right _) = m + mp m@(Right _) _ = m + + -- `mzero' + mz = Left (BTN []) + + env flags flag = (maybe (Left flag) Right . lookup flag) flags + + -- for the error case we inspect our lazy tree of missing dependencies and + -- pick the shortest list of missing dependencies + findShortest (BTN x) = x + findShortest (BTB lt rt) = + let l = findShortest lt + r = findShortest rt + in case (l,r) of + ([], xs) -> xs -- [] is too short + (xs, []) -> xs + ([x], _) -> [x] -- single elem is optimum + (_, [x]) -> [x] + (xs, ys) -> if lazyLengthCmp xs ys + then xs else ys + -- lazy variant of @\xs ys -> length xs <= length ys@ + lazyLengthCmp [] _ = True + lazyLengthCmp _ [] = False + lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys + +-- | A map of dependencies. Newtyped since the default monoid instance is not +-- appropriate. The monoid instance uses 'intersectVersionRanges'. +newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName VersionRange } +#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606) + deriving (Show, Read) +#else +-- The Show/Read instance for Data.Map in ghc-6.4 is useless +-- so we have to re-implement it here: +instance Show DependencyMap where + showsPrec d (DependencyMap m) = + showParen (d > 10) (showString "DependencyMap" . shows (M.toList m)) + +instance Read DependencyMap where + readPrec = parens $ R.prec 10 $ do + R.Ident "DependencyMap" <- R.lexP + xs <- R.readPrec + return (DependencyMap (M.fromList xs)) + where parens :: R.ReadPrec a -> R.ReadPrec a + parens p = optional + where + optional = p R.+++ mandatory + mandatory = paren optional + + paren :: R.ReadPrec a -> R.ReadPrec a + paren p = do L.Punc "(" <- R.lexP + x <- R.reset p + L.Punc ")" <- R.lexP + return x + + readListPrec = R.readListPrecDefault +#endif + +instance Monoid DependencyMap where + mempty = DependencyMap Map.empty + (DependencyMap a) `mappend` (DependencyMap b) = + DependencyMap (Map.unionWith intersectVersionRanges a b) + +toDepMap :: [Dependency] -> DependencyMap +toDepMap ds = + DependencyMap $ fromListWith intersectVersionRanges [ (p,vr) | Dependency p vr <- ds ] + +fromDepMap :: DependencyMap -> [Dependency] +fromDepMap m = [ Dependency p vr | (p,vr) <- toList (unDependencyMap m) ] + +simplifyCondTree :: (Monoid a, Monoid d) => + (v -> Either v Bool) + -> CondTree v d a + -> (d, a) +simplifyCondTree env (CondNode a d ifs) = + foldr mappend (d, a) $ catMaybes $ map simplifyIf ifs + where + simplifyIf (cnd, t, me) = + case simplifyCondition cnd env of + (Lit True, _) -> Just $ simplifyCondTree env t + (Lit False, _) -> fmap (simplifyCondTree env) me + _ -> error $ "Environment not defined for all free vars" + +-- | Flatten a CondTree. This will resolve the CondTree by taking all +-- possible paths into account. Note that since branches represent exclusive +-- choices this may not result in a \"sane\" result. +ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c) +ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs) + where f (_, t, me) = ignoreConditions t + : maybeToList (fmap ignoreConditions me) + +freeVars :: CondTree ConfVar c a -> [FlagName] +freeVars t = [ f | Flag f <- freeVars' t ] + where + freeVars' (CondNode _ _ ifs) = concatMap compfv ifs + compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct + condfv c = case c of + Var v -> [v] + Lit _ -> [] + CNot c' -> condfv c' + COr c1 c2 -> condfv c1 ++ condfv c2 + CAnd c1 c2 -> condfv c1 ++ condfv c2 + + +------------------------------------------------------------------------------ + +-- | A set of targets with their package dependencies +newtype TargetSet a = TargetSet [(DependencyMap, a)] + +-- | Combine the target-specific dependencies in a TargetSet to give the +-- dependencies for the package as a whole. +overallDependencies :: TargetSet PDTagged -> DependencyMap +overallDependencies (TargetSet targets) = mconcat depss + where + (depss, _) = unzip $ filter (removeDisabledSections . snd) targets + removeDisabledSections :: PDTagged -> Bool + removeDisabledSections (Lib _) = True + removeDisabledSections (Exe _ _) = True + removeDisabledSections (Test _ t) = testEnabled t + removeDisabledSections (Bench _ b) = benchmarkEnabled b + removeDisabledSections PDNull = True + +-- Apply extra constraints to a dependency map. +-- Combines dependencies where the result will only contain keys from the left +-- (first) map. If a key also exists in the right map, both constraints will +-- be intersected. +constrainBy :: DependencyMap -- ^ Input map + -> DependencyMap -- ^ Extra constraints + -> DependencyMap +constrainBy left extra = + DependencyMap $ + Map.foldWithKey tightenConstraint (unDependencyMap left) + (unDependencyMap extra) + where tightenConstraint n c l = + case Map.lookup n l of + Nothing -> l + Just vr -> Map.insert n (intersectVersionRanges vr c) l + +-- | Collect up the targets in a TargetSet of tagged targets, storing the +-- dependencies as we go. +flattenTaggedTargets :: TargetSet PDTagged -> + (Maybe Library, [(String, Executable)], [(String, TestSuite)] + , [(String, Benchmark)]) +flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], []) targets + where + untag (_, Lib _) (Just _, _, _, _) = bug "Only one library expected" + untag (deps, Lib l) (Nothing, exes, tests, bms) = + (Just l', exes, tests, bms) + where + l' = l { + libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps } + } + untag (deps, Exe n e) (mlib, exes, tests, bms) + | any ((== n) . fst) exes = bug "Exe with same name found" + | any ((== n) . fst) tests = bug "Test sharing name of exe found" + | any ((== n) . fst) bms = bug "Benchmark sharing name of exe found" + | otherwise = (mlib, exes ++ [(n, e')], tests, bms) + where + e' = e { + buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps } + } + untag (deps, Test n t) (mlib, exes, tests, bms) + | any ((== n) . fst) tests = bug "Test with same name found" + | any ((== n) . fst) exes = bug "Test sharing name of exe found" + | any ((== n) . fst) bms = bug "Test sharing name of benchmark found" + | otherwise = (mlib, exes, tests ++ [(n, t')], bms) + where + t' = t { + testBuildInfo = (testBuildInfo t) + { targetBuildDepends = fromDepMap deps } + } + untag (deps, Bench n b) (mlib, exes, tests, bms) + | any ((== n) . fst) bms = bug "Benchmark with same name found" + | any ((== n) . fst) exes = bug "Benchmark sharing name of exe found" + | any ((== n) . fst) tests = bug "Benchmark sharing name of test found" + | otherwise = (mlib, exes, tests, bms ++ [(n, b')]) + where + b' = b { + benchmarkBuildInfo = (benchmarkBuildInfo b) + { targetBuildDepends = fromDepMap deps } + } + untag (_, PDNull) x = x -- actually this should not happen, but let's be liberal + + +------------------------------------------------------------------------------ +-- Convert GenericPackageDescription to PackageDescription +-- + +data PDTagged = Lib Library + | Exe String Executable + | Test String TestSuite + | Bench String Benchmark + | PDNull + deriving Show + +instance Monoid PDTagged where + mempty = PDNull + PDNull `mappend` x = x + x `mappend` PDNull = x + Lib l `mappend` Lib l' = Lib (l `mappend` l') + Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e') + Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t') + Bench n b `mappend` Bench n' b' | n == n' = Bench n (b `mappend` b') + _ `mappend` _ = bug "Cannot combine incompatible tags" + +-- | Create a package description with all configurations resolved. +-- +-- This function takes a `GenericPackageDescription` and several environment +-- parameters and tries to generate `PackageDescription` by finding a flag +-- assignment that result in satisfiable dependencies. +-- +-- It takes as inputs a not necessarily complete specifications of flags +-- assignments, an optional package index as well as platform parameters. If +-- some flags are not assigned explicitly, this function will try to pick an +-- assignment that causes this function to succeed. The package index is +-- optional since on some platforms we cannot determine which packages have +-- been installed before. When no package index is supplied, every dependency +-- is assumed to be satisfiable, therefore all not explicitly assigned flags +-- will get their default values. +-- +-- This function will fail if it cannot find a flag assignment that leads to +-- satisfiable dependencies. (It will not try alternative assignments for +-- explicitly specified flags.) In case of failure it will return a /minimum/ +-- number of dependencies that could not be satisfied. On success, it will +-- return the package description and the full flag assignment chosen. +-- +finalizePackageDescription :: + FlagAssignment -- ^ Explicitly specified flag assignments + -> (Dependency -> Bool) -- ^ Is a given depenency satisfiable from the set of available packages? + -- If this is unknown then use True. + -> Platform -- ^ The 'Arch' and 'OS' + -> CompilerId -- ^ Compiler + Version + -> [Dependency] -- ^ Additional constraints + -> GenericPackageDescription + -> Either [Dependency] + (PackageDescription, FlagAssignment) + -- ^ Either missing dependencies or the resolved package + -- description along with the flag assignments chosen. +finalizePackageDescription userflags satisfyDep (Platform arch os) impl constraints + (GenericPackageDescription pkg flags mlib0 exes0 tests0 bms0) = + case resolveFlags of + Right ((mlib, exes', tests', bms'), targetSet, flagVals) -> + Right ( pkg { library = mlib + , executables = exes' + , testSuites = tests' + , benchmarks = bms' + , buildDepends = fromDepMap (overallDependencies targetSet) + --TODO: we need to find a way to avoid pulling in deps + -- for non-buildable components. However cannot simply + -- filter at this stage, since if the package were not + -- available we would have failed already. + } + , flagVals ) + + Left missing -> Left missing + where + -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data + condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 ) + ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0 + ++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0 + ++ map (\(name,tree) -> mapTreeData (Bench name) tree) bms0 + + resolveFlags = + case resolveWithFlags flagChoices os arch impl constraints condTrees check of + Right (targetSet, fs) -> + let (mlib, exes, tests, bms) = flattenTaggedTargets targetSet in + Right ( (fmap libFillInDefaults mlib, + map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes, + map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests, + map (\(n,b) -> (benchFillInDefaults b) { benchmarkName = n }) bms), + targetSet, fs) + Left missing -> Left missing + + flagChoices = map (\(MkFlag n _ d manual) -> (n, d2c manual n d)) flags + d2c manual n b = case lookup n userflags of + Just val -> [val] + Nothing + | manual -> [b] + | otherwise -> [b, not b] + --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices + check ds = if all satisfyDep ds + then DepOk + else MissingDeps $ filter (not . satisfyDep) ds + +{- +let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] []) +let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] []) + +let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])] +let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index +let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds +resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks ===> Right ... +resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks ===> Left ... +-} + +-- | Flatten a generic package description by ignoring all conditions and just +-- join the field descriptors into on package description. Note, however, +-- that this may lead to inconsistent field values, since all values are +-- joined into one field, which may not be possible in the original package +-- description, due to the use of exclusive choices (if ... else ...). +-- +-- TODO: One particularly tricky case is defaulting. In the original package +-- description, e.g., the source directory might either be the default or a +-- certain, explicitly set path. Since defaults are filled in only after the +-- package has been resolved and when no explicit value has been set, the +-- default path will be missing from the package description returned by this +-- function. +flattenPackageDescription :: GenericPackageDescription -> PackageDescription +flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0 bms0) = + pkg { library = mlib + , executables = reverse exes + , testSuites = reverse tests + , benchmarks = reverse bms + , buildDepends = ldeps ++ reverse edeps ++ reverse tdeps ++ reverse bdeps + } + where + (mlib, ldeps) = case mlib0 of + Just lib -> let (l,ds) = ignoreConditions lib in + (Just (libFillInDefaults l), ds) + Nothing -> (Nothing, []) + (exes, edeps) = foldr flattenExe ([],[]) exes0 + (tests, tdeps) = foldr flattenTst ([],[]) tests0 + (bms, bdeps) = foldr flattenBm ([],[]) bms0 + flattenExe (n, t) (es, ds) = + let (e, ds') = ignoreConditions t in + ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds ) + flattenTst (n, t) (es, ds) = + let (e, ds') = ignoreConditions t in + ( (testFillInDefaults $ e { testName = n }) : es, ds' ++ ds ) + flattenBm (n, t) (es, ds) = + let (e, ds') = ignoreConditions t in + ( (benchFillInDefaults $ e { benchmarkName = n }) : es, ds' ++ ds ) + +-- This is in fact rather a hack. The original version just overrode the +-- default values, however, when adding conditions we had to switch to a +-- modifier-based approach. There, nothing is ever overwritten, but only +-- joined together. +-- +-- This is the cleanest way i could think of, that doesn't require +-- changing all field parsing functions to return modifiers instead. +libFillInDefaults :: Library -> Library +libFillInDefaults lib@(Library { libBuildInfo = bi }) = + lib { libBuildInfo = biFillInDefaults bi } + +exeFillInDefaults :: Executable -> Executable +exeFillInDefaults exe@(Executable { buildInfo = bi }) = + exe { buildInfo = biFillInDefaults bi } + +testFillInDefaults :: TestSuite -> TestSuite +testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) = + tst { testBuildInfo = biFillInDefaults bi } + +benchFillInDefaults :: Benchmark -> Benchmark +benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) = + bm { benchmarkBuildInfo = biFillInDefaults bi } + +biFillInDefaults :: BuildInfo -> BuildInfo +biFillInDefaults bi = + if null (hsSourceDirs bi) + then bi { hsSourceDirs = [currentDir] } + else bi + +bug :: String -> a +bug msg = error $ msg ++ ". Consider this a bug." diff --git a/cabal/Cabal/Distribution/PackageDescription/Parse.hs b/cabal/Cabal/Distribution/PackageDescription/Parse.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/PackageDescription/Parse.hs @@ -0,0 +1,1205 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Parse +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defined parsers and partial pretty printers for the @.cabal@ format. +-- Some of the complexity in this module is due to the fact that we have to be +-- 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, + writePackageDescription, + parsePackageDescription, + showPackageDescription, + + -- ** Parsing + ParseResult(..), + FieldDescr(..), + LineNo, + + -- ** Supplementary build information + readHookedBuildInfo, + parseHookedBuildInfo, + writeHookedBuildInfo, + showHookedBuildInfo, + + pkgDescrFieldDescrs, + libFieldDescrs, + executableFieldDescrs, + binfoFieldDescrs, + sourceRepoFieldDescrs, + testSuiteFieldDescrs, + flagFieldDescrs + ) where + +import Data.Char (isSpace) +import Data.Maybe (listToMaybe, isJust) +import Data.Monoid ( Monoid(..) ) +import Data.List (nub, unfoldr, partition, (\\)) +import Control.Monad (liftM, foldM, when, unless) +import System.Directory (doesFileExist) +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 + +import Distribution.Text + ( Text(disp, parse), display, simpleParse ) +import Distribution.Compat.ReadP + ((+++), option) +import Text.PrettyPrint + +import Distribution.ParseUtils hiding (parseFields) +import Distribution.PackageDescription +import Distribution.Package + ( PackageIdentifier(..), Dependency(..), packageName, packageVersion ) +import Distribution.ModuleName ( ModuleName ) +import Distribution.Version + ( Version(Version), orLaterVersion + , LowerBound(..), asVersionIntervals ) +import Distribution.Verbosity (Verbosity) +import Distribution.Compiler (CompilerFlavor(..)) +import Distribution.PackageDescription.Configuration (parseCondition, freeVars) +import Distribution.Simple.Utils + ( die, dieWithLocation, warn, intercalate, lowercase, cabalVersion + , withFileContents, withUTF8FileContents + , writeFileAtomic, writeUTF8File ) + + +-- ----------------------------------------------------------------------------- +-- The PackageDescription type + +pkgDescrFieldDescrs :: [FieldDescr PackageDescription] +pkgDescrFieldDescrs = + [ simpleField "name" + disp parse + packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}}) + , simpleField "version" + disp parse + packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) + , simpleField "cabal-version" + (either disp disp) (liftM Left parse +++ liftM Right parse) + specVersionRaw (\v pkg -> pkg{specVersionRaw=v}) + , simpleField "build-type" + (maybe empty disp) (fmap Just parse) + buildType (\t pkg -> pkg{buildType=t}) + , simpleField "license" + disp parseLicenseQ + license (\l pkg -> pkg{license=l}) + , simpleField "license-file" + showFilePath parseFilePathQ + licenseFile (\l pkg -> pkg{licenseFile=l}) + , 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}) + , simpleField "homepage" + showFreeText parseFreeText + homepage (\val pkg -> pkg{homepage=val}) + , simpleField "package-url" + showFreeText parseFreeText + pkgUrl (\val pkg -> pkg{pkgUrl=val}) + , simpleField "bug-reports" + showFreeText parseFreeText + bugReports (\val pkg -> pkg{bugReports=val}) + , simpleField "synopsis" + showFreeText parseFreeText + synopsis (\val pkg -> pkg{synopsis=val}) + , simpleField "description" + showFreeText parseFreeText + description (\val pkg -> pkg{description=val}) + , simpleField "category" + showFreeText parseFreeText + category (\val pkg -> pkg{category=val}) + , simpleField "author" + showFreeText parseFreeText + author (\val pkg -> pkg{author=val}) + , listField "tested-with" + showTestedWith parseTestedWithQ + testedWith (\val pkg -> pkg{testedWith=val}) + , listField "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" + showFilePath parseFilePathQ + extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val}) + , listField "extra-tmp-files" + showFilePath parseFilePathQ + extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val}) + ] + +-- | Store any fields beginning with "x-" in the customFields field of +-- a PackageDescription. All other fields will generate a warning. +storeXFieldsPD :: UnrecFieldParser PackageDescription +storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD = + (customFieldsPD pkg) ++ [(f,val)]} +storeXFieldsPD _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The Library type + +libFieldDescrs :: [FieldDescr Library] +libFieldDescrs = + [ listField "exposed-modules" disp parseModuleNameQ + exposedModules (\mods lib -> lib{exposedModules=mods}) + + , boolField "exposed" + libExposed (\val lib -> lib{libExposed=val}) + ] ++ map biToLib binfoFieldDescrs + where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi}) + +storeXFieldsLib :: UnrecFieldParser Library +storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) = + Just $ l {libBuildInfo = bi{ customFieldsBI = (customFieldsBI bi) ++ [(f,val)]}} +storeXFieldsLib _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The Executable type + + +executableFieldDescrs :: [FieldDescr Executable] +executableFieldDescrs = + [ -- note ordering: configuration must come first, for + -- showPackageDescription. + simpleField "executable" + showToken parseTokenQ + exeName (\xs exe -> exe{exeName=xs}) + , simpleField "main-is" + showFilePath parseFilePathQ + modulePath (\xs exe -> exe{modulePath=xs}) + ] + ++ map biToExe binfoFieldDescrs + where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi}) + +storeXFieldsExe :: UnrecFieldParser Executable +storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) = + Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}} +storeXFieldsExe _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The TestSuite type + +-- | An intermediate type just used for parsing the test-suite stanza. +-- After validation it is converted into the proper 'TestSuite' type. +data TestSuiteStanza = TestSuiteStanza { + testStanzaTestType :: Maybe TestType, + testStanzaMainIs :: Maybe FilePath, + testStanzaTestModule :: Maybe ModuleName, + testStanzaBuildInfo :: BuildInfo + } + +emptyTestStanza :: TestSuiteStanza +emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty + +testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza] +testSuiteFieldDescrs = + [ simpleField "type" + (maybe empty disp) (fmap Just parse) + testStanzaTestType (\x suite -> suite { testStanzaTestType = x }) + , simpleField "main-is" + (maybe empty showFilePath) (fmap Just parseFilePathQ) + testStanzaMainIs (\x suite -> suite { testStanzaMainIs = x }) + , simpleField "test-module" + (maybe empty disp) (fmap Just parseModuleNameQ) + testStanzaTestModule (\x suite -> suite { testStanzaTestModule = x }) + ] + ++ map biToTest binfoFieldDescrs + where + biToTest = liftField testStanzaBuildInfo + (\bi suite -> suite { testStanzaBuildInfo = bi }) + +storeXFieldsTest :: UnrecFieldParser TestSuiteStanza +storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) = + Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}} +storeXFieldsTest _ _ = Nothing + +validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite +validateTestSuite line stanza = + case testStanzaTestType stanza of + Nothing -> return $ + emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza } + + Just tt@(TestTypeUnknown _ _) -> + return emptyTestSuite { + testInterface = TestSuiteUnsupported tt, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt | tt `notElem` knownTestTypes -> + return emptyTestSuite { + testInterface = TestSuiteUnsupported tt, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt@(TestTypeExe ver) -> + case testStanzaMainIs stanza of + Nothing -> syntaxError line (missingField "main-is" tt) + Just file -> do + when (isJust (testStanzaTestModule stanza)) $ + warning (extraField "test-module" tt) + return emptyTestSuite { + testInterface = TestSuiteExeV10 ver file, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt@(TestTypeLib ver) -> + case testStanzaTestModule stanza of + Nothing -> syntaxError line (missingField "test-module" tt) + Just module_ -> do + when (isJust (testStanzaMainIs stanza)) $ + warning (extraField "main-is" tt) + return emptyTestSuite { + testInterface = TestSuiteLibV09 ver module_, + testBuildInfo = testStanzaBuildInfo stanza + } + + where + missingField name tt = "The '" ++ name ++ "' field is required for the " + ++ display tt ++ " test suite type." + + extraField name tt = "The '" ++ name ++ "' field is not used for the '" + ++ display tt ++ "' test suite type." + + +-- --------------------------------------------------------------------------- +-- The Benchmark type + +-- | An intermediate type just used for parsing the benchmark stanza. +-- After validation it is converted into the proper 'Benchmark' type. +data BenchmarkStanza = BenchmarkStanza { + benchmarkStanzaBenchmarkType :: Maybe BenchmarkType, + benchmarkStanzaMainIs :: Maybe FilePath, + benchmarkStanzaBenchmarkModule :: Maybe ModuleName, + benchmarkStanzaBuildInfo :: BuildInfo + } + +emptyBenchmarkStanza :: BenchmarkStanza +emptyBenchmarkStanza = BenchmarkStanza Nothing Nothing Nothing mempty + +benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza] +benchmarkFieldDescrs = + [ simpleField "type" + (maybe empty disp) (fmap Just parse) + benchmarkStanzaBenchmarkType + (\x suite -> suite { benchmarkStanzaBenchmarkType = x }) + , simpleField "main-is" + (maybe empty showFilePath) (fmap Just parseFilePathQ) + benchmarkStanzaMainIs + (\x suite -> suite { benchmarkStanzaMainIs = x }) + ] + ++ map biToBenchmark binfoFieldDescrs + where + biToBenchmark = liftField benchmarkStanzaBuildInfo + (\bi suite -> suite { benchmarkStanzaBuildInfo = bi }) + +storeXFieldsBenchmark :: UnrecFieldParser BenchmarkStanza +storeXFieldsBenchmark (f@('x':'-':_), val) + t@(BenchmarkStanza { benchmarkStanzaBuildInfo = bi }) = + Just $ t {benchmarkStanzaBuildInfo = + bi{ customFieldsBI = (f,val):(customFieldsBI bi)}} +storeXFieldsBenchmark _ _ = Nothing + +validateBenchmark :: LineNo -> BenchmarkStanza -> ParseResult Benchmark +validateBenchmark line stanza = + case benchmarkStanzaBenchmarkType stanza of + Nothing -> return $ + emptyBenchmark { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza } + + Just tt@(BenchmarkTypeUnknown _ _) -> + return emptyBenchmark { + benchmarkInterface = BenchmarkUnsupported tt, + benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza + } + + Just tt | tt `notElem` knownBenchmarkTypes -> + return emptyBenchmark { + benchmarkInterface = BenchmarkUnsupported tt, + benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza + } + + Just tt@(BenchmarkTypeExe ver) -> + case benchmarkStanzaMainIs stanza of + Nothing -> syntaxError line (missingField "main-is" tt) + Just file -> do + when (isJust (benchmarkStanzaBenchmarkModule stanza)) $ + warning (extraField "benchmark-module" tt) + return emptyBenchmark { + benchmarkInterface = BenchmarkExeV10 ver file, + benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza + } + + where + missingField name tt = "The '" ++ name ++ "' field is required for the " + ++ display tt ++ " benchmark type." + + extraField name tt = "The '" ++ name ++ "' field is not used for the '" + ++ display tt ++ "' benchmark type." + +-- --------------------------------------------------------------------------- +-- The BuildInfo type + + +binfoFieldDescrs :: [FieldDescr BuildInfo] +binfoFieldDescrs = + [ boolField "buildable" + buildable (\val binfo -> binfo{buildable=val}) + , commaListField "build-tools" + disp parseBuildTool + buildTools (\xs binfo -> binfo{buildTools=xs}) + , spaceListField "cpp-options" + showToken parseTokenQ' + cppOptions (\val binfo -> binfo{cppOptions=val}) + , spaceListField "cc-options" + showToken parseTokenQ' + ccOptions (\val binfo -> binfo{ccOptions=val}) + , spaceListField "ld-options" + showToken parseTokenQ' + ldOptions (\val binfo -> binfo{ldOptions=val}) + , commaListField "pkgconfig-depends" + disp parsePkgconfigDependency + pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs}) + , listField "frameworks" + showToken parseTokenQ + frameworks (\val binfo -> binfo{frameworks=val}) + , listField "c-sources" + showFilePath parseFilePathQ + cSources (\paths binfo -> binfo{cSources=paths}) + + , simpleField "default-language" + (maybe empty disp) (option Nothing (fmap Just parseLanguageQ)) + defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang}) + , listField "other-languages" + disp parseLanguageQ + otherLanguages (\langs binfo -> binfo{otherLanguages=langs}) + , listField "default-extensions" + disp parseExtensionQ + defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts}) + , listField "other-extensions" + disp parseExtensionQ + otherExtensions (\exts binfo -> binfo{otherExtensions=exts}) + , listField "extensions" + disp parseExtensionQ + oldExtensions (\exts binfo -> binfo{oldExtensions=exts}) + + , listField "extra-libraries" + showToken parseTokenQ + extraLibs (\xs binfo -> binfo{extraLibs=xs}) + , listField "extra-lib-dirs" + showFilePath parseFilePathQ + extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs}) + , listField "includes" + showFilePath parseFilePathQ + includes (\paths binfo -> binfo{includes=paths}) + , listField "install-includes" + showFilePath parseFilePathQ + installIncludes (\paths binfo -> binfo{installIncludes=paths}) + , listField "include-dirs" + showFilePath parseFilePathQ + includeDirs (\paths binfo -> binfo{includeDirs=paths}) + , listField "hs-source-dirs" + showFilePath parseFilePathQ + hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths}) + , listField "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-options" GHC + options (\path binfo -> binfo{options=path}) + , optsField "hugs-options" Hugs + options (\path binfo -> binfo{options=path}) + , optsField "nhc98-options" NHC + options (\path binfo -> binfo{options=path}) + , optsField "jhc-options" JHC + options (\path binfo -> binfo{options=path}) + ] + +storeXFieldsBI :: UnrecFieldParser BuildInfo +storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) } +storeXFieldsBI _ _ = Nothing + +------------------------------------------------------------------------------ + +flagFieldDescrs :: [FieldDescr Flag] +flagFieldDescrs = + [ simpleField "description" + showFreeText parseFreeText + flagDescription (\val fl -> fl{ flagDescription = val }) + , boolField "default" + flagDefault (\val fl -> fl{ flagDefault = val }) + , boolField "manual" + flagManual (\val fl -> fl{ flagManual = val }) + ] + +------------------------------------------------------------------------------ + +sourceRepoFieldDescrs :: [FieldDescr SourceRepo] +sourceRepoFieldDescrs = + [ simpleField "type" + (maybe empty disp) (fmap Just parse) + repoType (\val repo -> repo { repoType = val }) + , simpleField "location" + (maybe empty showFreeText) (fmap Just parseFreeText) + repoLocation (\val repo -> repo { repoLocation = val }) + , simpleField "module" + (maybe empty showToken) (fmap Just parseTokenQ) + repoModule (\val repo -> repo { repoModule = val }) + , simpleField "branch" + (maybe empty showToken) (fmap Just parseTokenQ) + repoBranch (\val repo -> repo { repoBranch = val }) + , simpleField "tag" + (maybe empty showToken) (fmap Just parseTokenQ) + repoTag (\val repo -> repo { repoTag = val }) + , simpleField "subdir" + (maybe empty showFilePath) (fmap Just parseFilePathQ) + repoSubdir (\val repo -> repo { repoSubdir = val }) + ] + +-- --------------------------------------------------------------- +-- Parsing + +-- | Given a parser and a filename, return the parse of the file, +-- after checking if the file exists. +readAndParseFile :: (FilePath -> (String -> IO a) -> IO a) + -> (String -> ParseResult a) + -> Verbosity + -> FilePath -> IO a +readAndParseFile withFileContents' parser verbosity fpath = do + exists <- doesFileExist fpath + when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.") + withFileContents' fpath $ \str -> case parser str of + ParseFailed e -> do + let (line, message) = locatedErrorMsg e + dieWithLocation fpath line message + ParseOk warnings x -> do + mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings + return x + +readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo +readHookedBuildInfo = + readAndParseFile withFileContents parseHookedBuildInfo + +-- |Parse the given package file. +readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription +readPackageDescription = + readAndParseFile withUTF8FileContents parsePackageDescription + +stanzas :: [Field] -> [[Field]] +stanzas [] = [] +stanzas (f:fields) = (f:this) : stanzas rest + where + (this, rest) = break isStanzaHeader fields + +isStanzaHeader :: Field -> Bool +isStanzaHeader (F _ f _) = f == "executable" +isStanzaHeader _ = False + +------------------------------------------------------------------------------ + + +mapSimpleFields :: (Field -> ParseResult Field) -> [Field] + -> ParseResult [Field] +mapSimpleFields f fs = mapM walk fs + where + walk fld@(F _ _ _) = f fld + walk (IfBlock l c fs1 fs2) = do + fs1' <- mapM walk fs1 + fs2' <- mapM walk fs2 + return (IfBlock l c fs1' fs2') + walk (Section ln n l fs1) = do + fs1' <- mapM walk fs1 + return (Section ln n l fs1') + +-- prop_isMapM fs = mapSimpleFields return fs == return fs + + +-- names of fields that represents dependencies, thus consrca +constraintFieldNames :: [String] +constraintFieldNames = ["build-depends"] + +-- Possible refactoring would be to have modifiers be explicit about what +-- 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 (F l n v) + | n == "build-depends" = runP l n (parseCommaList parse) v +parseConstraint f = bug $ "Constraint was expected (got: " ++ show f ++ ")" + +{- +headerFieldNames :: [String] +headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames)) + . map fieldName $ pkgDescrFieldDescrs +-} + +libFieldNames :: [String] +libFieldNames = map fieldName libFieldDescrs + ++ buildInfoNames ++ constraintFieldNames + +-- exeFieldNames :: [String] +-- exeFieldNames = map fieldName executableFieldDescrs +-- ++ buildInfoNames + +buildInfoNames :: [String] +buildInfoNames = map fieldName binfoFieldDescrs + ++ map fst deprecatedFieldsBuildInfo + +-- A minimal implementation of the StateT monad transformer to avoid depending +-- on the 'mtl' package. +newtype StT s m a = StT { runStT :: s -> m (a,s) } + +instance Monad m => Monad (StT s m) where + return a = StT (\s -> return (a,s)) + StT f >>= g = StT $ \s -> do + (a,s') <- f s + runStT (g a) s' + +get :: Monad m => StT s m s +get = StT $ \s -> return (s, s) + +modify :: Monad m => (s -> s) -> StT s m () +modify f = StT $ \s -> return ((),f s) + +lift :: Monad m => m a -> StT s m a +lift m = StT $ \s -> m >>= \a -> return (a,s) + +evalStT :: Monad m => StT s m a -> s -> m a +evalStT st s = runStT st s >>= return . fst + +-- Our monad for parsing a list/tree of fields. +-- +-- The state represents the remaining fields to be processed. +type PM a = StT [Field] ParseResult a + + + +-- return look-ahead field or nothing if we're at the end of the file +peekField :: PM (Maybe Field) +peekField = get >>= return . listToMaybe + +-- Unconditionally discard the first field in our state. Will error when it +-- reaches end of file. (Yes, that's evil.) +skipField :: PM () +skipField = modify tail + +--FIXME: this should take a ByteString, not a String. We have to be able to +-- decode UTF8 and handle the BOM. + +-- | Parses the given file into a 'GenericPackageDescription'. +-- +-- In Cabal 1.2 the syntax for package descriptions was changed to a format +-- with sections and possibly indented property descriptions. +parsePackageDescription :: String -> ParseResult GenericPackageDescription +parsePackageDescription file = do + + -- This function is quite complex because it needs to be able to parse + -- both pre-Cabal-1.2 and post-Cabal-1.2 files. Additionally, it contains + -- a lot of parser-related noise since we do not want to depend on Parsec. + -- + -- If we detect an pre-1.2 file we implicitly convert it to post-1.2 + -- style. See 'sectionizeFields' below for details about the conversion. + + fields0 <- readFields file `catchParseError` \err -> + let tabs = findIndentTabs file in + case err of + -- In case of a TabsError report them all at once. + TabsError tabLineNo -> reportTabsError + -- but only report the ones including and following + -- the one that caused the actual error + [ t | t@(lineNo',_) <- tabs + , lineNo' >= tabLineNo ] + _ -> parseFail err + + let cabalVersionNeeded = + head $ [ minVersionBound versionRange + | Just versionRange <- [ simpleParse v + | F _ "cabal-version" v <- fields0 ] ] + ++ [Version [0] []] + minVersionBound versionRange = + case asVersionIntervals versionRange of + [] -> Version [0] [] + ((LowerBound version _, _):_) -> version + + handleFutureVersionParseFailure cabalVersionNeeded $ do + + let sf = sectionizeFields fields0 -- ensure 1.2 format + + -- figure out and warn about deprecated stuff (warnings are collected + -- inside our parsing monad) + fields <- mapSimpleFields deprecField sf + + -- Our parsing monad takes the not-yet-parsed fields as its state. + -- After each successful parse we remove the field from the state + -- ('skipField') and move on to the next one. + -- + -- Things are complicated a bit, because fields take a tree-like + -- structure -- they can be sections or "if"/"else" conditionals. + + flip evalStT fields $ do + + -- The header consists of all simple fields up to the first section + -- (flag, library, executable). + header_fields <- getHeader [] + + -- Parses just the header fields and stores them in a + -- 'PackageDescription'. Note that our final result is a + -- 'GenericPackageDescription'; for pragmatic reasons we just store + -- the partially filled-out 'PackageDescription' inside the + -- 'GenericPackageDescription'. + pkg <- lift $ parseFields pkgDescrFieldDescrs + storeXFieldsPD + emptyPackageDescription + header_fields + + -- 'getBody' assumes that the remaining fields only consist of + -- flags, lib and exe sections. + (repos, flags, 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 } + flags mlib exes tests bms + + where + oldSyntax flds = all isSimpleField flds + reportTabsError tabs = + syntaxError (fst (head tabs)) $ + "Do not use tabs for indentation (use spaces instead)\n" + ++ " Tabs were used at (line,column): " ++ show tabs + + maybeWarnCabalVersion newsyntax pkg + | newsyntax && specVersion pkg < Version [1,2] [] + = lift $ warning $ + "A package using section syntax must specify at least\n" + ++ "'cabal-version: >= 1.2'." + + maybeWarnCabalVersion newsyntax pkg + | not newsyntax && specVersion pkg >= Version [1,2] [] + = lift $ warning $ + "A package using 'cabal-version: " + ++ displaySpecVersion (specVersionRaw pkg) + ++ "' must use section syntax. See the Cabal user guide for details." + where + displaySpecVersion (Left version) = display version + displaySpecVersion (Right versionRange) = + case asVersionIntervals versionRange of + [] {- impossible -} -> display versionRange + ((LowerBound version _, _):_) -> display (orLaterVersion version) + + maybeWarnCabalVersion _ _ = return () + + + handleFutureVersionParseFailure cabalVersionNeeded parseBody = + (unless versionOk (warning message) >> parseBody) + `catchParseError` \parseError -> case parseError of + TabsError _ -> parseFail parseError + _ | versionOk -> parseFail parseError + | otherwise -> fail message + where versionOk = cabalVersionNeeded <= cabalVersion + message = "This package requires at least Cabal version " + ++ display cabalVersionNeeded + + -- "Sectionize" an old-style Cabal file. A sectionized file has: + -- + -- * all global fields at the beginning, followed by + -- + -- * all flag declarations, followed by + -- + -- * an optional library section, and an arbitrary number of executable + -- sections (in any order). + -- + -- The current implementatition just gathers all library-specific fields + -- in a library section and wraps all executable stanzas in an executable + -- section. + sectionizeFields :: [Field] -> [Field] + sectionizeFields fs + | oldSyntax fs = + let + -- "build-depends" is a local field now. To be backwards + -- compatible, we still allow it as a global field in old-style + -- package description files and translate it to a local field by + -- adding it to every non-empty section + (hdr0, exes0) = break ((=="executable") . fName) fs + (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0 + + (deps, libfs) = partition ((== "build-depends") . fName) + libfs0 + + exes = unfoldr toExe exes0 + toExe [] = Nothing + toExe (F l e n : r) + | e == "executable" = + let (efs, r') = break ((=="executable") . fName) r + in Just (Section l "executable" n (deps ++ efs), r') + toExe _ = bug "unexpeced input to 'toExe'" + in + hdr ++ + (if null libfs then [] + else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)]) + ++ exes + | otherwise = fs + + isSimpleField (F _ _ _) = True + isSimpleField _ = False + + -- warn if there's something at the end of the file + warnIfRest :: PM () + warnIfRest = do + s <- get + case s of + [] -> return () + _ -> lift $ warning "Ignoring trailing declarations." -- add line no. + + -- all simple fields at the beginning of the file are (considered) header + -- fields + getHeader :: [Field] -> PM [Field] + getHeader acc = peekField >>= \mf -> case mf of + Just f@(F _ _ _) -> skipField >> getHeader (f:acc) + _ -> return (reverse acc) + + -- + -- body ::= { repo | flag | library | executable | test }+ -- at most one lib + -- + -- 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 (CondTree ConfVar [Dependency] Library) + ,[(String, CondTree ConfVar [Dependency] Executable)] + ,[(String, CondTree ConfVar [Dependency] TestSuite)] + ,[(String, CondTree ConfVar [Dependency] Benchmark)]) + getBody = peekField >>= \mf -> case mf of + Just (Section line_no sec_type sec_label sec_fields) + | sec_type == "executable" -> do + when (null sec_label) $ lift $ syntaxError line_no + "'executable' needs one argument (the executable's name)" + 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) + + | sec_type == "test-suite" -> do + when (null sec_label) $ lift $ syntaxError line_no + "'test-suite' needs one argument (the test suite's name)" + testname <- lift $ runP line_no "test" parseTokenQ sec_label + flds <- collectFields (parseTestFields line_no) sec_fields + + -- Check that a valid test suite type has been chosen. A type + -- field may be given inside a conditional block, so we must + -- check for that before complaining that a type field has not + -- been given. The test suite must always have a valid type, so + -- we need to check both the 'then' and 'else' blocks, though + -- the blocks need not have the same type. + let checkTestType ts ct = + let ts' = mappend ts $ condTreeData ct + -- If a conditional has only a 'then' block and no + -- 'else' block, then it cannot have a valid type + -- in every branch, unless the type is specified at + -- a higher level in the tree. + checkComponent (_, _, Nothing) = False + -- If a conditional has a 'then' block and an 'else' + -- block, both must specify a test type, unless the + -- type is specified higher in the tree. + checkComponent (_, t, Just e) = + checkTestType ts' t && checkTestType ts' e + -- Does the current node specify a test type? + hasTestType = testInterface ts' + /= testInterface emptyTestSuite + components = condTreeComponents ct + -- If the current level of the tree specifies a type, + -- then we are done. If not, then one of the conditional + -- branches below the current node must specify a type. + -- Each node may have multiple immediate children; we + -- only one need one to specify a type because the + -- configure step uses 'mappend' to join together the + -- results of flag resolution. + in hasTestType || (any checkComponent components) + if checkTestType emptyTestSuite flds + then do + skipField + (repos, flags, lib, exes, tests, bms) <- getBody + return (repos, flags, lib, exes, (testname, flds) : tests, bms) + else lift $ syntaxError line_no $ + "Test suite \"" ++ testname + ++ "\" is missing required field \"type\" or the field " + ++ "is not present in all conditional branches. The " + ++ "available test types are: " + ++ intercalate ", " (map display knownTestTypes) + + | sec_type == "benchmark" -> do + when (null sec_label) $ lift $ syntaxError line_no + "'benchmark' needs one argument (the benchmark's name)" + benchname <- lift $ runP line_no "benchmark" parseTokenQ sec_label + flds <- collectFields (parseBenchmarkFields line_no) sec_fields + + -- Check that a valid benchmark type has been chosen. A type + -- field may be given inside a conditional block, so we must + -- check for that before complaining that a type field has not + -- been given. The benchmark must always have a valid type, so + -- we need to check both the 'then' and 'else' blocks, though + -- the blocks need not have the same type. + let checkBenchmarkType ts ct = + let ts' = mappend ts $ condTreeData ct + -- If a conditional has only a 'then' block and no + -- 'else' block, then it cannot have a valid type + -- in every branch, unless the type is specified at + -- a higher level in the tree. + checkComponent (_, _, Nothing) = False + -- If a conditional has a 'then' block and an 'else' + -- block, both must specify a benchmark type, unless the + -- type is specified higher in the tree. + checkComponent (_, t, Just e) = + checkBenchmarkType ts' t && checkBenchmarkType ts' e + -- Does the current node specify a benchmark type? + hasBenchmarkType = benchmarkInterface ts' + /= benchmarkInterface emptyBenchmark + components = condTreeComponents ct + -- If the current level of the tree specifies a type, + -- then we are done. If not, then one of the conditional + -- branches below the current node must specify a type. + -- Each node may have multiple immediate children; we + -- only one need one to specify a type because the + -- configure step uses 'mappend' to join together the + -- results of flag resolution. + in hasBenchmarkType || (any checkComponent components) + if checkBenchmarkType emptyBenchmark flds + then do + skipField + (repos, flags, lib, exes, tests, bms) <- getBody + return (repos, flags, lib, exes, tests, (benchname, flds) : bms) + else lift $ syntaxError line_no $ + "Benchmark \"" ++ benchname + ++ "\" is missing required field \"type\" or the field " + ++ "is not present in all conditional branches. The " + ++ "available benchmark types are: " + ++ intercalate ", " (map display knownBenchmarkTypes) + + | sec_type == "library" -> do + when (not (null sec_label)) $ lift $ + syntaxError line_no "'library' expects no argument" + flds <- collectFields parseLibFields sec_fields + skipField + (repos, flags, 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) + + | sec_type == "flag" -> do + when (null sec_label) $ lift $ + syntaxError line_no "'flag' needs one argument (the flag's name)" + flag <- lift $ parseFields + flagFieldDescrs + warnUnrec + (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) + + | sec_type == "source-repository" -> do + when (null sec_label) $ lift $ syntaxError line_no $ + "'source-repository' needs one argument, " + ++ "the repo kind which is usually 'head' or 'this'" + kind <- case simpleParse sec_label of + Just kind -> return kind + Nothing -> lift $ syntaxError line_no $ + "could not parse repo kind: " ++ sec_label + repo <- lift $ parseFields + sourceRepoFieldDescrs + warnUnrec + (SourceRepo { + repoKind = kind, + repoType = Nothing, + repoLocation = Nothing, + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing + }) + sec_fields + skipField + (repos, flags, lib, exes, tests, bms) <- getBody + return (repo:repos, flags, lib, exes, tests, bms) + + | otherwise -> do + lift $ warning $ "Ignoring unknown section type: " ++ sec_type + skipField + getBody + Just f -> do + _ <- lift $ syntaxError (lineNo f) $ + "Construct not supported at this position: " ++ show f + skipField + getBody + Nothing -> return ([], [], Nothing, [], [], []) + + -- Extracts all fields in a block and returns a 'CondTree'. + -- + -- We have to recurse down into conditionals and we treat fields that + -- describe dependencies specially. + collectFields :: ([Field] -> PM a) -> [Field] + -> PM (CondTree ConfVar [Dependency] a) + collectFields parser allflds = do + + let simplFlds = [ F l n v | F l n v <- allflds ] + condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ] + + let (depFlds, dataFlds) = partition isConstraint simplFlds + + a <- parser dataFlds + deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds + + ifs <- mapM processIfs condFlds + + return (CondNode a deps ifs) + where + isConstraint (F _ n _) = n `elem` constraintFieldNames + isConstraint _ = False + + processIfs (IfBlock l c t e) = do + cnd <- lift $ runP l "if" parseCondition c + t' <- collectFields parser t + e' <- case e of + [] -> return Nothing + es -> do fs <- collectFields parser es + return (Just fs) + return (cnd, t', e') + processIfs _ = bug "processIfs called with wrong field type" + + parseLibFields :: [Field] -> PM Library + parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary + + -- Note: we don't parse the "executable" field here, hence the tail hack. + parseExeFields :: [Field] -> PM Executable + parseExeFields = lift . parseFields (tail executableFieldDescrs) storeXFieldsExe emptyExecutable + + parseTestFields :: LineNo -> [Field] -> PM TestSuite + parseTestFields line fields = do + x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest + emptyTestStanza fields + lift $ validateTestSuite line x + + parseBenchmarkFields :: LineNo -> [Field] -> PM Benchmark + parseBenchmarkFields line fields = do + x <- lift $ parseFields benchmarkFieldDescrs storeXFieldsBenchmark + emptyBenchmarkStanza fields + lift $ validateBenchmark line x + + checkForUndefinedFlags :: + [Flag] -> + Maybe (CondTree ConfVar [Dependency] Library) -> + [(String, CondTree ConfVar [Dependency] Executable)] -> + [(String, CondTree ConfVar [Dependency] TestSuite)] -> + PM () + checkForUndefinedFlags flags mlib exes tests = do + let definedFlags = map flagName flags + maybe (return ()) (checkCondTreeFlags definedFlags) mlib + mapM_ (checkCondTreeFlags definedFlags . snd) exes + mapM_ (checkCondTreeFlags definedFlags . snd) tests + + checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM () + checkCondTreeFlags definedFlags ct = do + let fv = nub $ freeVars ct + when (not . all (`elem` definedFlags) $ fv) $ + fail $ "These flags are used without having been defined: " + ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] + + +-- | Parse a list of fields, given a list of field descriptions, +-- a structure to accumulate the parsed fields, and a function +-- that can decide what to do with fields which don't match any +-- of the field descriptions. +parseFields :: [FieldDescr a] -- ^ descriptions of fields we know how to + -- parse + -> UnrecFieldParser a -- ^ possibly do something with + -- unrecognized fields + -> a -- ^ accumulator + -> [Field] -- ^ fields to be parsed + -> ParseResult a +parseFields descrs unrec ini fields = + do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields + when (not (null unknowns)) $ do + warning $ render $ + text "Unknown fields:" <+> + commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")") + (reverse unknowns)) + $+$ + text "Fields allowed in this section:" $$ + nest 4 (commaSep $ map fieldName descrs) + return a + where + commaSep = fsep . punctuate comma . map text + +parseField :: [FieldDescr a] -- ^ list of parseable fields + -> UnrecFieldParser a -- ^ possibly do something with + -- unrecognized fields + -> (a,[(Int,String)]) -- ^ accumulated result and warnings + -> Field -- ^ the field to be parsed + -> ParseResult (a, [(Int,String)]) +parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val) + | name == f = parser line val a >>= \a' -> return (a',us) + | otherwise = parseField fields unrec (a,us) (F line f val) +parseField [] unrec (a,us) (F l f val) = return $ + case unrec (f,val) a of -- no fields matched, see if the 'unrec' + Just a' -> (a',us) -- function wants to do anything with it + Nothing -> (a, ((l,f):us)) +parseField _ _ _ _ = bug "'parseField' called on a non-field" + +deprecatedFields :: [(String,String)] +deprecatedFields = + deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo + +deprecatedFieldsPkgDescr :: [(String,String)] +deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ] + +deprecatedFieldsBuildInfo :: [(String,String)] +deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ] + +-- Handle deprecated fields +deprecField :: Field -> ParseResult Field +deprecField (F line fld val) = do + fld' <- case lookup fld deprecatedFields of + Nothing -> return fld + Just newName -> do + warning $ "The field \"" ++ fld + ++ "\" is deprecated, please use \"" ++ newName ++ "\"" + return newName + return (F line fld' val) +deprecField _ = bug "'deprecField' called on a non-field" + + +parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo +parseHookedBuildInfo inp = do + fields <- readFields inp + let ss@(mLibFields:exes) = stanzas fields + mLib <- parseLib mLibFields + biExes <- mapM parseExe (maybe ss (const exes) mLib) + return (mLib, biExes) + where + parseLib :: [Field] -> ParseResult (Maybe BuildInfo) + parseLib (bi@((F _ inFieldName _):_)) + | lowercase inFieldName /= "executable" = liftM Just (parseBI bi) + parseLib _ = return Nothing + + parseExe :: [Field] -> ParseResult (String, BuildInfo) + parseExe ((F line inFieldName mName):bi) + | lowercase inFieldName == "executable" + = do bis <- parseBI bi + return (mName, bis) + | otherwise = syntaxError line "expecting 'executable' at top of stanza" + parseExe (_:_) = bug "`parseExe' called on a non-field" + parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza" + + parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st + +-- --------------------------------------------------------------------------- +-- Pretty printing + +writePackageDescription :: FilePath -> PackageDescription -> IO () +writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) + +--TODO: make this use section syntax +-- add equivalent for GenericPackageDescription +showPackageDescription :: PackageDescription -> String +showPackageDescription pkg = render $ + ppPackage pkg + $$ ppCustomFields (customFieldsPD pkg) + $$ (case library pkg of + Nothing -> empty + Just lib -> ppLibrary lib) + $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ] + where + ppPackage = ppFields pkgDescrFieldDescrs + ppLibrary = ppFields libFieldDescrs + ppExecutable = ppFields executableFieldDescrs + +ppCustomFields :: [(String,String)] -> Doc +ppCustomFields flds = vcat (map ppCustomField flds) + +ppCustomField :: (String,String) -> Doc +ppCustomField (name,val) = text name <> colon <+> showFreeText val + +writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () +writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack + . showHookedBuildInfo + +showHookedBuildInfo :: HookedBuildInfo -> String +showHookedBuildInfo (mb_lib_bi, ex_bis) = render $ + (case mb_lib_bi of + Nothing -> empty + Just bi -> ppBuildInfo bi) + $$ vcat [ space + $$ text "executable:" <+> text name + $$ ppBuildInfo bi + | (name, bi) <- ex_bis ] + where + ppBuildInfo bi = ppFields binfoFieldDescrs bi + $$ ppCustomFields (customFieldsBI bi) + +-- replace all tabs used as indentation with whitespace, also return where +-- tabs were found +findIndentTabs :: String -> [(Int,Int)] +findIndentTabs = concatMap checkLine + . zip [1..] + . lines + where + checkLine (lineno, l) = + let (indent, _content) = span isSpace l + tabCols = map fst . filter ((== '\t') . snd) . zip [0..] + addLineNo = map (\col -> (lineno,col)) + in addLineNo (tabCols indent) + +--test_findIndentTabs = findIndentTabs $ unlines $ +-- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ] + +bug :: String -> a +bug msg = error $ msg ++ ". Consider this a bug." diff --git a/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs b/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs @@ -0,0 +1,238 @@ +----------------------------------------------------------------------------- +-- +-- Module : Distribution.PackageDescription.PrettyPrint +-- Copyright : Jürgen Nicklisch-Franken 2010 +-- License : AllRightsReserved +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- | 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 + +import Distribution.PackageDescription + ( TestSuite(..), TestSuiteInterface(..), testType + , SourceRepo(..), + customFieldsBI, CondTree(..), Condition(..), + FlagName(..), ConfVar(..), Executable(..), Library(..), + Flag(..), PackageDescription(..), + GenericPackageDescription(..)) +import Text.PrettyPrint + (hsep, comma, punctuate, fsep, parens, char, nest, empty, + isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render) +import Distribution.Simple.Utils (writeUTF8File) +import Distribution.ParseUtils (showFreeText, FieldDescr(..)) +import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs, + sourceRepoFieldDescrs) +import Distribution.Package (Dependency(..)) +import Distribution.Text (Text(..)) +import Data.Maybe (isJust, fromJust, isNothing) + +indentWith :: Int +indentWith = 4 + +-- | Recompile with false for regression testing +simplifiedPrinting :: Bool +simplifiedPrinting = False + +-- | Writes a .cabal file from a generic package description +writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO () +writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg) + +-- | Writes a generic package description to a string +showGenericPackageDescription :: GenericPackageDescription -> String +showGenericPackageDescription = render . ppGenericPackageDescription + +ppGenericPackageDescription :: GenericPackageDescription -> Doc +ppGenericPackageDescription gpd = + ppPackageDescription (packageDescription gpd) + $+$ ppGenPackageFlags (genPackageFlags gpd) + $+$ ppLibrary (condLibrary gpd) + $+$ ppExecutables (condExecutables gpd) + $+$ ppTestSuites (condTestSuites gpd) + +ppPackageDescription :: PackageDescription -> Doc +ppPackageDescription pd = ppFields pkgDescrFieldDescrs pd + $+$ ppCustomFields (customFieldsPD pd) + $+$ ppSourceRepos (sourceRepos pd) + +ppSourceRepos :: [SourceRepo] -> Doc +ppSourceRepos [] = empty +ppSourceRepos (hd:tl) = ppSourceRepo hd $+$ ppSourceRepos tl + +ppSourceRepo :: SourceRepo -> Doc +ppSourceRepo repo = + emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$ + (nest indentWith (ppFields sourceRepoFieldDescrs' repo)) + 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] + +ppField :: String -> Doc -> Doc +ppField name fielddoc | isEmpty fielddoc = empty + | otherwise = text name <> colon <+> fielddoc + +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)] + +ppCustomFields :: [(String,String)] -> Doc +ppCustomFields flds = vcat [ppCustomField f | f <- flds] + +ppCustomField :: (String,String) -> Doc +ppCustomField (name,val) = text name <> colon <+> showFreeText val + +ppGenPackageFlags :: [Flag] -> Doc +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))) + +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 + $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) + ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib + $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) + +ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc +ppExecutables exes = + vcat [emptyLine $ text ("executable " ++ n) + $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes] + where + ppExe (Executable _ modulePath' buildInfo') Nothing = + (if modulePath' == "" then empty else text "main-is:" <+> text modulePath') + $+$ ppFields binfoFieldDescrs buildInfo' + $+$ ppCustomFields (customFieldsBI buildInfo') + ppExe (Executable _ modulePath' buildInfo') + (Just (Executable _ modulePath2 buildInfo2)) = + (if modulePath' == "" || modulePath' == modulePath2 + then empty else text "main-is:" <+> text modulePath') + $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 + $+$ ppCustomFields (customFieldsBI buildInfo') + +ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc +ppTestSuites suites = + emptyLine $ vcat [ text ("test-suite " ++ n) + $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite) + | (n,condTree) <- suites] + where + ppTestSuite testsuite Nothing = + text "type:" <+> disp (testType testsuite) + $+$ maybe empty (\f -> text "main-is:" <+> text f) + (testSuiteMainIs testsuite) + $+$ maybe empty (\m -> text "test-module:" <+> disp m) + (testSuiteModule testsuite) + $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite) + $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite)) + + ppTestSuite (TestSuite _ _ buildInfo' _) + (Just (TestSuite _ _ buildInfo2 _)) = + ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 + $+$ ppCustomFields (customFieldsBI buildInfo') + + testSuiteMainIs test = case testInterface test of + TestSuiteExeV10 _ f -> Just f + _ -> Nothing + + testSuiteModule test = case testInterface test of + TestSuiteLibV09 _ m -> Just m + _ -> Nothing + +ppCondition :: Condition ConfVar -> Doc +ppCondition (Var x) = ppConfVar x +ppCondition (Lit b) = text (show b) +ppCondition (CNot c) = char '!' <> (ppCondition c) +ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||" + <+> ppCondition c2]) +ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&" + <+> ppCondition c2]) +ppConfVar :: ConfVar -> Doc +ppConfVar (OS os) = text "os" <> parens (disp os) +ppConfVar (Arch arch) = text "arch" <> parens (disp arch) +ppConfVar (Flag name) = text "flag" <> parens (ppFlagName name) +ppConfVar (Impl c v) = text "impl" <> parens (disp c <+> disp v) + +ppFlagName :: FlagName -> Doc +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) + $+$ 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)) + +ppDeps :: [Dependency] -> Doc +ppDeps [] = empty +ppDeps deps = + text "build-depends:" <+> fsep (punctuate comma (map disp deps)) + +emptyLine :: Doc -> Doc +emptyLine d = text " " $+$ d + + + diff --git a/cabal/Cabal/Distribution/ParseUtils.hs b/cabal/Cabal/Distribution/ParseUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/ParseUtils.hs @@ -0,0 +1,715 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ParseUtils +-- Copyright : (c) The University of Glasgow 2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'. +-- +-- The @.cabal@ file format is not trivial, especially with the introduction +-- of configurations and the section syntax that goes with that. This module +-- has a bunch of parsing functions that is used by the @.cabal@ parser and a +-- couple others. It has the parsing framework code and also little parsers for +-- 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... + +-- #hide +module Distribution.ParseUtils ( + LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, + runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning, + Field(..), fName, lineNo, + FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat, + showFields, showSingleNamedField, parseFields, parseFieldsFlat, + parseFilePathQ, parseTokenQ, parseTokenQ', + parseModuleNameQ, parseBuildTool, parsePkgconfigDependency, + parseOptVersion, parsePackageNameQ, parseVersionRangeQ, + parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ, + parseSepList, parseCommaList, parseOptCommaList, + showFilePath, showToken, showTestedWith, showFreeText, parseFreeText, + field, simpleField, listField, spaceListField, commaListField, + optsField, liftField, boolField, parseQuoted, + + UnrecFieldParser, warnUnrec, ignoreUnrec, + ) where + +import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat) +import Distribution.License +import Distribution.Version + ( Version(..), VersionRange, anyVersion ) +import Distribution.Package ( PackageName(..), Dependency(..) ) +import Distribution.ModuleName (ModuleName) +import Distribution.Compat.ReadP as ReadP hiding (get) +import Distribution.ReadE +import Distribution.Text + ( Text(..) ) +import Distribution.Simple.Utils + ( comparing, intercalate, lowercase, normaliseLineEndings ) +import Language.Haskell.Extension + ( Language, Extension ) + +import Text.PrettyPrint hiding (braces) +import Data.Char (isSpace, toLower, isAlphaNum, isDigit) +import Data.Maybe (fromMaybe) +import Data.Tree as Tree (Tree(..), flatten) +import qualified Data.Map as Map +import Control.Monad (foldM) +import System.FilePath (normalise) +import Data.List (sortBy) + +-- ----------------------------------------------------------------------------- + +type LineNo = Int + +data PError = AmbigousParse String LineNo + | NoParse String LineNo + | TabsError LineNo + | FromString String (Maybe LineNo) + deriving Show + +data PWarning = PWarning String + | UTFWarning LineNo String + deriving Show + +showPWarning :: FilePath -> PWarning -> String +showPWarning fpath (PWarning msg) = + normalise fpath ++ ": " ++ msg +showPWarning fpath (UTFWarning line fname) = + normalise fpath ++ ":" ++ show line + ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field." + +data ParseResult a = ParseFailed PError | ParseOk [PWarning] a + deriving Show + +instance Monad ParseResult where + return x = ParseOk [] x + ParseFailed err >>= _ = ParseFailed err + ParseOk ws x >>= f = case f x of + ParseFailed err -> ParseFailed err + ParseOk ws' x' -> ParseOk (ws'++ws) x' + fail s = ParseFailed (FromString s Nothing) + +catchParseError :: ParseResult a -> (PError -> ParseResult a) + -> ParseResult a +p@(ParseOk _ _) `catchParseError` _ = p +ParseFailed e `catchParseError` k = k e + +parseFail :: PError -> ParseResult a +parseFail = ParseFailed + +runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a +runP line fieldname p s = + case [ x | (x,"") <- results ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + --TODO: what is this double parse thing all about? + -- Can't we just do the all isSpace test the first time? + [] -> case [ x | (x,ys) <- results, all isSpace ys ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + [] -> ParseFailed (NoParse fieldname line) + _ -> ParseFailed (AmbigousParse fieldname line) + _ -> ParseFailed (AmbigousParse fieldname line) + where results = readP_to_S p s + +runE :: LineNo -> String -> ReadE a -> String -> ParseResult a +runE line fieldname p s = + case runReadE p s of + Right a -> ParseOk (utf8Warnings line fieldname s) a + Left e -> syntaxError line $ + "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s + +utf8Warnings :: LineNo -> String -> String -> [PWarning] +utf8Warnings line fieldname s = + take 1 [ UTFWarning n fieldname + | (n,l) <- zip [line..] (lines s) + , '\xfffd' `elem` l ] + +locatedErrorMsg :: PError -> (Maybe LineNo, String) +locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'.") +locatedErrorMsg (NoParse f n) = (Just n, "Parse of field '"++f++"' failed.") +locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.") +locatedErrorMsg (FromString s n) = (n, s) + +syntaxError :: LineNo -> String -> ParseResult a +syntaxError n s = ParseFailed $ FromString s (Just n) + +tabsError :: LineNo -> ParseResult a +tabsError ln = ParseFailed $ TabsError ln + +warning :: String -> ParseResult () +warning s = ParseOk [PWarning s] () + +-- | Field descriptor. The parameter @a@ parameterizes over where the field's +-- value is stored in. +data FieldDescr a + = FieldDescr + { fieldName :: String + , fieldGet :: a -> Doc + , fieldSet :: LineNo -> String -> a -> ParseResult a + -- ^ @fieldSet n str x@ Parses the field value from the given input + -- string @str@ and stores the result in @x@ if the parse was + -- successful. Otherwise, reports an error on line number @n@. + } + +field :: String -> (a -> Doc) -> (ReadP a a) -> FieldDescr a +field name showF readF = + FieldDescr name showF (\line val _st -> runP line name readF val) + +-- Lift a field descriptor storing into an 'a' to a field descriptor storing +-- into a 'b'. +liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b +liftField get set (FieldDescr name showF parseF) + = FieldDescr name (\b -> showF (get b)) + (\line str b -> do + a <- parseF line str (get b) + return (set a b)) + +-- Parser combinator for simple fields. Takes a field name, a pretty printer, +-- a parser function, an accessor, and a setter, returns a FieldDescr over the +-- compoid structure. +simpleField :: String -> (a -> Doc) -> (ReadP a a) + -> (b -> a) -> (a -> b -> b) -> FieldDescr b +simpleField name showF readF get set + = liftField get set $ field name showF readF + +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 + +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) + where + set' xs b = set (get b ++ xs) b + +listField :: String -> (a -> Doc) -> (ReadP [a] a) + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listField name showF readF get set = + liftField get set' $ + field name (fsep . map showF) (parseOptCommaList readF) + where + set' xs b = set (get b ++ xs) b + +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)) + where + update _ opts l | all null opts = l --empty opts as if no opts + update f opts [] = [(f,opts)] + update f opts ((f',opts'):rest) + | f == f' = (f, opts' ++ opts) : rest + | otherwise = (f',opts') : update f opts rest + reorder = sortBy (comparing fst) + +-- 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 +-- because it does not support warnings. We need a new parser framwork! +boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b +boolField name get set = liftField get set (FieldDescr name showF readF) + where + showF = text . show + readF line str _ + | str == "True" = ParseOk [] True + | str == "False" = ParseOk [] False + | lstr == "true" = ParseOk [caseWarning] True + | lstr == "false" = ParseOk [caseWarning] False + | otherwise = ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = PWarning $ + "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] + +ppField :: String -> Doc -> Doc +ppField name fielddoc = text name <> colon <+> fielddoc + +showFields :: [FieldDescr a] -> a -> String +showFields fields = render . ($+$ text "") . ppFields fields + +showSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String) +showSingleNamedField fields f = + case [ get | (FieldDescr f' get _) <- fields, f' == f ] of + [] -> Nothing + (get:_) -> Just (render . ppField f . get) + +parseFields :: [FieldDescr a] -> a -> String -> ParseResult a +parseFields fields initial = \str -> + readFields str >>= accumFields fields initial + +parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a +parseFieldsFlat fields initial = \str -> + readFieldsFlat str >>= accumFields fields initial + +accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a +accumFields fields = foldM setField + where + fieldMap = Map.fromList + [ (name, f) | f@(FieldDescr name _ _) <- fields ] + setField accum (F line name value) = case Map.lookup name fieldMap of + Just (FieldDescr _ _ set) -> set line value accum + Nothing -> do + warning ("Unrecognized field " ++ name ++ " on line " ++ show line) + return accum + setField accum f = do + warning ("Unrecognized stanza on line " ++ show (lineNo f)) + return accum + +-- | The type of a function which, given a name-value pair of an +-- unrecognized field, and the current structure being built, +-- decides whether to incorporate the unrecognized field +-- (by returning Just x, where x is a possibly modified version +-- of the structure being built), or not (by returning Nothing). +type UnrecFieldParser a = (String,String) -> a -> Maybe a + +-- | A default unrecognized field parser which simply returns Nothing, +-- i.e. ignores all unrecognized fields, so warnings will be generated. +warnUnrec :: UnrecFieldParser a +warnUnrec _ _ = Nothing + +-- | A default unrecognized field parser which silently (i.e. no +-- warnings will be generated) ignores unrecognized fields, by +-- returning the structure being built unmodified. +ignoreUnrec :: UnrecFieldParser a +ignoreUnrec _ x = Just x + +------------------------------------------------------------------------------ + +-- The data type for our three syntactic categories +data Field + = F LineNo String String + -- ^ A regular @: @ field + | Section LineNo String String [Field] + -- ^ A section with a name and possible parameter. The syntactic + -- structure is: + -- + -- @ + -- { + -- * + -- } + -- @ + | IfBlock LineNo String [Field] [Field] + -- ^ A conditional block with an optional else branch: + -- + -- @ + -- if { + -- * + -- } else { + -- * + -- } + -- @ + deriving (Show + ,Eq) -- for testing + +lineNo :: Field -> LineNo +lineNo (F n _ _) = n +lineNo (Section n _ _ _) = n +lineNo (IfBlock n _ _ _) = n + +fName :: Field -> String +fName (F _ n _) = n +fName (Section _ n _ _) = n +fName _ = error "fname: not a field or section" + +readFields :: String -> ParseResult [Field] +readFields input = ifelse + =<< mapM (mkField 0) + =<< mkTree tokens + + where ls = (lines . normaliseLineEndings) input + tokens = (concatMap tokeniseLine . trimLines) ls + +readFieldsFlat :: String -> ParseResult [Field] +readFieldsFlat input = mapM (mkField 0) + =<< mkTree tokens + where ls = (lines . normaliseLineEndings) input + tokens = (concatMap tokeniseLineFlat . trimLines) ls + +-- attach line number and determine indentation +trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)] +trimLines ls = [ (lineno, indent, hastabs, (trimTrailing l')) + | (lineno, l) <- zip [1..] ls + , let (sps, l') = span isSpace l + indent = length sps + hastabs = '\t' `elem` sps + , validLine l' ] + where validLine ('-':'-':_) = False -- Comment + validLine [] = False -- blank line + validLine _ = True + +-- | We parse generically based on indent level and braces '{' '}'. To do that +-- we split into lines and then '{' '}' tokens and other spans within a line. +data Token = + -- | The 'Line' token is for bits that /start/ a line, eg: + -- + -- > "\n blah blah { blah" + -- + -- tokenises to: + -- + -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"] + -- + -- so lines are the only ones that can have nested layout, since they + -- have a known indentation level. + -- + -- eg: we can't have this: + -- + -- > if ... { + -- > } else + -- > other + -- + -- because other cannot nest under else, since else doesn't start a line + -- so cannot have nested layout. It'd have to be: + -- + -- > if ... { + -- > } + -- > else + -- > other + -- + -- but that's not so common, people would normally use layout or + -- brackets not both in a single @if else@ construct. + -- + -- > if ... { foo : bar } + -- > else + -- > other + -- + -- this is ok + Line LineNo Indent HasTabs String + | Span LineNo String -- ^ span in a line, following brackets + | OpenBracket LineNo | CloseBracket LineNo + +type Indent = Int +type HasTabs = Bool + +-- | Tokenise a single line, splitting on '{' '}' and the spans inbetween. +-- 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 + (Span _ l':ss) -> Line n0 i t l' :ss + cs -> cs + where split _ "" = [] + split n s = case span (\c -> c /='}' && c /= '{') s of + ("", '{' : s') -> OpenBracket n : split n s' + (w , '{' : s') -> mkspan n w (OpenBracket n : split n s') + ("", '}' : s') -> CloseBracket n : split n s' + (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') + (w , _) -> mkspan n w [] + + mkspan n s ss | null s' = ss + | otherwise = Span n s' : ss + where s' = trimTrailing (trimLeading s) + +tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token] +tokeniseLineFlat (n0, i, t, l) + | null l' = [] + | otherwise = [Line n0 i t l'] + where + l' = trimTrailing (trimLeading l) + +trimLeading, trimTrailing :: String -> String +trimLeading = dropWhile isSpace +trimTrailing = reverse . dropWhile isSpace . reverse + + +type SyntaxTree = Tree (LineNo, HasTabs, String) + +-- | Parse the stream of tokens into a tree of them, based on indent \/ layout +mkTree :: [Token] -> ParseResult [SyntaxTree] +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 }" + -- the following two should never happen: + Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l + Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l + + +-- | Parse the stream of tokens into a tree of them, based on indent +-- This parse state expect to be in a layout context, though possibly +-- nested within a braces context so we may still encounter closing braces. +layout :: Indent -- ^ indent level of the parent\/previous line + -> [SyntaxTree] -- ^ accumulating param, trees in this level + -> [Token] -- ^ remaining tokens + -> ParseResult ([SyntaxTree], [Token]) + -- ^ collected trees on this level and trailing tokens +layout _ a [] = return (reverse a, []) +layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss) +layout i a (Line n _ t l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + layout i (Node (n,t,l) sub:a) ss' + +layout i a (Span n l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + layout i (Node (n,False,l) sub:a) ss' + +-- look ahead to see if following lines are more indented, giving a sub-tree +layout i a (Line n i' t l:ss) = do + lookahead <- layout (i'+1) [] ss + case lookahead of + ([], _) -> layout i (Node (n,t,l) [] :a) ss + (ts, ss') -> layout i (Node (n,t,l) ts :a) ss' + +layout _ _ ( OpenBracket n :_) = syntaxError n $ "unexpected '{'" +layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss) +layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: " + ++ show l + +-- | Parse the stream of tokens into a tree of them, based on explicit braces +-- This parse state expects to find a closing bracket. +braces :: LineNo -- ^ line of the '{', used for error messages + -> [SyntaxTree] -- ^ accumulating param, trees in this level + -> [Token] -- ^ remaining tokens + -> ParseResult ([SyntaxTree],[Token]) + -- ^ collected trees on this level and trailing tokens +braces m a (Line n _ t l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + braces m (Node (n,t,l) sub:a) ss' + +braces m a (Span n l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + braces m (Node (n,False,l) sub:a) ss' + +braces m a (Line n i t l:ss) = do + lookahead <- layout (i+1) [] ss + case lookahead of + ([], _) -> braces m (Node (n,t,l) [] :a) ss + (ts, ss') -> braces m (Node (n,t,l) ts :a) ss' + +braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss +braces _ a (CloseBracket _:ss) = return (reverse a, ss) +braces n _ [] = syntaxError n $ "opening brace '{'" + ++ "has no matching closing brace '}'" +braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'" + +-- | Convert the parse tree into the Field AST +-- Also check for dodgy uses of tabs in indentation. +mkField :: Int -> SyntaxTree -> ParseResult Field +mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n +mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of + ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l + (name, rest) -> case trimLeading rest of + (':':rest') -> do let followingLines = concatMap Tree.flatten ts + tabs = not (null [()| (_,True,_) <- followingLines ]) + if tabs && d >= 1 + then tabsError n + else return $ F n (map toLower name) + (fieldValue rest' followingLines) + rest' -> do ts' <- mapM (mkField (d+1)) ts + return (Section n (map toLower name) rest' ts') + where fieldValue firstLine followingLines = + let firstLine' = trimLeading firstLine + followingLines' = map (\(_,_,s) -> stripDot s) followingLines + allLines | null firstLine' = followingLines' + | otherwise = firstLine' : followingLines' + in intercalate "\n" allLines + stripDot "." = "" + stripDot s = s + +-- | Convert if/then/else 'Section's to 'IfBlock's +ifelse :: [Field] -> ParseResult [Field] +ifelse [] = return [] +ifelse (Section n "if" cond thenpart + :Section _ "else" as elsepart:fs) + | null cond = syntaxError n "'if' with missing condition" + | null thenpart = syntaxError n "'then' branch of 'if' is empty" + | not (null as) = syntaxError n "'else' takes no arguments" + | null elsepart = syntaxError n "'else' branch of 'if' is empty" + | otherwise = do tp <- ifelse thenpart + ep <- ifelse elsepart + fs' <- ifelse fs + return (IfBlock n cond tp ep:fs') +ifelse (Section n "if" cond thenpart:fs) + | null cond = syntaxError n "'if' with missing condition" + | null thenpart = syntaxError n "'then' branch of 'if' is empty" + | otherwise = do tp <- ifelse thenpart + fs' <- ifelse fs + return (IfBlock n cond tp []:fs') +ifelse (Section n "else" _ _:_) = syntaxError n "stray 'else' with no preceding 'if'" +ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs' + fs''' <- ifelse fs + return (Section n s a fs'' : fs''') +ifelse (f:fs) = do fs' <- ifelse fs + return (f : fs') + +------------------------------------------------------------------------------ + +-- |parse a module name +parseModuleNameQ :: ReadP r ModuleName +parseModuleNameQ = parseQuoted parse <++ parse + +parseFilePathQ :: ReadP r FilePath +parseFilePathQ = parseTokenQ + -- removed until normalise is no longer broken, was: + -- liftM normalise parseTokenQ + +parseBuildTool :: ReadP r Dependency +parseBuildTool = do name <- parseBuildToolNameQ + skipSpaces + ver <- parseVersionRangeQ <++ return anyVersion + skipSpaces + return $ Dependency name ver + +parseBuildToolNameQ :: ReadP r PackageName +parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName + +-- like parsePackageName but accepts symbols in components +parseBuildToolName :: ReadP r PackageName +parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-') + return (PackageName (intercalate "-" ns)) + where component = do + cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_') + if all isDigit cs then pfail else return cs + +-- pkg-config allows versions and other letters in package names, +-- eg "gtk+-2.0" is a valid pkg-config package _name_. +-- It then has a package version number like 2.10.13 +parsePkgconfigDependency :: ReadP r Dependency +parsePkgconfigDependency = do name <- munch1 (\c -> isAlphaNum c || c `elem` "+-._") + skipSpaces + ver <- parseVersionRangeQ <++ return anyVersion + skipSpaces + return $ Dependency (PackageName name) ver + +parsePackageNameQ :: ReadP r PackageName +parsePackageNameQ = parseQuoted parse <++ parse + +parseVersionRangeQ :: ReadP r VersionRange +parseVersionRangeQ = parseQuoted parse <++ parse + +parseOptVersion :: ReadP r Version +parseOptVersion = parseQuoted ver <++ ver + where ver :: ReadP r Version + ver = parse <++ return noVersion + noVersion = Version{ versionBranch=[], versionTags=[] } + +parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) +parseTestedWithQ = parseQuoted tw <++ tw + where + tw :: ReadP r (CompilerFlavor,VersionRange) + tw = do compiler <- parseCompilerFlavorCompat + skipSpaces + version <- parse <++ return anyVersion + skipSpaces + return (compiler,version) + +parseLicenseQ :: ReadP r License +parseLicenseQ = parseQuoted parse <++ parse + +-- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a +-- because the "compat" version of ReadP isn't quite powerful enough. In +-- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a +-- Hence the trick above to make 'lic' polymorphic. + +parseLanguageQ :: ReadP r Language +parseLanguageQ = parseQuoted parse <++ parse + +parseExtensionQ :: ReadP r Extension +parseExtensionQ = parseQuoted parse <++ parse + +parseHaskellString :: ReadP r String +parseHaskellString = readS_to_P reads + +parseTokenQ :: ReadP r String +parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') + +parseTokenQ' :: ReadP r String +parseTokenQ' = parseHaskellString <++ munch1 (\x -> not (isSpace x)) + +parseSepList :: ReadP r b + -> ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseSepList sepr p = sepBy p separator + where separator = skipSpaces >> sepr >> skipSpaces + +parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseSpaceList p = sepBy p skipSpaces + +parseCommaList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseCommaList = parseSepList (ReadP.char ',') + +parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseOptCommaList = parseSepList (optional (ReadP.char ',')) + +parseQuoted :: ReadP r a -> ReadP r a +parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p + +parseFreeText :: ReadP.ReadP s String +parseFreeText = ReadP.munch (const True) + +-- -------------------------------------------- +-- ** Pretty printing + +showFilePath :: FilePath -> Doc +showFilePath = showToken + +showToken :: String -> Doc +showToken str + | not (any dodgy str) && + not (null str) = text str + | otherwise = text (show str) + where dodgy c = isSpace c || c == ',' + +showTestedWith :: (CompilerFlavor,VersionRange) -> Doc +showTestedWith (compiler, version) = text (show compiler) <+> disp version + +-- | Pretty-print free-format text, ensuring that it is vertically aligned, +-- and with blank lines replaced by dots for correct re-parsing. +showFreeText :: String -> Doc +showFreeText "" = empty +showFreeText ('\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 +-- characters. The resulting strings do not contain newlines. +lines_ :: String -> [String] +lines_ [] = [""] +lines_ s = let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines_ s'' diff --git a/cabal/Cabal/Distribution/ReadE.hs b/cabal/Cabal/Distribution/ReadE.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/ReadE.hs @@ -0,0 +1,81 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ReadE +-- Copyright : Jose Iborra 2008 +-- +-- 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 + ReadE(..), succeedReadE, failReadE, + -- * Projections + parseReadE, readEOrFail, + readP_to_E + ) where + +import Distribution.Compat.ReadP +import Data.Char ( isSpace ) + +-- | Parser with simple error reporting +newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a} +type ErrorMsg = String + +instance Functor ReadE where + fmap f (ReadE p) = ReadE $ \txt -> case p txt of + Right a -> Right (f a) + Left err -> Left err + +succeedReadE :: (String -> a) -> ReadE a +succeedReadE f = ReadE (Right . f) + +failReadE :: ErrorMsg -> ReadE a +failReadE = ReadE . const Left + +parseReadE :: ReadE a -> ReadP r a +parseReadE (ReadE p) = do + txt <- look + either fail return (p txt) + +readEOrFail :: ReadE a -> (String -> a) +readEOrFail r = either error id . runReadE r + +readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a +readP_to_E err r = + ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt + , all isSpace s ] + of [] -> Left (err txt) + (p:_) -> Right p diff --git a/cabal/Cabal/Distribution/Simple.hs b/cabal/Cabal/Distribution/Simple.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple.hs @@ -0,0 +1,703 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the command line front end to the Simple build system. When given +-- the parsed command-line args and package information, is able to perform +-- basic commands like configure, build, install, register, etc. +-- +-- This module exports the main functions that Setup.hs scripts use. It +-- re-exports the 'UserHooks' type, the standard entry points like +-- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of +-- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own +-- behaviour. +-- +-- This module isn't called \"Simple\" because it's simple. Far from +-- it. It's called \"Simple\" because it does complicated things to +-- simple software. +-- +-- The original idea was that there could be different build systems that all +-- 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: + Warning: In the use of `runTests' + (imported from Distribution.Simple.UserHooks): + Deprecated: "Please use the new testing interface instead!" +-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module Distribution.Simple ( + module Distribution.Package, + module Distribution.Version, + module Distribution.License, + module Distribution.Simple.Compiler, + module Language.Haskell.Extension, + -- * Simple interface + defaultMain, defaultMainNoRead, defaultMainArgs, + -- * Customization + UserHooks(..), Args, + defaultMainWithHooks, defaultMainWithHooksArgs, + -- ** Standard sets of hooks + simpleUserHooks, + autoconfUserHooks, + defaultUserHooks, emptyUserHooks, + -- ** Utils + defaultHookedPackageDesc + ) where + +-- 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.PackageDescription + ( PackageDescription(..), GenericPackageDescription, Executable(..) + , updatePackageDescription, hasLibs + , HookedBuildInfo, emptyHookedBuildInfo ) +import Distribution.PackageDescription.Parse + ( readPackageDescription, readHookedBuildInfo ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.Simple.Program + ( defaultProgramConfiguration, addKnownPrograms, builtinPrograms + , restoreProgramConfiguration, reconfigurePrograms ) +import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler) +import Distribution.Simple.Setup +import Distribution.Simple.Command + +import Distribution.Simple.Build ( build ) +import Distribution.Simple.SrcDist ( sdist ) +import Distribution.Simple.Register + ( register, unregister ) + +import Distribution.Simple.Configure + ( getPersistBuildConfig, maybeGetPersistBuildConfig + , writePersistBuildConfig, checkPersistBuildConfigOutdated + , configure, checkForeignDeps ) + +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.Bench (bench) +import Distribution.Simple.BuildPaths ( srcPref) +import Distribution.Simple.Test (test) +import Distribution.Simple.Install (install) +import Distribution.Simple.Haddock (haddock, hscolour) +import Distribution.Simple.Utils + (die, notice, info, warn, setupMessage, chattyTry, + defaultPackageDesc, defaultHookedPackageDesc, + rawSystemExitWithEnv, cabalVersion, topHandler ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Verbosity +import Language.Haskell.Extension +import Distribution.Version +import Distribution.License +import Distribution.Text + ( display ) + +-- Base +import System.Environment(getArgs, getProgName, getEnvironment) +import System.Directory(removeFile, doesFileExist, + doesDirectoryExist, removeDirectoryRecursive) +import System.Exit +import System.IO.Error (isDoesNotExistError) +import Distribution.Compat.Exception (catchIO, throwIOIO) + +import Control.Monad (when) +import Data.List (intersperse, unionBy, nub, (\\)) + +-- | A simple implementation of @main@ for a Cabal setup script. +-- It reads the package description file using IO, and performs the +-- action specified on the command line. +defaultMain :: IO () +defaultMain = getArgs >>= defaultMainHelper simpleUserHooks + +-- | A version of 'defaultMain' that is passed the command line +-- arguments, rather than getting them from the environment. +defaultMainArgs :: [String] -> IO () +defaultMainArgs = defaultMainHelper simpleUserHooks + +-- | A customizable version of 'defaultMain'. +defaultMainWithHooks :: UserHooks -> IO () +defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks + +-- | A customizable version of 'defaultMain' that also takes the command +-- line arguments. +defaultMainWithHooksArgs :: UserHooks -> [String] -> IO () +defaultMainWithHooksArgs = defaultMainHelper + +-- | Like 'defaultMain', but accepts the package description as input +-- rather than using IO to read it. +defaultMainNoRead :: GenericPackageDescription -> IO () +defaultMainNoRead pkg_descr = + getArgs >>= + defaultMainHelper simpleUserHooks { readDesc = return (Just pkg_descr) } + +defaultMainHelper :: UserHooks -> Args -> IO () +defaultMainHelper hooks args = topHandler $ + case commandsRun globalCommand commands args of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (flags, commandParse) -> + case commandParse of + _ | fromFlag (globalVersion flags) -> printVersion + | fromFlag (globalNumericVersion flags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action + + where + printHelp help = getProgName >>= putStr . help + printOptionsList = putStr . unlines + printErrors errs = do + putStr (concat (intersperse "\n" errs)) + exitWith (ExitFailure 1) + printNumericVersion = putStrLn $ display cabalVersion + printVersion = putStrLn $ "Cabal library version " + ++ display cabalVersion + + progs = addKnownPrograms (hookedPrograms hooks) defaultProgramConfiguration + commands = + [configureCommand progs `commandAddAction` \fs as -> + configureAction hooks fs as >> return () + ,buildCommand progs `commandAddAction` buildAction hooks + ,installCommand `commandAddAction` installAction hooks + ,copyCommand `commandAddAction` copyAction hooks + ,haddockCommand `commandAddAction` haddockAction hooks + ,cleanCommand `commandAddAction` cleanAction hooks + ,sdistCommand `commandAddAction` sdistAction hooks + ,hscolourCommand `commandAddAction` hscolourAction hooks + ,registerCommand `commandAddAction` registerAction hooks + ,unregisterCommand `commandAddAction` unregisterAction hooks + ,testCommand `commandAddAction` testAction hooks + ,benchmarkCommand `commandAddAction` benchAction hooks + ] + +-- | Combine the preprocessors in the given hooks with the +-- preprocessors built into cabal. +allSuffixHandlers :: UserHooks + -> [PPSuffixHandler] +allSuffixHandlers hooks + = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers + where + overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] + overridesPP = unionBy (\x y -> fst x == fst y) + +configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo +configureAction hooks flags args = do + let distPref = fromFlag $ configDistPref flags + pbi <- preConf hooks args flags + + (mb_pd_file, pkg_descr0) <- confPkgDescr + + -- get_pkg_descr (configVerbosity flags') + --let pkg_descr = updatePackageDescription pbi pkg_descr0 + let epkg_descr = (pkg_descr0, pbi) + + --(warns, ers) <- sanityCheckPackage pkg_descr + --errorOut (configVerbosity flags') warns ers + + localbuildinfo0 <- confHook hooks epkg_descr flags + + -- remember the .cabal filename if we know it + -- 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) + +buildAction :: UserHooks -> BuildFlags -> Args -> IO () +buildAction hooks flags args = do + let distPref = fromFlag $ buildDistPref flags + verbosity = fromFlag $ buildVerbosity flags + + lbi <- getBuildConfig hooks verbosity distPref + progs <- reconfigurePrograms verbosity + (buildProgramPaths flags) + (buildProgramArgs flags) + (withPrograms lbi) + + hookedAction preBuild buildHook postBuild + (return lbi { withPrograms = progs }) + hooks flags args + +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 + +haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () +haddockAction hooks flags args = do + let distPref = fromFlag $ haddockDistPref flags + verbosity = fromFlag $ haddockVerbosity flags + + lbi <- getBuildConfig hooks verbosity distPref + progs <- reconfigurePrograms verbosity + (haddockProgramPaths flags) + (haddockProgramArgs flags) + (withPrograms lbi) + + hookedAction preHaddock haddockHook postHaddock + (return lbi { withPrograms = progs }) + hooks flags args + +cleanAction :: UserHooks -> CleanFlags -> Args -> IO () +cleanAction hooks flags args = do + pbi <- preClean hooks args 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 + +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 + +sdistAction :: UserHooks -> SDistFlags -> Args -> IO () +sdistAction hooks flags args = do + let distPref = fromFlag $ sDistDistPref flags + 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 + + 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 + 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 + (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 + hookedActionWithArgs preBench benchHook postBench + (getBuildConfig hooks verbosity distPref) + 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 + +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 + +hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo) + -> (UserHooks -> PackageDescription -> LocalBuildInfo + -> UserHooks -> flags -> IO ()) + -> (UserHooks -> Args -> flags -> PackageDescription + -> LocalBuildInfo -> IO ()) + -> IO LocalBuildInfo + -> UserHooks -> flags -> Args -> IO () +hookedAction pre_hook cmd_hook = + hookedActionWithArgs pre_hook (\h _ pd lbi uh flags -> cmd_hook h pd lbi uh flags) + +hookedActionWithArgs :: (UserHooks -> Args -> flags -> IO HookedBuildInfo) + -> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo + -> UserHooks -> flags -> IO ()) + -> (UserHooks -> Args -> flags -> PackageDescription + -> LocalBuildInfo -> IO ()) + -> IO LocalBuildInfo + -> UserHooks -> flags -> Args -> IO () +hookedActionWithArgs pre_hook cmd_hook post_hook get_build_config hooks flags args = do + pbi <- pre_hook hooks args flags + localbuildinfo <- get_build_config + let pkg_descr0 = localPkgDescr localbuildinfo + --pkg_descr0 <- get_pkg_descr (get_verbose flags) + sanityCheckHookedBuildInfo pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + -- TODO: should we write the modified package descr back to the + -- localbuildinfo? + cmd_hook hooks args pkg_descr localbuildinfo hooks flags + post_hook hooks args flags pkg_descr localbuildinfo + +sanityCheckHookedBuildInfo :: PackageDescription -> HookedBuildInfo -> IO () +sanityCheckHookedBuildInfo PackageDescription { library = Nothing } (Just _,_) + = die $ "The buildinfo contains info for a library, " + ++ "but the package does not have a library." + +sanityCheckHookedBuildInfo pkg_descr (_, hookExes) + | not (null nonExistant) + = die $ "The buildinfo contains info for an executable called '" + ++ head nonExistant ++ "' but the package does not have a " + ++ "executable with that name." + where + pkgExeNames = nub (map exeName (executables pkg_descr)) + hookExeNames = nub (map fst hookExes) + nonExistant = hookExeNames \\ pkgExeNames + +sanityCheckHookedBuildInfo _ _ = return () + + +getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo +getBuildConfig hooks verbosity distPref = do + lbi_wo_programs <- getPersistBuildConfig distPref + -- Restore info about unconfigured programs, since it is not serialized + let lbi = lbi_wo_programs { + withPrograms = restoreProgramConfiguration + (builtinPrograms ++ hookedPrograms hooks) + (withPrograms lbi_wo_programs) + } + + case pkgDescrFile lbi of + Nothing -> return lbi + Just pkg_descr_file -> do + outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file + if outdated + then reconfigure pkg_descr_file lbi + else return lbi + + where + reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo + reconfigure pkg_descr_file lbi = do + notice verbosity $ pkg_descr_file ++ " has been changed. " + ++ "Re-configuring with most recently used options. " + ++ "If this fails, please run configure manually.\n" + let cFlags = configFlags lbi + 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: + configPrograms = restoreProgramConfiguration + (builtinPrograms ++ hookedPrograms hooks) + (configPrograms cFlags), + + -- Use the current, not saved verbosity level: + configVerbosity = Flag verbosity + } + configureAction hooks cFlags' (extraConfigArgs lbi) + + +-- -------------------------------------------------------------------------- +-- Cleaning + +clean :: PackageDescription -> CleanFlags -> IO () +clean pkg_descr flags = do + let distPref = fromFlag $ cleanDistPref flags + notice verbosity "cleaning..." + + maybeConfig <- if fromFlag (cleanSaveConf flags) + then maybeGetPersistBuildConfig distPref + else return Nothing + + -- remove the whole dist/ directory rather than tracking exactly what files + -- we created in there. + chattyTry "removing dist/" $ do + exists <- doesDirectoryExist distPref + when exists (removeDirectoryRecursive distPref) + + -- Any extra files the user wants to remove + mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr) + + -- If the user wanted to save the config, write it back + maybe (return ()) (writePersistBuildConfig distPref) maybeConfig + + where + removeFileOrDirectory :: FilePath -> IO () + removeFileOrDirectory fname = do + isDir <- doesDirectoryExist fname + isFile <- doesFileExist fname + if isDir then removeDirectoryRecursive fname + else if isFile then removeFile fname + else return () + verbosity = fromFlag (cleanVerbosity flags) + +-- -------------------------------------------------------------------------- +-- Default hooks + +-- | Hooks that correspond to a plain instantiation of the +-- \"simple\" build system +simpleUserHooks :: UserHooks +simpleUserHooks = + emptyUserHooks { + confHook = configure, + postConf = finalChecks, + buildHook = defaultBuildHook, + copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params + testHook = defaultTestHook, + benchHook = defaultBenchHook, + instHook = defaultInstallHook, + sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h), + cleanHook = \p _ _ f -> clean p f, + hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f, + haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f, + regHook = defaultRegHook, + unregHook = \p l _ f -> unregister p l f + } + where + finalChecks _args flags pkg_descr lbi = + checkForeignDeps pkg_descr lbi (lessVerbose verbosity) + where + verbosity = fromFlag (configVerbosity flags) + +-- | Basic autoconf 'UserHooks': +-- +-- * 'postConf' runs @.\/configure@, if present. +-- +-- * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst', +-- 'preReg' and 'preUnreg' read additional build information from +-- /package/@.buildinfo@, if present. +-- +-- Thus @configure@ can use local system information to generate +-- /package/@.buildinfo@ and possibly other files. + +{-# DEPRECATED defaultUserHooks + "Use simpleUserHooks or autoconfUserHooks, unless you need Cabal-1.2\n compatibility in which case you must stick with defaultUserHooks" #-} +defaultUserHooks :: UserHooks +defaultUserHooks = autoconfUserHooks { + confHook = \pkg flags -> do + let verbosity = fromFlag (configVerbosity flags) + warn verbosity $ + "defaultUserHooks in Setup script is deprecated." + confHook autoconfUserHooks pkg flags, + postConf = oldCompatPostConf + } + -- This is the annoying old version that only runs configure if it exists. + -- It's here for compatibility with existing Setup.hs scripts. See: + -- http://hackage.haskell.org/trac/hackage/ticket/165 + where oldCompatPostConf args flags pkg_descr lbi + = do let verbosity = fromFlag (configVerbosity flags) + noExtraFlags args + confExists <- doesFileExist "configure" + when confExists $ + runConfigureScript verbosity + backwardsCompatHack flags lbi + + pbi <- getHookedBuildInfo verbosity + sanityCheckHookedBuildInfo pkg_descr pbi + let pkg_descr' = updatePackageDescription pbi pkg_descr + postConf simpleUserHooks args flags pkg_descr' lbi + + backwardsCompatHack = True + +autoconfUserHooks :: UserHooks +autoconfUserHooks + = simpleUserHooks + { + postConf = defaultPostConf, + preBuild = readHook buildVerbosity, + preClean = readHook cleanVerbosity, + preCopy = readHook copyVerbosity, + preInst = readHook installVerbosity, + preHscolour = readHook hscolourVerbosity, + preHaddock = readHook haddockVerbosity, + preReg = readHook regVerbosity, + preUnreg = readHook regVerbosity + } + where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () + defaultPostConf args flags pkg_descr lbi + = do let verbosity = fromFlag (configVerbosity flags) + noExtraFlags args + confExists <- doesFileExist "configure" + if confExists + then runConfigureScript verbosity + backwardsCompatHack flags lbi + else die "configure script not found." + + pbi <- getHookedBuildInfo verbosity + sanityCheckHookedBuildInfo pkg_descr pbi + let pkg_descr' = updatePackageDescription pbi pkg_descr + postConf simpleUserHooks args flags pkg_descr' lbi + + backwardsCompatHack = False + + readHook :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo + readHook get_verbosity a flags = do + noExtraFlags a + getHookedBuildInfo verbosity + where + verbosity = fromFlag (get_verbosity flags) + +runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo + -> IO () +runConfigureScript verbosity backwardsCompatHack flags lbi = do + + env <- getEnvironment + let programConfig = withPrograms lbi + (ccProg, ccFlags) <- configureCCompiler verbosity programConfig + -- The C compiler's compilation and linker flags (e.g. + -- "C compiler flags" and "Gcc Linker flags" from GHC) have already + -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS + -- to ccFlags + -- We don't try and tell configure which ld to use, as we don't have + -- a way to pass its flags too + let env' = appendToEnvironment ("CFLAGS", unwords ccFlags) + env + args' = args ++ ["--with-gcc=" ++ ccProg] + handleNoWindowsSH $ + rawSystemExitWithEnv verbosity "sh" args' env' + + where + args = "configure" : configureArgs backwardsCompatHack flags + + appendToEnvironment (key, val) [] = [(key, val)] + appendToEnvironment (key, val) (kv@(k, v) : rest) + | key == k = (key, v ++ " " ++ val) : rest + | otherwise = kv : appendToEnvironment (key, val) rest + + handleNoWindowsSH action + | buildOS /= Windows + = action + + | otherwise + = action + `catchIO` \ioe -> if isDoesNotExistError ioe + then die notFoundMsg + else throwIOIO ioe + + notFoundMsg = "The package has a './configure' script. This requires a " + ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin." + +getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo +getHookedBuildInfo verbosity = do + maybe_infoFile <- defaultHookedPackageDesc + case maybe_infoFile of + Nothing -> return emptyHookedBuildInfo + Just infoFile -> do + info verbosity $ "Reading parameters from " ++ infoFile + readHookedBuildInfo verbosity infoFile + +defaultTestHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> TestFlags -> IO () +defaultTestHook pkg_descr localbuildinfo _ flags = + test pkg_descr localbuildinfo flags + +defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo + -> UserHooks -> BenchmarkFlags -> IO () +defaultBenchHook args pkg_descr localbuildinfo _ flags = + bench args pkg_descr localbuildinfo flags + +defaultInstallHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> InstallFlags -> IO () +defaultInstallHook pkg_descr localbuildinfo _ flags = do + let copyFlags = defaultCopyFlags { + copyDistPref = installDistPref flags, + copyDest = toFlag NoCopyDest, + copyVerbosity = installVerbosity flags + } + install pkg_descr localbuildinfo copyFlags + let registerFlags = defaultRegisterFlags { + regDistPref = installDistPref flags, + regInPlace = installInPlace flags, + regPackageDB = installPackageDB flags, + regVerbosity = installVerbosity flags + } + when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags + +defaultBuildHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> BuildFlags -> IO () +defaultBuildHook pkg_descr localbuildinfo hooks flags = + build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) + +defaultRegHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> RegisterFlags -> IO () +defaultRegHook pkg_descr localbuildinfo _ flags = + if hasLibs pkg_descr + then register pkg_descr localbuildinfo flags + else setupMessage verbosity + "Package contains no library to register:" (packageId pkg_descr) + where verbosity = fromFlag (regVerbosity flags) diff --git a/cabal/Cabal/Distribution/Simple/Bench.hs b/cabal/Cabal/Distribution/Simple/Bench.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Bench.hs @@ -0,0 +1,156 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Bench +-- Copyright : Johan Tibell 2011 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into running the benchmarks in a built +-- 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 + +import qualified Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(buildable) + , Benchmark(..), BenchmarkInterface(..), benchmarkType, hasBenchmarks ) +import Distribution.Simple.BuildPaths ( exeExtension ) +import Distribution.Simple.Compiler ( Compiler(..) ) +import Distribution.Simple.InstallDirs + ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) + , substPathTemplate , toPathTemplate, PathTemplate ) +import qualified Distribution.Simple.LocalBuildInfo as LBI + ( LocalBuildInfo(..) ) +import Distribution.Simple.Setup ( BenchmarkFlags(..), fromFlag ) +import Distribution.Simple.UserHooks ( Args ) +import Distribution.Simple.Utils ( die, notice, rawSystemExitCode ) +import Distribution.Text + +import Control.Monad ( when, unless ) +import System.Exit ( ExitCode(..), exitFailure, exitWith ) +import System.Directory ( doesFileExist ) +import System.FilePath ( (), (<.>) ) + +-- | Perform the \"@.\/setup bench@\" action. +bench :: Args -- ^positional command-line arguments + -> PD.PackageDescription -- ^information from the .cabal file + -> LBI.LocalBuildInfo -- ^information from the configure step + -> BenchmarkFlags -- ^flags sent to benchmark + -> IO () +bench args pkg_descr lbi flags = do + let verbosity = fromFlag $ benchmarkVerbosity flags + benchmarkNames = args + pkgBenchmarks = PD.benchmarks pkg_descr + enabledBenchmarks = [ t | t <- pkgBenchmarks + , PD.benchmarkEnabled t + , PD.buildable (PD.benchmarkBuildInfo t) ] + + -- Run the benchmark + doBench :: PD.Benchmark -> IO ExitCode + doBench bm = + case PD.benchmarkInterface bm of + PD.BenchmarkExeV10 _ _ -> do + let cmd = LBI.buildDir lbi PD.benchmarkName bm + PD.benchmarkName bm <.> exeExtension + options = map (benchOption pkg_descr lbi bm) $ + benchmarkOptions flags + name = PD.benchmarkName bm + -- Check that the benchmark executable exists. + exists <- doesFileExist cmd + unless exists $ die $ + "Error: Could not find benchmark program \"" + ++ cmd ++ "\". Did you build the package first?" + + notice verbosity $ startMessage name + -- This will redirect the child process + -- stdout/stderr to the parent process. + exitcode <- rawSystemExitCode verbosity cmd options + notice verbosity $ finishMessage name exitcode + return exitcode + + _ -> do + notice verbosity $ "No support for running " + ++ "benchmark " ++ PD.benchmarkName bm ++ " of type: " + ++ show (disp $ PD.benchmarkType bm) + exitFailure + + when (not $ PD.hasBenchmarks pkg_descr) $ do + notice verbosity "Package has no benchmarks." + exitWith ExitSuccess + + when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ + die $ "No benchmarks enabled. Did you remember to configure with " + ++ "\'--enable-benchmarks\'?" + + bmsToRun <- case benchmarkNames of + [] -> return enabledBenchmarks + names -> flip mapM names $ \bmName -> + let benchmarkMap = zip enabledNames enabledBenchmarks + enabledNames = map PD.benchmarkName enabledBenchmarks + allNames = map PD.benchmarkName pkgBenchmarks + in case lookup bmName benchmarkMap of + Just t -> return t + _ | bmName `elem` allNames -> + die $ "Package configured with benchmark " + ++ bmName ++ " disabled." + | otherwise -> die $ "no such benchmark: " ++ bmName + + let totalBenchmarks = length bmsToRun + notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." + exitcodes <- mapM doBench bmsToRun + let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes) + unless allOk exitFailure + where + startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n" + finishMessage name exitcode = "Benchmark " ++ name ++ ": " + ++ (case exitcode of + ExitSuccess -> "FINISH" + ExitFailure _ -> "ERROR") + + +-- TODO: This is abusing the notion of a 'PathTemplate'. The result +-- isn't neccesarily a path. +benchOption :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.Benchmark + -> PathTemplate + -> String +benchOption pkg_descr lbi bm template = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) ++ + [(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)] diff --git a/cabal/Cabal/Distribution/Simple/Build.hs b/cabal/Cabal/Distribution/Simple/Build.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Build.hs @@ -0,0 +1,349 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point to actually building the modules in a package. It +-- doesn't actually do much itself, most of the work is delegated to +-- compiler-specific actions. It does do some non-compiler specific bits like +-- 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, + + initialBuildSteps, + 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.Build.Macros as Build.Macros +import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule + +import Distribution.Package + ( Package(..), PackageName(..), PackageIdentifier(..) + , Dependency(..), thisPackageVersion ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), compilerFlavor, PackageDB(..) ) +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..) + , TestSuite(..), TestSuiteInterface(..), Benchmark(..) + , BenchmarkInterface(..) ) +import qualified Distribution.InstalledPackageInfo as IPI +import qualified Distribution.ModuleName as ModuleName + +import Distribution.Simple.Setup + ( BuildFlags(..), fromFlag ) +import Distribution.Simple.PreProcess + ( preprocessComponent, PPSuffixHandler ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms) + , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI + , componentBuildInfo, inplacePackageId ) +import Distribution.Simple.Program.Types +import Distribution.Simple.Program.Db +import Distribution.Simple.BuildPaths + ( autogenModulesDir, autogenModuleName, cppHeaderName, exeExtension ) +import Distribution.Simple.Register + ( registerPackage, inplaceInstalledPackageInfo ) +import Distribution.Simple.Test ( stubFilePath, stubName ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, rewriteFile + , die, info, setupMessage ) + +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Text + ( display ) + +import Data.Maybe + ( maybeToList ) +import Data.List + ( intersect ) +import Control.Monad + ( unless ) +import System.FilePath + ( (), (<.>) ) +import System.Directory + ( getCurrentDirectory ) + +-- ----------------------------------------------------------------------------- +-- |Build the libraries and executables in this package. + +build :: PackageDescription -- ^ Mostly information from the .cabal file + -> LocalBuildInfo -- ^ Configuration information + -> BuildFlags -- ^ Flags that the user passed to build + -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling + -> IO () +build pkg_descr lbi flags suffixes = do + let distPref = fromFlag (buildDistPref flags) + verbosity = fromFlag (buildVerbosity flags) + initialBuildSteps distPref pkg_descr lbi verbosity + setupMessage verbosity "Building" (packageId pkg_descr) + + internalPackageDB <- createInternalPackageDB distPref + + withComponentsLBI pkg_descr lbi $ \comp clbi -> + let bi = componentBuildInfo comp + progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) + lbi' = lbi { + withPrograms = progs', + withPackageDB = withPackageDB lbi ++ [internalPackageDB] + } + in buildComponent verbosity pkg_descr lbi' suffixes comp clbi distPref + + +buildComponent :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> Component + -> ComponentLocalBuildInfo + -> FilePath + -> IO () +buildComponent verbosity pkg_descr lbi suffixes + comp@(CLib lib) clbi distPref = do + preprocessComponent pkg_descr comp lbi False verbosity suffixes + info verbosity "Building library..." + buildLib verbosity 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) + } + registerPackage verbosity + installedPkgInfo pkg_descr lbi True -- True meaning inplace + (withPackageDB lbi) + + +buildComponent verbosity pkg_descr lbi suffixes + comp@(CExe exe) clbi _ = do + preprocessComponent pkg_descr comp lbi False verbosity suffixes + info verbosity $ "Building executable " ++ exeName exe ++ "..." + buildExe verbosity pkg_descr lbi exe clbi + + +buildComponent verbosity pkg_descr lbi suffixes + comp@(CTest + test@TestSuite { testInterface = TestSuiteExeV10 _ f }) + clbi _distPref = do + let bi = testBuildInfo test + exe = Executable { + exeName = testName test, + modulePath = f, + buildInfo = bi + } + preprocessComponent pkg_descr comp lbi False verbosity suffixes + info verbosity $ "Building test suite " ++ testName test ++ "..." + buildExe verbosity pkg_descr lbi exe clbi + + +buildComponent verbosity pkg_descr lbi suffixes + comp@(CTest + test@TestSuite { testInterface = TestSuiteLibV09 _ m }) + clbi distPref = do + pwd <- getCurrentDirectory + let bi = testBuildInfo test + lib = Library { + exposedModules = [ m ], + libExposed = True, + libBuildInfo = bi + } + pkg = pkg_descr { + package = (package pkg_descr) { + pkgName = PackageName (testName test) + } + , buildDepends = targetBuildDepends $ testBuildInfo test + , executables = [] + , testSuites = [] + , library = Just lib + } + ipi = (inplaceInstalledPackageInfo pwd distPref pkg lib lbi clbi) { + IPI.installedPackageId = inplacePackageId $ packageId ipi + } + testDir = buildDir lbi stubName test + stubName test ++ "-tmp" + testLibDep = thisPackageVersion $ package pkg + exe = Executable { + exeName = stubName test, + modulePath = stubFilePath test, + buildInfo = (testBuildInfo test) { + hsSourceDirs = [ testDir ], + targetBuildDepends = testLibDep + : (targetBuildDepends $ testBuildInfo test) + } + } + -- | The stub executable needs a new 'ComponentLocalBuildInfo' + -- that exposes the relevant test suite library. + exeClbi = clbi { + componentPackageDeps = + (IPI.installedPackageId ipi, packageId ipi) + : (filter (\(_, x) -> let PackageName name = pkgName x + in name == "Cabal" || name == "base") + (componentPackageDeps clbi)) + } + preprocessComponent pkg_descr comp lbi False verbosity suffixes + info verbosity $ "Building test suite " ++ testName test ++ "..." + buildLib verbosity pkg lbi lib clbi + registerPackage verbosity ipi pkg lbi True $ withPackageDB lbi + buildExe verbosity pkg_descr lbi exe exeClbi + + +buildComponent _ _ _ _ + (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) + _ _ = + die $ "No support for building test suite type " ++ display tt + + +buildComponent verbosity pkg_descr lbi suffixes + comp@(CBench + bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f }) + clbi _ = do + let bi = benchmarkBuildInfo bm + exe = Executable + { exeName = benchmarkName bm + , modulePath = f + , buildInfo = bi + } + preprocessComponent pkg_descr comp lbi False verbosity suffixes + info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..." + buildExe verbosity pkg_descr lbi exe clbi + + +buildComponent _ _ _ _ + (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) + _ _ = + die $ "No support for building benchmark type " ++ display tt + + +-- | 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 + +addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo + -> ProgramDb -> ProgramDb +addInternalBuildTools pkg lbi bi progs = + foldr updateProgram progs internalBuildTools + where + internalBuildTools = + [ simpleConfiguredProgram toolName (FoundOnSystem toolLocation) + | toolName <- toolNames + , let toolLocation = buildDir lbi toolName toolName <.> exeExtension ] + toolNames = intersect buildToolNames internalExeNames + internalExeNames = map exeName (executables pkg) + buildToolNames = map buildToolName (buildTools bi) + where + buildToolName (Dependency (PackageName name) _ ) = name + + +-- TODO: build separate libs in separate dirs so that we can build +-- multiple libs, e.g. for 'LibTest' library-style testsuites +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildLib verbosity 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 + _ -> die "Building is not supported with this compiler." + +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity pkg_descr lbi exe clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildExe verbosity 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." + +initialBuildSteps :: FilePath -- ^"dist" prefix + -> PackageDescription -- ^mostly information from the .cabal file + -> LocalBuildInfo -- ^Configuration information + -> Verbosity -- ^The verbosity to use + -> 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 + let name = display (packageId pkg_descr) + die ("Package " ++ name ++ " can't be built on this system.") + + createDirectoryIfMissingVerbose verbosity True (buildDir lbi) + + writeAutogenFiles verbosity pkg_descr lbi + +-- | Generate and write out the Paths_.hs and cabal_macros.h files +-- +writeAutogenFiles :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> IO () +writeAutogenFiles verbosity pkg lbi = do + createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi) + + let pathsModulePath = autogenModulesDir lbi + ModuleName.toFilePath (autogenModuleName pkg) <.> "hs" + rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi) + + let cppHeaderPath = autogenModulesDir lbi cppHeaderName + rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi) diff --git a/cabal/Cabal/Distribution/Simple/Build/Macros.hs b/cabal/Cabal/Distribution/Simple/Build/Macros.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Build/Macros.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build.Macros +-- Copyright : Simon Marlow 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Generate cabal_macros.h - CPP macros for package version testing +-- +-- When using CPP you get +-- +-- > VERSION_ +-- > MIN_VERSION_(A,B,C) +-- +-- for each /package/ in @build-depends@, which is true if the version of +-- /package/ in use is @>= A.B.C@, using the normal ordering on version +-- numbers. +-- +module Distribution.Simple.Build.Macros ( + generate + ) where + +import Distribution.Package + ( PackageIdentifier(PackageIdentifier) ) +import Distribution.Version + ( Version(versionBranch) ) +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo, externalPackageDeps ) +import Distribution.Text + ( display ) + +-- ------------------------------------------------------------ +-- * Generate cabal_macros.h +-- ------------------------------------------------------------ + +generate :: PackageDescription -> LocalBuildInfo -> String +generate _pkg_descr lbi = concat $ + "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" : + [ concat + ["/* package ",display pkgid," */\n" + ,"#define VERSION_",pkgname," ",show (display version),"\n" + ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + | (_, pkgid@(PackageIdentifier name version)) <- externalPackageDeps lbi + , let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + pkgname = map fixchar (display name) + ] + where fixchar '-' = '_' + fixchar c = c + diff --git a/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs b/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs @@ -0,0 +1,262 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build.Macros +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Generating the Paths_pkgname module. +-- +-- This is a module that Cabal generates for the benefit of packages. It +-- enables them to find their version number and find any installed data files +-- at runtime. This code should probably be split off into another module. +-- +module Distribution.Simple.Build.PathsModule ( + generate, pkgPathEnvVar + ) where + +import Distribution.System + ( OS(Windows), buildOS, Arch(..), buildArch ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), compilerFlavor, compilerVersion ) +import Distribution.Package + ( packageId, packageName, packageVersion ) +import Distribution.PackageDescription + ( PackageDescription(..), hasLibs ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), InstallDirs(..) + , absoluteInstallDirs, prefixRelativeInstallDirs ) +import Distribution.Simple.Setup ( CopyDest(NoCopyDest) ) +import Distribution.Simple.BuildPaths + ( autogenModuleName ) +import Distribution.Text + ( display ) +import Distribution.Version + ( Version(..), orLaterVersion, withinRange ) + +import System.FilePath + ( pathSeparator ) +import Data.Maybe + ( fromJust, isNothing ) + +-- ------------------------------------------------------------ +-- * Building Paths_.hs +-- ------------------------------------------------------------ + +generate :: PackageDescription -> LocalBuildInfo -> String +generate pkg_descr lbi = + let pragmas + | absolute || isHugs = "" + | supports_language_pragma = + "{-# LANGUAGE ForeignFunctionInterface #-}\n" + | otherwise = + "{-# OPTIONS_GHC -fffi #-}\n"++ + "{-# OPTIONS_JHC -fffi #-}\n" + + foreign_imports + | absolute = "" + | isHugs = "import System.Environment\n" + | otherwise = + "import Foreign\n"++ + "import Foreign.C\n" + + header = + pragmas++ + "module " ++ display paths_modulename ++ " (\n"++ + " version,\n"++ + " getBinDir, getLibDir, getDataDir, getLibexecDir,\n"++ + " getDataFileName\n"++ + " ) where\n"++ + "\n"++ + foreign_imports++ + "import qualified Control.Exception as Exception\n"++ + "import Data.Version (Version(..))\n"++ + "import System.Environment (getEnv)\n"++ + "import Prelude\n"++ + "\n"++ + "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++ + "catchIO = Exception.catch\n" ++ + "\n"++ + "\nversion :: Version"++ + "\nversion = " ++ show (packageVersion pkg_descr) + + body + | absolute = + "\nbindir, libdir, datadir, libexecdir :: FilePath\n"++ + "\nbindir = " ++ show flat_bindir ++ + "\nlibdir = " ++ show flat_libdir ++ + "\ndatadir = " ++ show flat_datadir ++ + "\nlibexecdir = " ++ show flat_libexecdir ++ + "\n"++ + "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"++ + "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++ + "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++ + "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++ + "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++ + "\n"++ + "getDataFileName :: FilePath -> IO FilePath\n"++ + "getDataFileName name = do\n"++ + " dir <- getDataDir\n"++ + " return (dir ++ "++path_sep++" ++ name)\n" + | otherwise = + "\nprefix, bindirrel :: FilePath" ++ + "\nprefix = " ++ show flat_prefix ++ + "\nbindirrel = " ++ show (fromJust flat_bindirrel) ++ + "\n\n"++ + "getBinDir :: IO FilePath\n"++ + "getBinDir = getPrefixDirRel bindirrel\n\n"++ + "getLibDir :: IO FilePath\n"++ + "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"++ + "getDataDir :: IO FilePath\n"++ + "getDataDir = "++ mkGetEnvOr "datadir" + (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++ + "getLibexecDir :: IO FilePath\n"++ + "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"++ + "getDataFileName :: FilePath -> IO FilePath\n"++ + "getDataFileName name = do\n"++ + " dir <- getDataDir\n"++ + " return (dir `joinFileName` name)\n"++ + "\n"++ + get_prefix_stuff++ + "\n"++ + filename_stuff + in header++body + + where + InstallDirs { + prefix = flat_prefix, + bindir = flat_bindir, + libdir = flat_libdir, + datadir = flat_datadir, + libexecdir = flat_libexecdir + } = absoluteInstallDirs pkg_descr lbi NoCopyDest + InstallDirs { + bindir = flat_bindirrel, + libdir = flat_libdirrel, + datadir = flat_datadirrel, + libexecdir = flat_libexecdirrel, + progdir = flat_progdirrel + } = prefixRelativeInstallDirs (packageId pkg_descr) lbi + + mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel + mkGetDir dir Nothing = "return " ++ show dir + + mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++ + " (\\_ -> "++expr++")" + where var' = pkgPathEnvVar pkg_descr var + + -- In several cases we cannot make relocatable installations + 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 + supportsRelocatableProgs GHC = 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 + + path_sep = show [pathSeparator] + + supports_language_pragma = + compilerFlavor (compiler lbi) == GHC && + (compilerVersion (compiler lbi) + `withinRange` orLaterVersion (Version [6,6,1] [])) + +-- | Generates the name of the environment variable controlling the path +-- component of interest. +pkgPathEnvVar :: PackageDescription + -> String -- ^ path component; one of \"bindir\", \"libdir\", + -- \"datadir\" or \"libexecdir\" + -> String -- ^ environment variable name +pkgPathEnvVar pkg_descr var = + showPkgName (packageName pkg_descr) ++ "_" ++ var + where + showPkgName = map fixchar . display + fixchar '-' = '_' + fixchar c = c + +get_prefix_win32 :: Arch -> String +get_prefix_win32 arch = + "getPrefixDirRel :: FilePath -> IO FilePath\n"++ + "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n"++ + " where\n"++ + " try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n"++ + " ret <- c_GetModuleFileName nullPtr buf size\n"++ + " case ret of\n"++ + " 0 -> return (prefix `joinFileName` dirRel)\n"++ + " _ | ret < size -> do\n"++ + " exePath <- peekCWString buf\n"++ + " let (bindir,_) = splitFileName exePath\n"++ + " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ + " | otherwise -> try_size (size * 2)\n"++ + "\n"++ + "foreign import " ++ cconv ++ " unsafe \"windows.h GetModuleFileNameW\"\n"++ + " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + where cconv = case arch of + I386 -> "stdcall" + X86_64 -> "ccall" + + +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 = + "minusFileName :: FilePath -> String -> FilePath\n"++ + "minusFileName dir \"\" = dir\n"++ + "minusFileName dir \".\" = dir\n"++ + "minusFileName dir suffix =\n"++ + " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"++ + "\n"++ + "joinFileName :: String -> String -> FilePath\n"++ + "joinFileName \"\" fname = fname\n"++ + "joinFileName \".\" fname = fname\n"++ + "joinFileName dir \"\" = dir\n"++ + "joinFileName dir fname\n"++ + " | isPathSeparator (last dir) = dir++fname\n"++ + " | otherwise = dir++pathSeparator:fname\n"++ + "\n"++ + "splitFileName :: FilePath -> (String, String)\n"++ + "splitFileName p = (reverse (path2++drive), reverse fname)\n"++ + " where\n"++ + " (path,drive) = case p of\n"++ + " (c:':':p') -> (reverse p',[':',c])\n"++ + " _ -> (reverse p ,\"\")\n"++ + " (fname,path1) = break isPathSeparator path\n"++ + " path2 = case path1 of\n"++ + " [] -> \".\"\n"++ + " [_] -> path1 -- don't remove the trailing slash if \n"++ + " -- there is only one character\n"++ + " (c:path') | isPathSeparator c -> path'\n"++ + " _ -> path1\n"++ + "\n"++ + "pathSeparator :: Char\n"++ + (case buildOS of + Windows -> "pathSeparator = '\\\\'\n" + _ -> "pathSeparator = '/'\n") ++ + "\n"++ + "isPathSeparator :: Char -> Bool\n"++ + (case buildOS of + Windows -> "isPathSeparator c = c == '/' || c == '\\\\'\n" + _ -> "isPathSeparator c = c == '/'\n") diff --git a/cabal/Cabal/Distribution/Simple/BuildPaths.hs b/cabal/Cabal/Distribution/Simple/BuildPaths.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/BuildPaths.hs @@ -0,0 +1,150 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.BuildPaths +-- Copyright : Isaac Jones 2003-2004, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- 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, + autogenModulesDir, + + autogenModuleName, + cppHeaderName, + haddockName, + + mkLibName, + mkProfLibName, + mkSharedLibName, + + exeExtension, + objExtension, + dllExtension, + + ) where + + +import System.FilePath ((), (<.>)) + +import Distribution.Package + ( PackageIdentifier, packageName ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Compiler + ( CompilerId(..) ) +import Distribution.PackageDescription (PackageDescription) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir)) +import Distribution.Simple.Setup (defaultDistPref) +import Distribution.Text + ( display ) +import Distribution.System (OS(..), buildOS) + +-- --------------------------------------------------------------------------- +-- Build directories and files + +srcPref :: FilePath -> FilePath +srcPref distPref = distPref "src" + +hscolourPref :: FilePath -> PackageDescription -> FilePath +hscolourPref = haddockPref + +haddockPref :: FilePath -> PackageDescription -> FilePath +haddockPref distPref pkg_descr + = distPref "doc" "html" display (packageName pkg_descr) + +-- |The directory in which we put auto-generated modules +autogenModulesDir :: LocalBuildInfo -> String +autogenModulesDir lbi = buildDir lbi "autogen" + +cppHeaderName :: String +cppHeaderName = "cabal_macros.h" + +-- |The name of the auto-generated module associated with a package +autogenModuleName :: PackageDescription -> ModuleName +autogenModuleName pkg_descr = + ModuleName.fromString $ + "Paths_" ++ map fixchar (display (packageName pkg_descr)) + where fixchar '-' = '_' + fixchar c = c + +haddockName :: PackageDescription -> FilePath +haddockName pkg_descr = display (packageName pkg_descr) <.> "haddock" + +-- --------------------------------------------------------------------------- +-- Library file names + +mkLibName :: PackageIdentifier -> String +mkLibName lib = "libHS" ++ display lib <.> "a" + +mkProfLibName :: PackageIdentifier -> String +mkProfLibName lib = "libHS" ++ display lib ++ "_p" <.> "a" + +-- Implement proper name mangling for dynamical shared objects +-- libHS- +-- e.g. libHSbase-2.1-ghc6.6.1.so +mkSharedLibName :: PackageIdentifier -> CompilerId -> String +mkSharedLibName lib (CompilerId compilerFlavor compilerVersion) + = "libHS" ++ display lib ++ "-" ++ comp <.> dllExtension + where comp = display compilerFlavor ++ display compilerVersion + +-- ------------------------------------------------------------ +-- * Platform file extensions +-- ------------------------------------------------------------ + +-- ToDo: This should be determined via autoconf (AC_EXEEXT) +-- | Extension for executable files +-- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) +exeExtension :: String +exeExtension = case buildOS of + 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. +objExtension :: String +objExtension = "o" + +-- | Extension for dynamically linked (or shared) libraries +-- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows) +dllExtension :: String +dllExtension = case buildOS of + Windows -> "dll" + OSX -> "dylib" + _ -> "so" diff --git a/cabal/Cabal/Distribution/Simple/Command.hs b/cabal/Cabal/Distribution/Simple/Command.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Command.hs @@ -0,0 +1,555 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Command +-- Copyright : Duncan Coutts 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is to do with command line handling. The Cabal command line is +-- organised into a number of named sub-commands (much like darcs). The +-- 'CommandUI' abstraction represents one of these sub-commands, with a name, +-- description, a set of flags. Commands can be associated with actions and +-- run. It handles some common stuff automatically, like the @--help@ and +-- 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 + CommandUI(..), + commandShowOptions, + CommandParse(..), + commandParseArgs, + + -- ** Constructing commands + ShowOrParseArgs(..), + makeCommand, + hiddenCommand, + + -- ** Associating actions with commands + Command, + commandAddAction, + noExtraFlags, + + -- ** Running commands + commandsRun, + +-- * Option Fields + OptionField(..), Name, + +-- ** Constructing Option Fields + option, multiOption, + +-- ** Liftings & Projections + liftOption, viewAsFieldDescr, + +-- * Option Descriptions + OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder, + +-- ** OptDescr 'smart' constructors + MkOptDescr, + reqArg, reqArg', optArg, optArg', noArg, + boolOpt, boolOpt', choiceOpt, choiceOptFromEnum + + ) where + +import Control.Monad +import Data.Char (isAlpha, toLower) +import Data.List (sortBy) +import Data.Maybe +import Data.Monoid +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) + +data CommandUI flags = CommandUI { + -- | The name of the command as it would be entered on the command line. + -- For example @\"build\"@. + commandName :: String, + -- | A short, one line description of the command to use in help texts. + commandSynopsis :: String, + -- | The useage line summary for this command + commandUsage :: String -> String, + -- | Additional explanation of the command to use in help texts. + commandDescription :: Maybe (String -> String), + -- | Initial \/ empty flags + commandDefaultFlags :: flags, + -- | All the Option fields for this command + commandOptions :: ShowOrParseArgs -> [OptionField flags] + } + +data ShowOrParseArgs = ShowArgs | ParseArgs +type Name = String +type Description = String + +-- | We usually have a datatype 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. +data OptionField a = OptionField { + optionName :: Name, + optionDescr :: [OptDescr a] } + +-- | An OptionField takes one or more OptDescrs, describing the command line interface for the field. +data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a -> [String]) + | OptArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a->a) (a -> [Maybe String]) + | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)] + | BoolOpt Description OptFlags{-True-} OptFlags{-False-} (Bool -> a -> a) (a-> Maybe Bool) + +-- | Short command line option strings +type SFlags = [Char] +-- | Long command line option strings +type LFlags = [String] +type OptFlags = (SFlags,LFlags) +type ArgPlaceHolder = String + + +-- | Create an option taking a single OptDescr. +-- No explicit Name is given for the Option, the name is the first LFlag given. +option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a -> OptionField a +option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set] +option _ _ _ _ _ _ = error "Distribution.command.option: An OptionField must have at least one LFlag" + +-- | Create an option taking several OptDescrs. +-- You will have to give the flags and description individually to the OptDescr constructor. +multiOption :: Name -> get -> set + -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially applied to flags and description. + -> OptionField a +multiOption n get set args = OptionField n [arg get set | arg <- args] + +type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set -> OptDescr a + +-- | Create a string-valued command line interface. +reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg ad mkflag showflag sf lf d get set = + ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) (showflag . get) + +-- | Create a string-valued command line interface with a default value. +optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArg ad mkflag def showflag sf lf d get set = + OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) + (\b -> set (get b `mappend` def) b) + (showflag . get) + +-- | (String -> a) variant of "reqArg" +reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg' ad mkflag showflag = + reqArg ad (succeedReadE mkflag) showflag + +-- | (String -> a) variant of "optArg" +optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArg' ad mkflag showflag = + 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 flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d + +boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt g s sfT sfF _sf _lf@(n:_) d get set = + BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get) +boolOpt _ _ _ _ _ _ _ _ _ = error "Distribution.Simple.Setup.boolOpt: unreachable" + +boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get) + +-- | create a Choice option +choiceOpt :: Eq b => [(b,OptFlags,Description)] -> MkOptDescr (a -> b) (b -> a -> a) a +choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts + where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff] + +-- | create a Choice option out of an enumeration type. +-- As long flags, the Show output is used. As short flags, the first character +-- which does not conflict with a previous one is used. +choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => MkOptDescr (a -> b) (b -> a -> a) a +choiceOptFromEnum _sf _lf d get = choiceOpt [ (x, (sf, [map toLower $ show x]), d') + | (x, sf) <- sflags' + , let d' = d ++ show x] + _sf _lf d get + where sflags' = foldl f [] [firstOne..] + f prev x = let prevflags = concatMap snd prev in + prev ++ take 1 [(x, [toLower sf]) | sf <- show x, isAlpha sf + , toLower sf `notElem` prevflags] + firstOne = minBound `asTypeOf` get undefined + +commandGetOpts :: ShowOrParseArgs -> CommandUI flags -> [GetOpt.OptDescr (flags -> flags)] +commandGetOpts showOrParse command = + concatMap viewAsGetOpt (commandOptions command showOrParse) + +viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)] +viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa + where + optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) = + [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d] + where set' = readEOrFail set + optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) = + [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d] + where set' Nothing = def + 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 _) = + [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) + , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ] + +-- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > Choice > Opt) and consider only the first one. +viewAsFieldDescr :: OptionField a -> FieldDescr a +viewAsFieldDescr (OptionField _n []) = error "Distribution.command.viewAsFieldDescr: unexpected" +viewAsFieldDescr (OptionField n dd) = FieldDescr n get set + where optDescr = head $ sortBy cmp dd + ReqArg{} `cmp` ReqArg{} = EQ + ReqArg{} `cmp` _ = GT + BoolOpt{} `cmp` ReqArg{} = LT + BoolOpt{} `cmp` BoolOpt{} = EQ + BoolOpt{} `cmp` _ = GT + ChoiceOpt{} `cmp` ReqArg{} = LT + ChoiceOpt{} `cmp` BoolOpt{} = LT + ChoiceOpt{} `cmp` ChoiceOpt{} = EQ + ChoiceOpt{} `cmp` _ = GT + OptArg{} `cmp` OptArg{} = EQ + OptArg{} `cmp` _ = LT + get t = case optDescr of + ReqArg _ _ _ _ ppr -> + (cat . punctuate comma . map text . ppr) t + OptArg _ _ _ _ _ ppr -> + case ppr t of + [] -> empty + (Nothing : _) -> text "True" + (Just a : _) -> text a + ChoiceOpt alts -> + fromMaybe empty $ listToMaybe + [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t] + BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t + set line val a = + case optDescr of + ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val + -- We parse for a single value instead of a list, + -- as one can't really implement parseList :: ReadE a -> ReadE [a] + -- with the current ReadE definition + ChoiceOpt{} -> case getChoiceByLongFlag optDescr val of + Just f -> return (f a) + _ -> syntaxError line val + BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runP line n parse val + OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val + -- Optional arguments are parsed just like required arguments here; + -- we don't provide a method to set an OptArg field to the default value. + +getChoiceByLongFlag :: OptDescr b -> String -> Maybe (b->b) +getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe [ set | (_,(_sf,lf:_), set, _) <- alts + , lf == val] + +getChoiceByLongFlag _ _ = error "Distribution.command.getChoiceByLongFlag: expected a choice option" + +getCurrentChoice :: OptDescr a -> a -> [String] +getCurrentChoice (ChoiceOpt alts) a = + [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a] + +getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr" + + +liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b +liftOption get' set' opt = opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt} + + +liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b +liftOptDescr get' set' (ChoiceOpt opts) = + ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get')) + | (d, ff, set, get) <- opts] + +liftOptDescr get' set' (OptArg d ff ad set def get) = + OptArg d ff ad (liftSet get' set' `fmap` set) (liftSet get' set' def) (get . get') + +liftOptDescr get' set' (ReqArg d ff ad set get) = + ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') + +liftOptDescr get' set' (BoolOpt d ffT ffF set get) = + BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') + +liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b +liftSet get' set' set x = set' (set $ get' x) x + +-- | Show flags in the standard long option command line format +commandShowOptions :: CommandUI flags -> flags -> [String] +commandShowOptions command v = concat + [ showOptDescr v od | o <- commandOptions command ParseArgs + , od <- optionDescr o] + where + showOptDescr :: a -> OptDescr a -> [String] + showOptDescr x (BoolOpt _ (_,lfT:_) (_,lfF:_) _ enabled) + = case enabled x of + Nothing -> [] + Just True -> ["--" ++ lfT] + Just False -> ["--" ++ lfF] + showOptDescr x c@ChoiceOpt{} + = ["--" ++ val | val <- getCurrentChoice c x] + showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag) + = [ "--"++lf++"="++flag + | flag <- showflag x ] + showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag) + = [ case flag of + Just s -> "--"++lf++"="++s + Nothing -> "--"++lf + | flag <- showflag x ] + showOptDescr _ _ + = error "Distribution.Simple.Command.showOptDescr: unreachable" + + +commandListOptions :: CommandUI flags -> [String] +commandListOptions command = + concatMap listOption $ + addCommonFlags ShowArgs $ -- This is a slight hack, we don't want + -- "--list-options" showing up in the + -- list options output, so use ShowArgs + commandGetOpts ShowArgs command + where + listOption (GetOpt.Option shortNames longNames _ _) = + [ "-" ++ [name] | name <- shortNames ] + ++ [ "--" ++ name | name <- longNames ] + +-- | 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 + +-- | Make a Command from standard 'GetOpt' options. +makeCommand :: String -- ^ name + -> String -- ^ short description + -> Maybe (String -> String) -- ^ long description + -> 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 + } + where usage pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" + ++ "Flags for " ++ name ++ ":" + +-- | Common flags that apply to every command +data CommonFlag = HelpFlag | ListOptionsFlag + +commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag] +commonFlags showOrParseArgs = case showOrParseArgs of + ShowArgs -> [help] + ParseArgs -> [help, list] + where + help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag) + "Show this help text" + helpShortFlags = case showOrParseArgs of + ShowArgs -> ['h'] + ParseArgs -> ['h', '?'] + list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag) + "Print a list of command line flags" + +addCommonFlags :: ShowOrParseArgs + -> [GetOpt.OptDescr a] + -> [GetOpt.OptDescr (Either CommonFlag a)] +addCommonFlags showOrParseArgs options = + map (fmapOptDesc Left) (commonFlags showOrParseArgs) + ++ map (fmapOptDesc Right) options + where fmapOptDesc f (GetOpt.Option s l d m) = + GetOpt.Option s l (fmapArgDesc f d) m + fmapArgDesc f (GetOpt.NoArg a) = GetOpt.NoArg (f a) + fmapArgDesc f (GetOpt.ReqArg s d) = GetOpt.ReqArg (f . s) d + fmapArgDesc f (GetOpt.OptArg s d) = GetOpt.OptArg (f . s) d + +-- | Parse a bunch of command line arguments +-- +commandParseArgs :: CommandUI flags + -> Bool -- ^ Is the command a global or subcommand? + -> [String] + -> CommandParse (flags -> flags, [String]) +commandParseArgs command global args = + let options = addCommonFlags ParseArgs + $ commandGetOpts ParseArgs command + order | global = GetOpt.RequireOrder + | otherwise = GetOpt.Permute + in case GetOpt.getOpt' order options args of + (flags, _, _, _) + | any listFlag flags -> CommandList (commandListOptions command) + | any helpFlag flags -> CommandHelp (commandHelp command) + where listFlag (Left ListOptionsFlag) = True; listFlag _ = False + helpFlag (Left HelpFlag) = True; helpFlag _ = False + (flags, opts, opts', []) + | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') + | otherwise -> CommandErrors (unrecognised opts') + (_, _, _, errs) -> CommandErrors errs + + 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. + accum flags = foldr (flip (.)) id [ f | Right f <- flags ] + unrecognised opts = [ "unrecognized 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 + -- as sub-command rather than global flags. + mix [] ys = ys + mix (x:xs) ys = x:ys++xs + +data CommandParse flags = CommandHelp (String -> String) + | CommandList [String] + | CommandErrors [String] + | CommandReadyToGo flags +instance Functor CommandParse where + fmap _ (CommandHelp help) = CommandHelp help + fmap _ (CommandList opts) = CommandList opts + fmap _ (CommandErrors errs) = CommandErrors errs + fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags) + + +data CommandType = NormalCommand | HiddenCommand +data Command action = + Command String String ([String] -> CommandParse action) CommandType + +-- | Mark command as hidden. Hidden commands don't show up in the 'progname +-- help' or 'progname --help' output. +hiddenCommand :: Command action -> Command action +hiddenCommand (Command name synopsys f _cmdType) = + Command name synopsys f HiddenCommand + +commandAddAction :: CommandUI flags + -> (flags -> [String] -> action) + -> Command action +commandAddAction command action = + Command (commandName command) + (commandSynopsis command) + (fmap (uncurry applyDefaultArgs) . commandParseArgs command False) + NormalCommand + + where applyDefaultArgs mkflags args = + let flags = mkflags (commandDefaultFlags command) + in action flags args + +commandsRun :: CommandUI a + -> [Command action] + -> [String] + -> CommandParse (a, CommandParse action) +commandsRun globalCommand commands args = + case commandParseArgs globalCommand' True args of + CommandHelp help -> CommandHelp help + CommandList opts -> CommandList (opts ++ commandNames) + CommandErrors errs -> CommandErrors errs + CommandReadyToGo (mkflags, args') -> case args' of + ("help":cmdArgs) -> handleHelpCommand cmdArgs + (name:cmdArgs) -> case lookupCommand name of + [Command _ _ action _] + -> CommandReadyToGo (flags, action cmdArgs) + _ -> CommandReadyToGo (flags, badCommand name) + [] -> CommandReadyToGo (flags, noCommand) + where flags = mkflags (commandDefaultFlags globalCommand) + + where + lookupCommand cname = [ cmd | cmd@(Command cname' _ _ _) <- commands' + , cname' == cname ] + noCommand = CommandErrors ["no command given (try --help)\n"] + badCommand cname = CommandErrors ["unrecognised command: " ++ cname + ++ " (try --help)\n"] + commands' = commands ++ [commandAddAction helpCommandUI undefined] + commandNames = [ name | (Command name _ _ _) <- 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" + handleHelpCommand cmdArgs = + case commandParseArgs helpCommandUI True cmdArgs of + CommandHelp help -> CommandHelp help + CommandList list -> CommandList (list ++ commandNames) + CommandErrors _ -> CommandHelp globalHelp + CommandReadyToGo (_,[]) -> CommandHelp globalHelp + CommandReadyToGo (_,(name:cmdArgs')) -> + case lookupCommand name of + [Command _ _ action _] -> + case action ("--help":cmdArgs') of + CommandHelp help -> CommandHelp help + CommandList _ -> CommandList [] + _ -> 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:" + } + +-- | Utility function, many commands do not accept additional flags. This +-- action fails with a helpful error message if the user supplies any extra. +-- +noExtraFlags :: [String] -> IO () +noExtraFlags [] = return () +noExtraFlags extraFlags = + 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] diff --git a/cabal/Cabal/Distribution/Simple/Compiler.hs b/cabal/Cabal/Distribution/Simple/Compiler.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Compiler.hs @@ -0,0 +1,194 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Compiler +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This should be a much more sophisticated abstraction than it is. Currently +-- it's just a bit of data about the compiler, like it's flavour and name and +-- version. The reason it's just data is because currently it has to be in +-- 'Read' and 'Show' so it can be saved along with the 'LocalBuildInfo'. The +-- only interesting bit of info it contains is a mapping between language +-- extensions and compiler command line flags. This module also defines a +-- 'PackageDB' type which is used to refer to package databases. Most compilers +-- only know about a single global package collection but GHC has a global and +-- 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, + + -- * Support for package databases + PackageDB(..), + PackageDBStack, + registrationPackageDB, + + -- * Support for optimisation levels + OptimisationLevel(..), + flagToOptimisationLevel, + + -- * Support for language extensions + Flag, + languageToFlags, + unsupportedLanguages, + extensionsToFlags, + unsupportedExtensions + ) where + +import Distribution.Compiler +import Distribution.Version (Version(..)) +import Distribution.Text (display) +import Language.Haskell.Extension (Language(Haskell98), Extension) + +import Data.List (nub) +import Data.Maybe (catMaybes, isNothing) + +data Compiler = Compiler { + compilerId :: CompilerId, + compilerLanguages :: [(Language, Flag)], + compilerExtensions :: [(Extension, Flag)] + } + deriving (Show, Read) + +showCompilerId :: Compiler -> String +showCompilerId = display . compilerId + +compilerFlavor :: Compiler -> CompilerFlavor +compilerFlavor = (\(CompilerId f _) -> f) . compilerId + +compilerVersion :: Compiler -> Version +compilerVersion = (\(CompilerId _ v) -> v) . compilerId + +-- ------------------------------------------------------------ +-- * Package databases +-- ------------------------------------------------------------ + +-- |Some compilers have a notion of a database of available packages. +-- For some there is just one global db of packages, other compilers +-- support a per-user or an arbitrary db specified at some location in +-- the file system. This can be used to build isloated environments of +-- packages, for example to build a collection of related packages +-- without installing them globally. +-- +data PackageDB = GlobalPackageDB + | UserPackageDB + | SpecificPackageDB FilePath + deriving (Eq, Ord, Show, Read) + +-- | 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: +-- +-- > [GlobalPackageDB] +-- > [GlobalPackageDB, UserPackageDB] +-- > [GlobalPackageDB, SpecificPackageDB "package.conf.inplace"] +-- +-- Note that the 'GlobalPackageDB' is invariably at the bottom since it +-- contains the rts, base and other special compiler-specific packages. +-- +-- We are not restricted to using just the above combinations. In particular +-- we can use several custom package dbs and the user package db together. +-- +-- When it comes to writing, the top most (last) package is used. +-- +type PackageDBStack = [PackageDB] + +-- | Return the package that we should register into. This is the package db at +-- the top of the stack. +-- +registrationPackageDB :: PackageDBStack -> PackageDB +registrationPackageDB [] = error "internal error: empty package db set" +registrationPackageDB dbs = last dbs + +-- ------------------------------------------------------------ +-- * Optimisation levels +-- ------------------------------------------------------------ + +-- | Some compilers support optimising. Some have different levels. +-- For compliers 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) + +flagToOptimisationLevel :: Maybe String -> OptimisationLevel +flagToOptimisationLevel Nothing = NormalOptimisation +flagToOptimisationLevel (Just s) = case reads s of + [(i, "")] + | i >= fromEnum (minBound :: OptimisationLevel) + && i <= fromEnum (maxBound :: OptimisationLevel) + -> toEnum i + | otherwise -> error $ "Bad optimisation level: " ++ show i + ++ ". Valid values are 0..2" + _ -> error $ "Can't parse optimisation level " ++ s + +-- ------------------------------------------------------------ +-- * Languages and Extensions +-- ------------------------------------------------------------ + +unsupportedLanguages :: Compiler -> [Language] -> [Language] +unsupportedLanguages comp langs = + [ lang | lang <- langs + , isNothing (languageToFlag comp lang) ] + +languageToFlags :: Compiler -> Maybe Language -> [Flag] +languageToFlags comp = filter (not . null) + . catMaybes . map (languageToFlag comp) + . maybe [Haskell98] (\x->[x]) + +languageToFlag :: Compiler -> Language -> Maybe Flag +languageToFlag comp ext = lookup ext (compilerLanguages comp) + + +-- |For the given compiler, return the extensions it does not support. +unsupportedExtensions :: Compiler -> [Extension] -> [Extension] +unsupportedExtensions comp exts = + [ ext | ext <- exts + , isNothing (extensionToFlag comp ext) ] + +type Flag = String + +-- |For the given compiler, return the flags for the supported extensions. +extensionsToFlags :: Compiler -> [Extension] -> [Flag] +extensionsToFlags comp = nub . filter (not . null) + . catMaybes . map (extensionToFlag comp) + +extensionToFlag :: Compiler -> Extension -> Maybe Flag +extensionToFlag comp ext = lookup ext (compilerExtensions comp) diff --git a/cabal/Cabal/Distribution/Simple/Configure.hs b/cabal/Cabal/Distribution/Simple/Configure.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Configure.hs @@ -0,0 +1,1083 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Configure +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This deals with the /configure/ phase. It provides the 'configure' action +-- which is given the package description and configure flags. It then tries +-- to: configure the compiler; resolves any conditionals in the package +-- description; resolve the package dependencies; check if all the extensions +-- used by this package are supported by the compiler; check that all the build +-- tools are available (including version checks if appropriate); checks for +-- any required @pkg-config@ packages (updating the 'BuildInfo' with the +-- results) +-- +-- Then based on all this it saves the info in the 'LocalBuildInfo' and writes +-- it out to the @dist\/setup-config@ file. It also displays various details to +-- the user, the amount of information displayed depending on the verbosity +-- level. + +{- 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, + getPersistBuildConfig, + checkPersistBuildConfigOutdated, + maybeGetPersistBuildConfig, + localBuildInfoFile, + getInstalledPackages, + configCompiler, configCompilerAux, + ccLdOptionsBuildInfo, + tryGetConfigStateFile, + checkForeignDeps, + interpretPackageDbFlags, + ) + where + +import Distribution.Simple.Compiler + ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion + , showCompilerId, unsupportedLanguages, unsupportedExtensions + , PackageDB(..), PackageDBStack ) +import Distribution.Package + ( PackageName(PackageName), PackageIdentifier(..), PackageId + , packageName, packageVersion, Package(..) + , Dependency(Dependency), simplifyDependency + , InstalledPackageId(..) ) +import Distribution.InstalledPackageInfo as Installed + ( InstalledPackageInfo, InstalledPackageInfo_(..) + , emptyInstalledPackageInfo ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.PackageDescription as PD + ( PackageDescription(..), specVersion, GenericPackageDescription(..) + , Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions + , HookedBuildInfo, updatePackageDescription, allBuildInfo + , FlagName(..), TestSuite(..), Benchmark(..) ) +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 + , configureAllKnownPrograms, knownPrograms, lookupKnownProgram + , userSpecifyArgss, userSpecifyPaths + , requireProgram, requireProgramVersion + , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf ) +import Distribution.Simple.Setup + ( ConfigFlags(..), CopyDest(..), fromFlag, fromFlagOrDefault, flagToMaybe ) +import Distribution.Simple.InstallDirs + ( InstallDirs(..), defaultInstallDirs, combineInstallDirs ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) + , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId + , allComponentsBy, Component(..), foldComponent, ComponentName(..) ) +import Distribution.Simple.BuildPaths + ( autogenModulesDir ) +import Distribution.Simple.Utils + ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose + , intercalate, cabalVersion + , withFileContents, writeFileAtomic + , withTempFile ) +import Distribution.System + ( OS(..), buildOS, Arch(..), buildArch, 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 Control.Monad + ( when, unless, foldM, filterM, forM ) +import Data.List + ( nub, partition, isPrefixOf, inits, find ) +import Data.Maybe + ( isNothing, catMaybes, mapMaybe ) +import Data.Monoid + ( Monoid(..) ) +import Data.Graph + ( SCC(..), graphFromEdges, transposeG, vertices, stronglyConnCompR ) +import System.Directory + ( doesFileExist, getModificationTime, createDirectoryIfMissing, getTemporaryDirectory ) +import System.Exit + ( ExitCode(..), exitWith ) +import System.FilePath + ( (), isAbsolute ) +import qualified System.Info + ( compilerName, compilerVersion ) +import System.IO + ( hPutStrLn, stderr, hClose ) +import Distribution.Text + ( Text(disp), display, simpleParse ) +import Text.PrettyPrint + ( comma, punctuate, render, nest, sep ) +import Distribution.Compat.Exception ( catchExit, catchIO ) + +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 + +tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a) +tryGetConfigStateFile filename = do + exists <- doesFileExist filename + if not exists + then return (Left missing) + else withFileContents filename $ \str -> + case lines str of + [headder, rest] -> case checkHeader headder of + Just msg -> return (Left msg) + Nothing -> case reads rest of + [(bi,_)] -> return (Right bi) + _ -> return (Left cantParse) + _ -> return (Left cantParse) + where + checkHeader :: String -> Maybe String + checkHeader header = case parseHeader header of + Just (cabalId, compId) + | cabalId + == currentCabalId -> Nothing + | otherwise -> Just (badVersion cabalId compId) + Nothing -> Just cantParse + + 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." + +-- internal function +tryGetPersistBuildConfig :: FilePath -> IO (Either String LocalBuildInfo) +tryGetPersistBuildConfig distPref + = tryGetConfigStateFile (localBuildInfoFile distPref) + +-- |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 return lbi + +-- |Try to read the 'localBuildInfoFile'. +maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo) +maybeGetPersistBuildConfig distPref = do + lbi <- tryGetPersistBuildConfig distPref + return $ either (const Nothing) Just lbi + +-- |After running configure, output the 'LocalBuildInfo' to the +-- 'localBuildInfoFile'. +writePersistBuildConfig :: FilePath -> LocalBuildInfo -> 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 + where + +currentCabalId :: PackageIdentifier +currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion + +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 + +-- |Check that localBuildInfoFile is up-to-date with respect to the +-- .cabal file. +checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool +checkPersistBuildConfigOutdated distPref pkg_descr_file = do + t0 <- getModificationTime pkg_descr_file + t1 <- getModificationTime $ localBuildInfoFile distPref + return (t0 > t1) + +-- |@dist\/setup-config@ +localBuildInfoFile :: FilePath -> FilePath +localBuildInfoFile distPref = distPref "setup-config" + +-- ----------------------------------------------------------------------------- +-- * Configuration +-- ----------------------------------------------------------------------------- + +-- |Perform the \"@.\/setup configure@\" action. +-- Returns the @.setup-config@ file. +configure :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags -> IO LocalBuildInfo +configure (pkg_descr0, pbi) cfg + = do let distPref = fromFlag (configDistPref cfg) + buildDir' = distPref "build" + verbosity = fromFlag (configVerbosity cfg) + + setupMessage verbosity "Configuring" (packageId pkg_descr0) + + createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref + + let programsConfig = userSpecifyArgss (configProgramArgs cfg) + . userSpecifyPaths (configProgramPaths cfg) + $ configPrograms cfg + userInstall = fromFlag (configUserInstall cfg) + packageDbs = interpretPackageDbFlags userInstall + (configPackageDBs cfg) + + -- detect compiler + (comp, programsConfig') <- configCompiler + (flagToMaybe $ configHcFlavor cfg) + (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg) + programsConfig (lessVerbose verbosity) + let version = compilerVersion comp + flavor = compilerFlavor comp + + -- Create a PackageIndex that makes *any libraries that might be* + -- defined internally to this package look like installed packages, in + -- case an executable should refer to any of them as dependencies. + -- + -- It must be *any libraries that might be* defined rather than the + -- actual definitions, because these depend on conditionals in the .cabal + -- file, and we haven't resolved them yet. finalizePackageDescription + -- does the resolution of conditionals, and it takes internalPackageSet + -- as part of its input. + -- + -- Currently a package can define no more than one library (which has + -- the same name as the package) but we could extend this later. + -- If we later allowed private internal libraries, then here we would + -- need to pre-scan the conditional data to make a list of all private + -- libraries that could possibly be defined by the .cabal file. + let pid = packageId pkg_descr0 + internalPackage = emptyInstalledPackageInfo { + --TODO: should use a per-compiler method to map the source + -- package ID into an installed package id we can use + -- for the internal package set. The open-codes use of + -- InstalledPackageId . display here is a hack. + Installed.installedPackageId = InstalledPackageId $ display $ pid, + Installed.sourcePackageId = pid + } + internalPackageSet = PackageIndex.fromList [internalPackage] + installedPackageSet <- getInstalledPackages (lessVerbose verbosity) comp + packageDbs programsConfig' + + let -- Constraint test function for the solver + dependencySatisfiable = + not . null . PackageIndex.lookupDependency pkgs' + where + pkgs' = PackageIndex.insert internalPackage installedPackageSet + enableTest t = t { testEnabled = fromFlag (configTests cfg) } + flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t)) + (condTestSuites pkg_descr0) + enableBenchmark bm = bm { benchmarkEnabled = fromFlag (configBenchmarks cfg) } + flaggedBenchmarks = map (\(n, bm) -> (n, mapTreeData enableBenchmark bm)) + (condBenchmarks pkg_descr0) + pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests + , condBenchmarks = flaggedBenchmarks } + + (pkg_descr0', flags) <- + case finalizePackageDescription + (configConfigurationsFlags cfg) + dependencySatisfiable + Distribution.System.buildPlatform + (compilerId comp) + (configConstraints cfg) + pkg_descr0'' + of Right r -> return r + Left missing -> + die $ "At least the following dependencies are missing:\n" + ++ (render . nest 4 . sep . punctuate comma + . map (disp . simplifyDependency) + $ missing) + + -- add extra include/lib dirs as specified in cfg + -- we do it here so that those get checked too + let pkg_descr = + enableCoverage (fromFlag (configLibCoverage cfg)) distPref + $ addExtraIncludeLibDirs pkg_descr0' + + when (not (null flags)) $ + info verbosity $ "Flags chosen: " + ++ intercalate ", " [ name ++ "=" ++ display value + | (FlagName name, value) <- flags ] + + checkPackageProblems verbosity pkg_descr0 + (updatePackageDescription pbi pkg_descr) + + let selectDependencies = + (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ])) + . map (selectDependency internalPackageSet installedPackageSet) + + (failedDeps, allPkgDeps) = selectDependencies (buildDepends pkg_descr) + + internalPkgDeps = [ pkgid | InternalDependency _ pkgid <- allPkgDeps ] + externalPkgDeps = [ pkg | ExternalDependency _ pkg <- allPkgDeps ] + + when (not (null internalPkgDeps) && not (newPackageDepsBehaviour pkg_descr)) $ + die $ "The field 'build-depends: " + ++ intercalate ", " (map (display . packageName) internalPkgDeps) + ++ "' refers to a library which is defined within the same " + ++ "package. To use this feature the package must specify at " + ++ "least 'cabal-version: >= 1.8'." + + reportFailedDependencies failedDeps + reportSelectedDependencies verbosity allPkgDeps + + packageDependsIndex <- + case PackageIndex.dependencyClosure installedPackageSet + (map Installed.installedPackageId externalPkgDeps) of + Left packageDependsIndex -> return packageDependsIndex + Right broken -> + die $ "The following installed packages are broken because other" + ++ " packages they depend on are missing. These broken " + ++ "packages must be rebuilt before they can be used.\n" + ++ unlines [ "package " + ++ display (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map display deps) + | (pkg, deps) <- broken ] + + let pseudoTopPkg = emptyInstalledPackageInfo { + Installed.installedPackageId = InstalledPackageId (display (packageId pkg_descr)), + Installed.sourcePackageId = packageId pkg_descr, + Installed.depends = map Installed.installedPackageId externalPkgDeps + } + case PackageIndex.dependencyInconsistencies + . PackageIndex.insert pseudoTopPkg + $ packageDependsIndex of + [] -> return () + inconsistencies -> + warn verbosity $ + "This package indirectly depends on multiple versions of the same " + ++ "package. This is highly likely to cause a compile failure.\n" + ++ unlines [ "package " ++ display pkg ++ " requires " + ++ display (PackageIdentifier name ver) + | (name, uses) <- inconsistencies + , (pkg, ver) <- uses ] + + -- installation directories + defaultDirs <- defaultInstallDirs flavor userInstall (hasLibs pkg_descr) + let installDirs = combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs cfg) + + -- check languages and extensions + let langlist = nub $ catMaybes $ map defaultLanguage (allBuildInfo pkg_descr) + let langs = unsupportedLanguages comp langlist + when (not (null langs)) $ + die $ "The package " ++ display (packageId pkg_descr0) + ++ " requires the following languages which are not " + ++ "supported by " ++ display (compilerId comp) ++ ": " + ++ intercalate ", " (map display langs) + let extlist = nub $ concatMap allExtensions (allBuildInfo pkg_descr) + let exts = unsupportedExtensions comp extlist + when (not (null exts)) $ + die $ "The package " ++ display (packageId pkg_descr0) + ++ " requires the following language extensions which are not " + ++ "supported by " ++ display (compilerId comp) ++ ": " + ++ intercalate ", " (map display exts) + + -- configured known/required programs & external build tools + -- exclude build-tool deps on "internal" exes in the same package + let requiredBuildTools = + [ buildTool + | let exeNames = map exeName (executables pkg_descr) + , bi <- allBuildInfo pkg_descr + , buildTool@(Dependency (PackageName toolName) reqVer) <- buildTools bi + , let isInternal = + toolName `elem` exeNames + -- we assume all internal build-tools are + -- versioned with the package: + && packageVersion pkg_descr `withinRange` reqVer + , not isInternal ] + + programsConfig'' <- + configureAllKnownPrograms (lessVerbose verbosity) programsConfig' + >>= configureRequiredPrograms verbosity requiredBuildTools + + (pkg_descr', programsConfig''') <- + configurePkgconfigPackages verbosity pkg_descr programsConfig'' + + split_objs <- + if not (fromFlag $ configSplitObjs cfg) + then return False + else case flavor of + GHC | version >= Version [6,5] [] -> return True + _ -> do warn verbosity + ("this compiler does not support " ++ + "--enable-split-objs; ignoring") + return False + + -- The allPkgDeps contains all the package deps for the whole package + -- but we need to select the subset for this specific component. + -- we just take the subset for the package names this component + -- needs. Note, this only works because we cannot yet depend on two + -- versions of the same package. + let configLib lib = configComponent (libBuildInfo lib) + configExe exe = (exeName exe, configComponent (buildInfo exe)) + configTest test = (testName test, + configComponent(testBuildInfo test)) + configBenchmark bm = (benchmarkName bm, + configComponent(benchmarkBuildInfo bm)) + configComponent bi = ComponentLocalBuildInfo { + componentPackageDeps = + if newPackageDepsBehaviour pkg_descr' + then [ (installedPackageId pkg, packageId pkg) + | pkg <- selectSubset bi externalPkgDeps ] + ++ [ (inplacePackageId pkgid, pkgid) + | pkgid <- selectSubset bi internalPkgDeps ] + else [ (installedPackageId pkg, packageId pkg) + | pkg <- externalPkgDeps ] + } + selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg] + selectSubset bi pkgs = + [ pkg | pkg <- pkgs, packageName pkg `elem` names ] + where + names = [ name | Dependency name _ <- targetBuildDepends bi ] + + -- Obtains the intrapackage dependencies for the given component + let ipDeps component = + mapMaybe exeDepToComp (buildTools bi) + ++ mapMaybe libDepToComp (targetBuildDepends bi) + where + bi = foldComponent libBuildInfo buildInfo testBuildInfo + benchmarkBuildInfo component + exeDepToComp (Dependency (PackageName name) _) = + CExe `fmap` find ((==) name . exeName) + (executables pkg_descr') + libDepToComp (Dependency pn _) + | pn `elem` map packageName internalPkgDeps = + CLib `fmap` library pkg_descr' + libDepToComp _ = Nothing + + let sccs = (stronglyConnCompR . map lkup . vertices . transposeG) g + where (g, lkup, _) = graphFromEdges + $ allComponentsBy pkg_descr' + $ \c -> (c, key c, map key (ipDeps c)) + key = foldComponent (const "library") exeName + testName benchmarkName + + -- check for cycles in the dependency graph + buildOrder <- forM sccs $ \scc -> case scc of + AcyclicSCC (c,_,_) -> return (foldComponent (const CLibName) + (CExeName . exeName) + (CTestName . testName) + (CBenchName . benchmarkName) + c) + CyclicSCC vs -> + die $ "Found cycle in intrapackage dependency graph:\n " + ++ intercalate " depends on " + (map (\(_,k,_) -> "'" ++ k ++ "'") (vs ++ [head vs])) + + let lbi = LocalBuildInfo { + configFlags = cfg, + extraConfigArgs = [], -- Currently configure does not + -- take extra args, but if it + -- did they would go here. + installDirTemplates = installDirs, + compiler = comp, + buildDir = buildDir', + scratchDir = fromFlagOrDefault + (distPref "scratch") + (configScratchDir cfg), + libraryConfig = configLib `fmap` library pkg_descr', + executableConfigs = configExe `fmap` executables pkg_descr', + testSuiteConfigs = configTest `fmap` testSuites pkg_descr', + benchmarkConfigs = configBenchmark `fmap` benchmarks pkg_descr', + compBuildOrder = buildOrder, + installedPkgs = packageDependsIndex, + pkgDescrFile = Nothing, + localPkgDescr = pkg_descr', + withPrograms = programsConfig''', + withVanillaLib = fromFlag $ configVanillaLib cfg, + withProfLib = fromFlag $ configProfLib cfg, + withSharedLib = fromFlag $ configSharedLib cfg, + withDynExe = fromFlag $ configDynExe cfg, + withProfExe = fromFlag $ configProfExe cfg, + withOptimization = fromFlag $ configOptimization cfg, + withGHCiLib = fromFlag $ configGHCiLib cfg, + splitObjs = split_objs, + stripExes = fromFlag $ configStripExes cfg, + withPackageDB = packageDbs, + progPrefix = fromFlag $ configProgPrefix cfg, + progSuffix = fromFlag $ configProgSuffix cfg + } + + let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest + relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi + + unless (isAbsolute (prefix dirs)) $ die $ + "expected an absolute directory name for --prefix: " ++ prefix dirs + + info verbosity $ "Using " ++ display currentCabalId + ++ " compiled by " ++ display currentCompilerId + info verbosity $ "Using compiler: " ++ showCompilerId comp + info verbosity $ "Using install prefix: " ++ prefix dirs + + let dirinfo name dir isPrefixRelative = + info verbosity $ name ++ " installed in: " ++ dir ++ relNote + where relNote = case buildOS of + Windows | not (hasLibs pkg_descr) + && isNothing isPrefixRelative + -> " (fixed location)" + _ -> "" + + dirinfo "Binaries" (bindir dirs) (bindir relative) + dirinfo "Libraries" (libdir dirs) (libdir relative) + dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative) + dirinfo "Data files" (datadir dirs) (datadir relative) + dirinfo "Documentation" (docdir dirs) (docdir relative) + + sequence_ [ reportProgram verbosity prog configuredProg + | (prog, configuredProg) <- knownPrograms programsConfig''' ] + + return lbi + + where + addExtraIncludeLibDirs pkg_descr = + let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg + , PD.includeDirs = configExtraIncludeDirs cfg} + modifyLib l = l{ libBuildInfo = libBuildInfo l `mappend` extraBi } + modifyExecutable e = e{ buildInfo = buildInfo e `mappend` extraBi} + in pkg_descr{ library = modifyLib `fmap` library pkg_descr + , executables = modifyExecutable `map` executables pkg_descr} + +-- ----------------------------------------------------------------------------- +-- Configuring package dependencies + +reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () +reportProgram verbosity prog Nothing + = info verbosity $ "No " ++ programName prog ++ " found" +reportProgram verbosity prog (Just configuredProg) + = info verbosity $ "Using " ++ programName prog ++ version ++ location + where location = case programLocation configuredProg of + FoundOnSystem p -> " found on system at: " ++ p + UserSpecified p -> " given by user at: " ++ p + version = case programVersion configuredProg of + Nothing -> "" + Just v -> " version " ++ display v + +hackageUrl :: String +hackageUrl = "http://hackage.haskell.org/package/" + +data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo + | InternalDependency Dependency PackageId -- should be a lib name + +data FailedDependency = DependencyNotExists PackageName + | DependencyNoVersion Dependency + +-- | Test for a package dependency and record the version we have installed. +selectDependency :: PackageIndex -- ^ Internally defined packages + -> PackageIndex -- ^ Installed packages + -> Dependency + -> Either FailedDependency ResolvedDependency +selectDependency internalIndex installedIndex + dep@(Dependency pkgname vr) = + -- If the dependency specification matches anything in the internal package + -- index, then we prefer that match to anything in the second. + -- For example: + -- + -- Name: MyLibrary + -- Version: 0.1 + -- Library + -- .. + -- Executable my-exec + -- build-depends: MyLibrary + -- + -- We want "build-depends: MyLibrary" always to match the internal library + -- even if there is a newer installed library "MyLibrary-0.2". + -- However, "build-depends: MyLibrary >= 0.2" should match the installed one. + case PackageIndex.lookupPackageName internalIndex pkgname of + [(_,[pkg])] | packageVersion pkg `withinRange` vr + -> Right $ InternalDependency dep (packageId pkg) + + _ -> case PackageIndex.lookupDependency installedIndex dep of + [] -> Left $ DependencyNotExists pkgname + pkgs -> Right $ ExternalDependency dep $ + -- by default we just pick the latest + case last pkgs of + (_ver, instances) -> head instances -- the first preference + +reportSelectedDependencies :: Verbosity + -> [ResolvedDependency] -> IO () +reportSelectedDependencies verbosity deps = + info verbosity $ unlines + [ "Dependency " ++ display (simplifyDependency dep) + ++ ": using " ++ display pkgid + | resolved <- deps + , let (dep, pkgid) = case resolved of + ExternalDependency dep' pkg' -> (dep', packageId pkg') + InternalDependency dep' pkgid' -> (dep', pkgid') ] + +reportFailedDependencies :: [FailedDependency] -> IO () +reportFailedDependencies [] = return () +reportFailedDependencies failed = + die (intercalate "\n\n" (map reportFailedDependency failed)) + + where + reportFailedDependency (DependencyNotExists pkgname) = + "there is no version of " ++ display pkgname ++ " installed.\n" + ++ "Perhaps you need to download and install it from\n" + ++ hackageUrl ++ display pkgname ++ "?" + + reportFailedDependency (DependencyNoVersion dep) = + "cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n" + +getInstalledPackages :: Verbosity -> Compiler + -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity comp packageDBs progconf = do + when (null packageDBs) $ + die $ "No package databases have been specified. If you use " + ++ "--package-db=clear, you must follow it with --package-db= " + ++ "with 'global', 'user' or a specific file." + + info verbosity "Reading installed packages..." + case compilerFlavor comp of + GHC -> GHC.getInstalledPackages verbosity 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 + flv -> die $ "don't know how to find the installed packages for " + ++ display flv + +-- | The user interface specifies the package dbs to use with a combination of +-- @--global@, @--user@ and @--package-db=global|user|clear|$file@. +-- This function combines the global/user flag and interprets the package-db +-- flag into a single package db stack. +-- +interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack +interpretPackageDbFlags userInstall specificDBs = + extra initialStack specificDBs + where + initialStack | userInstall = [GlobalPackageDB, UserPackageDB] + | otherwise = [GlobalPackageDB] + + extra dbs' [] = dbs' + extra _ (Nothing:dbs) = extra [] dbs + extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs + +newPackageDepsBehaviourMinVersion :: Version +newPackageDepsBehaviourMinVersion = Version { versionBranch = [1,7,1], versionTags = [] } + +-- In older cabal versions, there was only one set of package dependencies for +-- the whole package. In this version, we can have separate dependencies per +-- target, but we only enable this behaviour if the minimum cabal version +-- specified is >= a certain minimum. Otherwise, for compatibility we use the +-- old behaviour. +newPackageDepsBehaviour :: PackageDescription -> Bool +newPackageDepsBehaviour pkg = + specVersion pkg >= newPackageDepsBehaviourMinVersion + +-- ----------------------------------------------------------------------------- +-- Configuring program dependencies + +configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration -> IO ProgramConfiguration +configureRequiredPrograms verbosity deps conf = + foldM (configureRequiredProgram verbosity) conf deps + +configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency -> IO ProgramConfiguration +configureRequiredProgram verbosity conf (Dependency (PackageName progName) verRange) = + case lookupKnownProgram progName conf of + Nothing -> die ("Unknown build tool " ++ progName) + Just prog + -- requireProgramVersion always requires the program have a version + -- but if the user says "build-depends: foo" ie no version constraint + -- then we should not fail if we cannot discover the program version. + | verRange == anyVersion -> do + (_, conf') <- requireProgram verbosity prog conf + return conf' + | otherwise -> do + (_, _, conf') <- requireProgramVersion verbosity prog verRange conf + return conf' + +-- ----------------------------------------------------------------------------- +-- Configuring pkg-config package dependencies + +configurePkgconfigPackages :: Verbosity -> PackageDescription + -> ProgramConfiguration + -> IO (PackageDescription, ProgramConfiguration) +configurePkgconfigPackages verbosity pkg_descr conf + | null allpkgs = return (pkg_descr, conf) + | otherwise = do + (_, _, conf') <- requireProgramVersion + (lessVerbose verbosity) pkgConfigProgram + (orLaterVersion $ Version [0,9,0] []) conf + mapM_ requirePkg allpkgs + lib' <- updateLibrary (library pkg_descr) + exes' <- mapM updateExecutable (executables pkg_descr) + let pkg_descr' = pkg_descr { library = lib', executables = exes' } + return (pkg_descr', conf') + + where + allpkgs = concatMap pkgconfigDepends (allBuildInfo pkg_descr) + pkgconfig = rawSystemProgramStdoutConf (lessVerbose verbosity) + pkgConfigProgram conf + + requirePkg dep@(Dependency (PackageName pkg) range) = do + version <- pkgconfig ["--modversion", pkg] + `catchIO` (\_ -> die notFound) + `catchExit` (\_ -> die notFound) + case simpleParse version of + Nothing -> die "parsing output of pkg-config --modversion failed" + Just v | not (withinRange v range) -> die (badVersion v) + | otherwise -> info verbosity (depSatisfied v) + where + notFound = "The pkg-config package " ++ pkg ++ versionRequirement + ++ " is required but it could not be found." + badVersion v = "The pkg-config package " ++ pkg ++ versionRequirement + ++ " is required but the version installed on the" + ++ " system is version " ++ display v + depSatisfied v = "Dependency " ++ display dep + ++ ": using version " ++ display v + + versionRequirement + | isAnyVersion range = "" + | otherwise = " version " ++ display range + + updateLibrary Nothing = return Nothing + updateLibrary (Just lib) = do + bi <- pkgconfigBuildInfo (pkgconfigDepends (libBuildInfo lib)) + return $ Just lib { libBuildInfo = libBuildInfo lib `mappend` bi } + + updateExecutable exe = do + bi <- pkgconfigBuildInfo (pkgconfigDepends (buildInfo exe)) + return exe { buildInfo = buildInfo exe `mappend` bi } + + pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo + pkgconfigBuildInfo [] = return mempty + pkgconfigBuildInfo pkgdeps = do + let pkgs = nub [ display pkg | Dependency pkg _ <- pkgdeps ] + ccflags <- pkgconfig ("--cflags" : pkgs) + ldflags <- pkgconfig ("--libs" : pkgs) + return (ccLdOptionsBuildInfo (words ccflags) (words ldflags)) + +-- | Makes a 'BuildInfo' from C compiler and linker flags. +-- +-- This can be used with the output from configuration programs like pkg-config +-- and similar package-specific programs like mysql-config, freealut-config etc. +-- For example: +-- +-- > ccflags <- rawSystemProgramStdoutConf verbosity prog conf ["--cflags"] +-- > ldflags <- rawSystemProgramStdoutConf verbosity prog conf ["--libs"] +-- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags)) +-- +ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo +ccLdOptionsBuildInfo cflags ldflags = + let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags + (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags + (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' + in mempty { + PD.includeDirs = map (drop 2) includeDirs', + PD.extraLibs = map (drop 2) extraLibs', + PD.extraLibDirs = map (drop 2) extraLibDirs', + PD.ccOptions = cflags', + PD.ldOptions = ldflags'' + } + +-- ----------------------------------------------------------------------------- +-- Determining the compiler details + +configCompilerAux :: ConfigFlags -> IO (Compiler, ProgramConfiguration) +configCompilerAux cfg = configCompiler (flagToMaybe $ configHcFlavor cfg) + (flagToMaybe $ configHcPath cfg) + (flagToMaybe $ configHcPkg cfg) + programsConfig + (fromFlag (configVerbosity cfg)) + where + programsConfig = userSpecifyArgss (configProgramArgs cfg) + . userSpecifyPaths (configProgramPaths cfg) + $ defaultProgramConfiguration + +configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> Verbosity + -> IO (Compiler, ProgramConfiguration) +configCompiler Nothing _ _ _ _ = die "Unknown compiler" +configCompiler (Just hcFlavor) hcPath hcPkg conf verbosity = do + 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 + _ -> die "Unknown compiler" + + +-- Try to build a test C program which includes every header and links every +-- lib. If that fails, try to narrow it down by preprocessing (only) and linking +-- with individual headers and libs. If none is the obvious culprit then give a +-- generic error message. +-- TODO: produce a log file from the compiler errors, if any. +checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () +checkForeignDeps pkg lbi verbosity = do + ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling lucky + (return ()) + (do missingLibs <- findMissingLibs + missingHdr <- findOffendingHdr + explainErrors missingHdr missingLibs) + where + allHeaders = collectField PD.includes + allLibs = collectField PD.extraLibs + + ifBuildsWith headers args success failure = do + ok <- builds (makeProgram headers) args + if ok then success else failure + + findOffendingHdr = + ifBuildsWith allHeaders ccArgs + (return Nothing) + (go . tail . inits $ allHeaders) + where + go [] = return Nothing -- cannot happen + go (hdrs:hdrsInits) = + -- Try just preprocessing first + ifBuildsWith hdrs cppArgs + -- If that works, try compiling too + (ifBuildsWith hdrs ccArgs + (go hdrsInits) + (return . Just . Right . last $ hdrs)) + (return . Just . Left . last $ hdrs) + + cppArgs = "-E":commonCppArgs -- preprocess only + ccArgs = "-c":commonCcArgs -- don't try to link + + findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs) + (return []) + (filterM (fmap not . libExists) allLibs) + + libExists lib = builds (makeProgram []) (makeLdArgs [lib]) + + commonCppArgs = hcDefines (compiler lbi) + ++ [ "-I" ++ autogenModulesDir lbi ] + ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ] + ++ ["-I."] + ++ collectField PD.cppOptions + ++ collectField PD.ccOptions + ++ [ "-I" ++ dir + | dep <- deps + , dir <- Installed.includeDirs dep ] + ++ [ opt + | dep <- deps + , opt <- Installed.ccOptions dep ] + + commonCcArgs = commonCppArgs + ++ collectField PD.ccOptions + ++ [ opt + | dep <- deps + , opt <- Installed.ccOptions dep ] + + commonLdArgs = [ "-L" ++ dir | dir <- collectField PD.extraLibDirs ] + ++ collectField PD.ldOptions + ++ [ "-L" ++ dir + | dep <- deps + , dir <- Installed.libraryDirs dep ] + --TODO: do we also need dependent packages' ld options? + makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs + + makeProgram hdrs = unlines $ + [ "#include \"" ++ hdr ++ "\"" | hdr <- hdrs ] ++ + ["int main(int argc, char** argv) { return 0; }"] + + collectField f = concatMap f allBi + allBi = allBuildInfo pkg + deps = PackageIndex.topologicalOrder (installedPkgs lbi) + + builds program args = do + tempDir <- getTemporaryDirectory + withTempFile tempDir ".c" $ \cName cHnd -> + withTempFile tempDir "" $ \oNname oHnd -> do + hPutStrLn cHnd program + hClose cHnd + hClose oHnd + _ <- rawSystemProgramStdoutConf verbosity + gccProgram (withPrograms lbi) (cName:"-o":oNname:args) + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + + explainErrors Nothing [] = return () -- should be impossible! + explainErrors hdr libs = die $ unlines $ + [ if plural + then "Missing dependencies on foreign libraries:" + else "Missing dependency on a foreign library:" + | missing ] + ++ case hdr of + Just (Left h) -> ["* Missing (or bad) header file: " ++ h ] + _ -> [] + ++ case libs of + [] -> [] + [lib] -> ["* Missing C library: " ++ lib] + _ -> ["* Missing C libraries: " ++ intercalate ", " libs] + ++ [if plural then messagePlural else messageSingular | missing] + ++ case hdr of + Just (Left _) -> [ headerCppMessage ] + Just (Right h) -> [ (if missing then "* " else "") + ++ "Bad header file: " ++ h + , headerCcMessage ] + _ -> [] + + where + plural = length libs >= 2 + -- Is there something missing? (as opposed to broken) + missing = not (null libs) + || case hdr of Just (Left _) -> True; _ -> False + + messageSingular = + "This problem can usually be solved by installing the system " + ++ "package that provides this library (you may need the " + ++ "\"-dev\" version). If the library is already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where it is." + messagePlural = + "This problem can usually be solved by installing the system " + ++ "packages that provide these libraries (you may need the " + ++ "\"-dev\" versions). If the libraries are already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where they are." + headerCppMessage = + "If the header file does exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." + headerCcMessage = + "The header file contains a compile error. " + ++ "You can re-run configure with the verbosity flag " + ++ "-v3 to see the error messages from the C compiler." + + --FIXME: share this with the PreProcessor module + hcDefines :: Compiler -> [String] + hcDefines comp = + case compilerFlavor comp of + GHC -> + let ghcOS = case buildOS of + Linux -> ["linux"] + Windows -> ["mingw32"] + OSX -> ["darwin"] + FreeBSD -> ["freebsd"] + OpenBSD -> ["openbsd"] + NetBSD -> ["netbsd"] + Solaris -> ["solaris2"] + AIX -> ["aix"] + HPUX -> ["hpux"] + IRIX -> ["irix"] + HaLVM -> [] + OtherOS _ -> [] + ghcArch = case buildArch of + I386 -> ["i386"] + X86_64 -> ["x86_64"] + PPC -> ["powerpc"] + PPC64 -> ["powerpc64"] + Sparc -> ["sparc"] + Arm -> ["arm"] + Mips -> ["mips"] + SH -> [] + IA64 -> ["ia64"] + S390 -> ["s390"] + Alpha -> ["alpha"] + Hppa -> ["hppa"] + Rs6000 -> ["rs6000"] + M68k -> ["m68k"] + Vax -> ["vax"] + OtherArch _ -> [] + in ["-D__GLASGOW_HASKELL__=" ++ versionInt version] ++ + map (\os -> "-D" ++ os ++ "_HOST_OS=1") ghcOS ++ + map (\arch -> "-D" ++ arch ++ "_HOST_ARCH=1") ghcArch + JHC -> ["-D__JHC__=" ++ versionInt version] + NHC -> ["-D__NHC__=" ++ versionInt version] + Hugs -> ["-D__HUGS__"] + _ -> [] + where + version = compilerVersion 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. + versionInt :: Version -> String + versionInt (Version { versionBranch = [] }) = "1" + versionInt (Version { versionBranch = [n] }) = show n + versionInt (Version { versionBranch = n1:n2:_ }) + = -- 6.8.x -> 608 + -- 6.10.x -> 610 + let s1 = show n1 + s2 = show n2 + middle = case s2 of + _ : _ : _ -> "" + _ -> "0" + in s1 ++ middle ++ s2 + +-- | Output package check warnings and errors. Exit if any errors. +checkPackageProblems :: Verbosity + -> GenericPackageDescription + -> PackageDescription + -> IO () +checkPackageProblems verbosity gpkg pkg = do + ioChecks <- checkPackageFiles pkg "." + let pureChecks = checkPackage gpkg (Just pkg) + errors = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ] + warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ] + if null errors + then mapM_ (warn verbosity) warnings + else do mapM_ (hPutStrLn stderr . ("Error: " ++)) errors + exitWith (ExitFailure 1) diff --git a/cabal/Cabal/Distribution/Simple/GHC.hs b/cabal/Cabal/Distribution/Simple/GHC.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/GHC.hs @@ -0,0 +1,1127 @@ +----------------------------------------------------------------------------- +-- | +-- 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 ( + configure, getInstalledPackages, + buildLib, buildExe, + installLib, installExe, + libAbiHash, + initPackageDB, + registerPackage, + componentGhcOptions, + ghcLibDir, + + -- * Deprecated + ghcVerbosityOptions, + ghcPackageDbOptions, + ) 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, 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(..) + , absoluteInstallDirs ) +import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Utils +import Distribution.Package + ( PackageIdentifier, Package(..), PackageName(..) ) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Simple.Program + ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg + , ProgramLocation(..), rawSystemProgram + , rawSystemProgramStdout, rawSystemProgramStdoutConf + , getProgramInvocationOutput + , requireProgramVersion, requireProgram, getProgramOutput + , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram + , ghcProgram, ghcPkgProgram, hsc2hsProgram + , arProgram, ranlibProgram, 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 Distribution.Simple.Program.GHC +import Distribution.Simple.Setup (toFlag, fromFlag) +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, liftM ) +import Data.Char ( isSpace ) +import Data.List +import Data.Maybe ( catMaybes, fromMaybe ) +import Data.Monoid ( Monoid(..) ) +import System.Directory + ( removeFile, 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) + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, 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 <- if ghcVersion >= Version [6,7] [] + then do xs <- getProgramOutput verbosity ghcProg ["--info"] + case reads xs of + [(i, ss)] + | all isSpace ss -> + return i + _ -> + die "Can't parse --info output of GHC" + else return [] + + let comp = Compiler { + compilerId = CompilerId GHC ghcVersion, + compilerLanguages = languages, + compilerExtensions = extensions + } + conf4 = configureToolchain ghcProg ghcInfo conf3 -- configure gcc and ld + return (comp, 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 :: FilePath -> ConfiguredProgram -> Verbosity + -> IO (Maybe FilePath) +guessToolFromGhcPath tool ghcProg verbosity + = do let path = programPath ghcProg + dir = takeDirectory path + versionSuffix = takeVersionSuffix (dropExeExtension path) + guessNormal = dir tool <.> exeExtension + guessGhcVersioned = dir (tool ++ "-ghc" ++ versionSuffix) <.> exeExtension + guessVersioned = dir (tool ++ versionSuffix) <.> exeExtension + guesses | null versionSuffix = [guessNormal] + | otherwise = [guessGhcVersioned, + guessVersioned, + guessNormal] + info verbosity $ "looking for tool " ++ show tool ++ " near compiler in " ++ dir + exists <- mapM doesFileExist guesses + case [ file | (file, True) <- zip guesses exists ] of + [] -> return Nothing + (fp:_) -> do info verbosity $ "found " ++ tool ++ " 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 -> IO (Maybe FilePath) +guessGhcPkgFromGhcPath = guessToolFromGhcPath "ghc-pkg" + +-- | 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 -> IO (Maybe FilePath) +guessHsc2hsFromGhcPath = guessToolFromGhcPath "hsc2hs" + +-- | Adjust the way we find and configure gcc and ld +-- +configureToolchain :: ConfiguredProgram -> [(String, String)] + -> ProgramConfiguration + -> ProgramConfiguration +configureToolchain ghcProg ghcInfo = + addKnownProgram gccProgram { + programFindLocation = findProg gccProgram + [ if ghcVersion >= Version [6,12] [] + then mingwBinDir binPrefix ++ "gcc.exe" + else baseDir "gcc.exe" ], + programPostConf = configureGcc + } + . addKnownProgram ldProgram { + programFindLocation = findProg ldProgram + [ if ghcVersion >= Version [6,12] [] + then mingwBinDir binPrefix ++ "ld.exe" + else libDir "ld.exe" ], + programPostConf = configureLd + } + . addKnownProgram arProgram { + programFindLocation = findProg arProgram + [ if ghcVersion >= Version [6,12] [] + then mingwBinDir binPrefix ++ "ar.exe" + else libDir "ar.exe" ] + } + . addKnownProgram stripProgram { + programFindLocation = findProg stripProgram + [ if ghcVersion >= Version [6,12] [] + then mingwBinDir binPrefix ++ "strip.exe" + else libDir "strip.exe" ] + } + 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 = "" + + -- on Windows finding and configuring ghc's gcc and ld is a bit special + findProg :: Program -> [FilePath] -> Verbosity -> IO (Maybe FilePath) + findProg prog locations + | isWindows = \verbosity -> look locations verbosity + | otherwise = programFindLocation prog + where + look [] verbosity = do + warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.") + programFindLocation prog verbosity + look (f:fs) verbosity = do + exists <- doesFileExist f + if exists then return (Just f) + else look fs verbosity + + ccFlags = getFlags "C compiler flags" + gccLinkerFlags = getFlags "Gcc Linker flags" + ldLinkerFlags = getFlags "Ld Linker flags" + + getFlags key = case lookup key ghcInfo of + Nothing -> [] + Just flags -> + case reads flags of + [(args, "")] -> args + _ -> [] -- XXX Should should be an error really + + configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureGcc v cp = liftM (++ (ccFlags ++ gccLinkerFlags)) + $ configureGcc' v cp + + configureGcc' :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + 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 ["-B" ++ libDir, "-I" ++ includeDir] + _ -> return [] + | otherwise = \_ _ -> return [] + + configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureLd v cp = liftM (++ ldLinkerFlags) $ configureLd' v cp + + -- we need to find out if ld supports the -x flag + configureLd' :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureLd' verbosity ldProg = do + tempDir <- getTemporaryDirectory + ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> + withTempFile tempDir ".o" $ \testofile testohnd -> do + hPutStrLn testchnd "int foo() {}" + 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 ["-x"] + else return [] + +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 + +getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] +getExtensions verbosity ghcProg + | ghcVersion >= Version [6,7] [] = do + + str <- rawSystemStdout verbosity (programPath 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) + ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity packagedbs conf = do + checkPackageDbEnvVar + checkPackageDbStack packagedbs + pkgss <- getInstalledPackages' verbosity packagedbs conf + topDir <- ghcLibDir' verbosity ghcProg + let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss ] + return $! hackRtsPackage (mconcat indexes) + + where + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it + Just ghcProg = lookupProgram ghcProgram conf + + 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. + +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 :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + let pref = buildDir lbi + pkgid = packageId pkg_descr + ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) + ifProfLib = when (withProfLib lbi) + ifSharedLib = when (withSharedLib lbi) + ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) + comp = compiler lbi + ghcVersion = compilerVersion comp + + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) + let runGhcProg = runGHC verbosity ghcProg + + libBi <- hackThreadedFlag verbosity + comp (withProfLib lbi) (libBuildInfo lib) + + let libTargetDir = pref + forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi + -- 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? + let baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir + vanillaOpts = baseOpts `mappend` mempty { + ghcOptMode = toFlag GhcModeMake, + 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 { + ghcOptDynamic = toFlag True, + ghcOptFPic = toFlag True, + ghcOptHiSuffix = toFlag "dyn_hi", + ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = ghcSharedOptions libBi + } + + unless (null (libModules lib)) $ + do ifVanillaLib forceVanillaLib (runGhcProg vanillaOpts) + ifProfLib (runGhcProg profOpts) + ifSharedLib (runGhcProg sharedOpts) + + -- build any C sources + unless (null (cSources libBi)) $ do + info verbosity "Building C Sources..." + sequence_ + [ do let vanillaCcOpts = (componentCcGhcOptions verbosity lbi + libBi clbi pref filename) `mappend` mempty { + ghcOptProfilingMode = toFlag (withProfLib lbi) + } + sharedCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynamic = toFlag True, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCcOpts) + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg vanillaCcOpts + ifSharedLib (runGhcProg sharedCcOpts) + | filename <- cSources libBi] + + -- link: + info verbosity "Linking..." + let cObjs = map (`replaceExtension` objExtension) (cSources libBi) + cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) + vanillaLibFilePath = libTargetDir mkLibName pkgid + profileLibFilePath = libTargetDir mkProfLibName pkgid + sharedLibFilePath = libTargetDir mkSharedLibName pkgid + (compilerId (compiler lbi)) + ghciLibFilePath = libTargetDir mkGHCiLibName pkgid + libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest + sharedLibInstallPath = libInstallPath mkSharedLibName pkgid + (compilerId (compiler lbi)) + + 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 + pref objExtension True + hProfObjs <- + if (withProfLib lbi) + then getHaskellObjects lib lbi + pref ("p_" ++ objExtension) True + else return [] + hSharedObjs <- + if (withSharedLib lbi) + then getHaskellObjects lib lbi + pref ("dyn_" ++ objExtension) False + else return [] + + unless (null hObjs && null cObjs && null stubObjs) $ do + -- first remove library files if they exists + sequence_ + [ removeFile libFilePath `catchIO` \_ -> return () + | libFilePath <- [vanillaLibFilePath, profileLibFilePath + ,sharedLibFilePath, ghciLibFilePath] ] + + let staticObjectFiles = + hObjs + ++ map (pref ) cObjs + ++ stubObjs + profObjectFiles = + hProfObjs + ++ map (pref ) cObjs + ++ stubProfObjs + ghciObjFiles = + hObjs + ++ map (pref ) cObjs + ++ stubObjs + dynamicObjectFiles = + hSharedObjs + ++ map (pref ) 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, + ghcOptDynamic = toFlag True, + 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 + } + + ifVanillaLib False $ do + (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi) + Ar.createArLibArchive verbosity arProg + vanillaLibFilePath staticObjectFiles + + ifProfLib $ do + (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi) + Ar.createArLibArchive verbosity arProg + profileLibFilePath profObjectFiles + + ifGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity ldProg + ghciLibFilePath ghciObjFiles + + ifSharedLib $ + runGhcProg ghcSharedLinkArgs + + +-- | Build an executable with GHC. +-- +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi + exe@Executable { exeName = exeName', modulePath = modPath } clbi = do + let pref = buildDir lbi + + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) + let runGhcProg = runGHC verbosity ghcProg + + exeBi <- hackThreadedFlag verbosity + (compiler lbi) (withProfExe lbi) (buildInfo exe) + + -- exeNameReal, the name that GHC really uses (with .exe on Windows) + let exeNameReal = exeName' <.> + (if null $ takeExtension exeName' then exeExtension else "") + + let targetDir = pref exeName' + let exeDir = targetDir (exeName' ++ "-tmp") + createDirectoryIfMissingVerbose verbosity True targetDir + createDirectoryIfMissingVerbose verbosity True exeDir + -- TODO: do we need to put hs-boot files into place for mutually recursive modules? + -- FIX: what about exeName.hi-boot? + + -- build executables + unless (null (cSources exeBi)) $ do + info verbosity "Building C Sources." + sequence_ + [ do let opts = (componentCcGhcOptions verbosity lbi exeBi clbi + exeDir filename) `mappend` mempty { + ghcOptDynamic = toFlag (withDynExe lbi), + ghcOptProfilingMode = toFlag (withProfExe lbi) + } + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg opts + | filename <- cSources exeBi] + + srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath + + let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) + let vanillaOpts = (componentGhcOptions verbosity lbi exeBi clbi exeDir) + `mappend` mempty { + ghcOptMode = toFlag GhcModeMake, + ghcOptInputFiles = [exeDir x | x <- cObjs] + ++ [srcMainFile], + ghcOptLinkOptions = PD.ldOptions exeBi, + ghcOptLinkLibs = extraLibs exeBi, + ghcOptLinkLibPath = extraLibDirs exeBi, + ghcOptLinkFrameworks = PD.frameworks exeBi + } + + exeOpts | withProfExe lbi = vanillaOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptHiSuffix = toFlag "p_hi", + ghcOptObjSuffix = toFlag "p_o", + ghcOptExtra = ghcProfOptions exeBi + } + | withDynExe lbi = vanillaOpts `mappend` mempty { + ghcOptDynamic = toFlag True, + ghcOptHiSuffix = toFlag "dyn_hi", + ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = ghcSharedOptions exeBi + } + | otherwise = vanillaOpts + + -- For building exe's for profiling that use TH we actually + -- have to build twice, once without profiling and the again + -- with profiling. 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. + when ((withProfExe lbi || withDynExe lbi) && + EnableExtension TemplateHaskell `elem` allExtensions exeBi) $ + runGhcProg vanillaOpts { ghcOptNoLink = toFlag True } + + runGhcProg exeOpts { 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 ] + +-- 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 + ghcArgs = + (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi)) + `mappend` mempty { + ghcOptMode = toFlag GhcModeAbiHash, + ghcOptPackageName = toFlag (packageId pkg_descr), + ghcOptInputModules = exposedModules lib + } + -- + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) + getProgramInvocationOutput verbosity (ghcInvocation ghcProg 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, + 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 = 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. + +{-# DEPRECATED ghcVerbosityOptions "Use the GhcOptions record instead" #-} +ghcVerbosityOptions :: Verbosity -> [String] +ghcVerbosityOptions verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-w", "-v0"] + +{-# DEPRECATED ghcPackageDbOptions "Use the GhcOptions record instead" #-} +ghcPackageDbOptions :: PackageDBStack -> [String] +ghcPackageDbOptions dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> "-no-user-package-conf" + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ "-package-conf", db ] + specific _ = ierror + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + +mkGHCiLibName :: PackageIdentifier -> String +mkGHCiLibName lib = "HS" ++ display 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) + stripExe verbosity lbi exeFileName (dest <.> exeExtension) + installBinary (binDir fixedExeBaseName) + +stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () +stripExe verbosity lbi name path = when (stripExes lbi) $ + case lookupProgram stripProgram (withPrograms lbi) of + Just strip -> rawSystemProgram verbosity strip args + Nothing -> unless (buildOS == Windows) $ + -- Don't bother warning on windows, we don't expect them to + -- have the strip program anyway. + warn verbosity $ "Unable to strip executable '" ++ name + ++ "' (missing the 'strip' program)" + where + args = path : case buildOS 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. + _ -> [] + +-- |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 + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do + -- copy .hi files over: + let copyHelper installFun src dst n = do + createDirectoryIfMissingVerbose verbosity True dst + installFun verbosity (src n) (dst n) + copy = copyHelper installOrdinaryFile + copyShared = copyHelper installExecutableFile + copyModuleFiles ext = + findModuleFiles [builtDir] [ext] (libModules lib) + >>= installOrdinaryFiles verbosity targetDir + ifVanilla $ copyModuleFiles "hi" + ifProf $ copyModuleFiles "p_hi" + ifShared $ copyModuleFiles "dyn_hi" + + -- copy the built library files over: + ifVanilla $ copy builtDir targetDir vanillaLibName + ifProf $ copy builtDir targetDir profileLibName + ifGHCi $ copy builtDir targetDir ghciLibName + ifShared $ copyShared builtDir dynlibTargetDir sharedLibName + + -- run ranlib if necessary: + ifVanilla $ updateLibArchive verbosity lbi + (targetDir vanillaLibName) + ifProf $ updateLibArchive verbosity lbi + (targetDir profileLibName) + + where + vanillaLibName = mkLibName pkgid + profileLibName = mkProfLibName pkgid + ghciLibName = mkGHCiLibName pkgid + sharedLibName = mkSharedLibName pkgid (compilerId (compiler lbi)) + + pkgid = packageId pkg + + hasLib = not $ null (libModules lib) + && null (cSources (libBuildInfo lib)) + ifVanilla = when (hasLib && withVanillaLib lbi) + ifProf = when (hasLib && withProfLib lbi) + ifGHCi = when (hasLib && withGHCiLib lbi) + ifShared = when (hasLib && withSharedLib lbi) + +-- | On MacOS X we have to call @ranlib@ to regenerate the archive index after +-- copying. This is because the silly MacOS X linker checks that the archive +-- index is not older than the file itself, which means simply +-- copying/installing the file breaks it!! +-- +updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO () +updateLibArchive verbosity lbi path + | buildOS == OSX = do + (ranlib, _) <- requireProgram verbosity ranlibProgram (withPrograms lbi) + rawSystemProgram verbosity ranlib [path] + | otherwise = return () + +-- ----------------------------------------------------------------------------- +-- 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 + +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) diff --git a/cabal/Cabal/Distribution/Simple/GHC/IPI641.hs b/cabal/Cabal/Distribution/Simple/GHC/IPI641.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/GHC/IPI641.hs @@ -0,0 +1,129 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC.IPI641 +-- Copyright : (c) The University of Glasgow 2004 +-- +-- 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, + toCurrent, + ) where + +import qualified Distribution.InstalledPackageInfo as Current +import qualified Distribution.Package as Current hiding (depends) +import Distribution.Text (display) + +import Distribution.Simple.GHC.IPI642 + ( PackageIdentifier, convertPackageId + , License, convertLicense, convertModuleName ) + +-- | This is the InstalledPackageInfo type used by ghc-6.4 and 6.4.1. +-- +-- It's here purely for the 'Read' instance so that we can read the package +-- database used by those ghc versions. It is a little hacky to read the +-- package db directly, but we do need the info and until ghc-6.9 there was +-- no better method. +-- +-- In ghc-6.4.2 the format changed a bit. See "Distribution.Simple.GHC.IPI642" +-- +data InstalledPackageInfo = InstalledPackageInfo { + package :: PackageIdentifier, + license :: License, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + homepage :: String, + pkgUrl :: String, + description :: String, + category :: String, + exposed :: Bool, + exposedModules :: [String], + hiddenModules :: [String], + importDirs :: [FilePath], + libraryDirs :: [FilePath], + hsLibraries :: [String], + extraLibraries :: [String], + includeDirs :: [FilePath], + includes :: [String], + depends :: [PackageIdentifier], + hugsOptions :: [String], + ccOptions :: [String], + ldOptions :: [String], + frameworkDirs :: [FilePath], + frameworks :: [String], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath] + } + deriving Read + +mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId +mkInstalledPackageId = Current.InstalledPackageId . display + +toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo +toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo { + Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)), + Current.sourcePackageId = convertPackageId (package ipi), + Current.license = convertLicense (license ipi), + Current.copyright = copyright ipi, + Current.maintainer = maintainer ipi, + Current.author = author ipi, + Current.stability = stability ipi, + Current.homepage = homepage ipi, + Current.pkgUrl = pkgUrl ipi, + Current.synopsis = "", + Current.description = description ipi, + Current.category = category ipi, + Current.exposed = exposed ipi, + Current.exposedModules = map convertModuleName (exposedModules ipi), + Current.hiddenModules = map convertModuleName (hiddenModules ipi), + Current.trusted = Current.trusted Current.emptyInstalledPackageInfo, + Current.importDirs = importDirs ipi, + Current.libraryDirs = libraryDirs ipi, + 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 + } diff --git a/cabal/Cabal/Distribution/Simple/GHC/IPI642.hs b/cabal/Cabal/Distribution/Simple/GHC/IPI642.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/GHC/IPI642.hs @@ -0,0 +1,164 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC.IPI642 +-- Copyright : (c) The University of Glasgow 2004 +-- +-- 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, + toCurrent, + + -- Don't use these, they're only for conversion purposes + PackageIdentifier, convertPackageId, + License, convertLicense, + convertModuleName + ) where + +import qualified Distribution.InstalledPackageInfo as Current +import qualified Distribution.Package as Current hiding (depends) +import qualified Distribution.License as Current + +import Distribution.Version (Version) +import Distribution.ModuleName (ModuleName) +import Distribution.Text (simpleParse,display) + +import Data.Maybe + +-- | This is the InstalledPackageInfo type used by ghc-6.4.2 and later. +-- +-- It's here purely for the 'Read' instance so that we can read the package +-- database used by those ghc versions. It is a little hacky to read the +-- package db directly, but we do need the info and until ghc-6.9 there was +-- no better method. +-- +-- In ghc-6.4.1 and before the format was slightly different. +-- See "Distribution.Simple.GHC.IPI642" +-- +data InstalledPackageInfo = InstalledPackageInfo { + package :: PackageIdentifier, + license :: License, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + homepage :: String, + pkgUrl :: String, + description :: String, + category :: String, + exposed :: Bool, + exposedModules :: [String], + hiddenModules :: [String], + importDirs :: [FilePath], + libraryDirs :: [FilePath], + hsLibraries :: [String], + extraLibraries :: [String], + extraGHCiLibraries:: [String], + includeDirs :: [FilePath], + includes :: [String], + depends :: [PackageIdentifier], + hugsOptions :: [String], + ccOptions :: [String], + ldOptions :: [String], + frameworkDirs :: [FilePath], + frameworks :: [String], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath] + } + deriving Read + +data PackageIdentifier = PackageIdentifier { + pkgName :: String, + pkgVersion :: Version + } + deriving Read + +data License = GPL | LGPL | BSD3 | BSD4 + | PublicDomain | AllRightsReserved | OtherLicense + deriving Read + +convertPackageId :: PackageIdentifier -> Current.PackageIdentifier +convertPackageId PackageIdentifier { pkgName = n, pkgVersion = v } = + Current.PackageIdentifier (Current.PackageName n) v + +mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId +mkInstalledPackageId = Current.InstalledPackageId . display + +convertModuleName :: String -> ModuleName +convertModuleName s = fromJust $ simpleParse s + +convertLicense :: License -> Current.License +convertLicense GPL = Current.GPL Nothing +convertLicense LGPL = Current.LGPL Nothing +convertLicense BSD3 = Current.BSD3 +convertLicense BSD4 = Current.BSD4 +convertLicense PublicDomain = Current.PublicDomain +convertLicense AllRightsReserved = Current.AllRightsReserved +convertLicense OtherLicense = Current.OtherLicense + +toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo +toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo { + Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)), + Current.sourcePackageId = convertPackageId (package ipi), + Current.license = convertLicense (license ipi), + Current.copyright = copyright ipi, + Current.maintainer = maintainer ipi, + Current.author = author ipi, + Current.stability = stability ipi, + Current.homepage = homepage ipi, + Current.pkgUrl = pkgUrl ipi, + Current.synopsis = "", + Current.description = description ipi, + Current.category = category ipi, + Current.exposed = exposed ipi, + Current.exposedModules = map convertModuleName (exposedModules ipi), + Current.hiddenModules = map convertModuleName (hiddenModules ipi), + Current.trusted = Current.trusted Current.emptyInstalledPackageInfo, + Current.importDirs = importDirs ipi, + Current.libraryDirs = libraryDirs ipi, + 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 + } diff --git a/cabal/Cabal/Distribution/Simple/Haddock.hs b/cabal/Cabal/Distribution/Simple/Haddock.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Haddock.hs @@ -0,0 +1,653 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Haddock +-- Copyright : Isaac Jones 2003-2005 +-- +-- 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 for haddock 0.x which involves +-- \'unlit\'ing and using @-DHADDOCK@ 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. +-- +-- 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 + ) where + +-- local +import Distribution.Package + ( PackageIdentifier, Package(..), packageName ) +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..), allExtensions + , Library(..), hasLibs, Executable(..) ) +import Distribution.Simple.Compiler + ( Compiler(..), compilerVersion ) +import Distribution.Simple.GHC ( componentGhcOptions, ghcLibDir ) +import Distribution.Simple.Program.GHC ( GhcOptions(..), renderGhcOptions ) +import Distribution.Simple.Program + ( ConfiguredProgram(..), requireProgramVersion + , rawSystemProgram, rawSystemProgramStdout + , hscolourProgram, haddockProgram ) +import Distribution.Simple.PreProcess (ppCpp', ppUnlit + , PPSuffixHandler, runSimplePreProcessor + , preprocessComponent) +import Distribution.Simple.Setup + ( 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.LocalBuildInfo + ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..) + , withComponentsLBI ) +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_(..) ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.Simple.Utils + ( die, warn, notice, intercalate, setupMessage + , createDirectoryIfMissingVerbose, withTempFile, copyFileVerbose + , withTempDirectory + , findFileWithExtension, findFile ) +import Distribution.Text + ( display, simpleParse ) + +import Distribution.Verbosity +import Language.Haskell.Extension +-- Base +import System.Directory(removeFile, doesFileExist, createDirectoryIfMissing) + +import Control.Monad ( when, guard ) +import Control.Exception (assert) +import Data.Monoid +import Data.Maybe ( fromMaybe, listToMaybe ) + +import System.FilePath((), (<.>), splitFileName, splitExtension, + normalise, splitPath, joinPath) +import System.IO (hClose, hPutStrLn) +import Distribution.Version + +-- Types + +-- | 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 + argVerbose :: Any, + argOutput :: Flag [Output], -- ^ Html or Hoogle doc or both? required. + argInterfaces :: [(FilePath, Maybe FilePath)], -- ^ [(interface file, path 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. +} + +-- | the FilePath of a directory, it's a monoid under () +newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord) + +unDir :: Directory -> FilePath +unDir = joinPath . filter (\p -> p /="./" && p /= ".") . splitPath . unDir' + +type Template = String + +data Output = Html | Hoogle + +-- -------------------------------------------------------------------------- +-- Haddock support + +haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO () +haddock pkg_descr _ _ haddockFlags + | not (hasLibs pkg_descr) + && not (fromFlag $ haddockExecutables haddockFlags) = + warn (fromFlag $ haddockVerbosity haddockFlags) $ + "No documentation was generated as this package does not contain " + ++ "a library. Perhaps you want to use the --executables flag." + +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) + + -- 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 (compiler lbi) + + -- 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 + + libdirArgs <- getGhcLibDir verbosity lbi isVersion2 + let commonArgs = mconcat + [ libdirArgs + , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags + , fromPackageDescription pkg_descr ] + + let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes + withComponentsLBI pkg_descr lbi $ \comp clbi -> do + pre comp + case comp of + CLib lib -> do + withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do + let bi = libBuildInfo lib + libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate + libArgs' <- prepareSources verbosity tmp + lbi isVersion2 bi (commonArgs `mappend` libArgs) + runHaddock verbosity confHaddock libArgs' + CExe exe -> when (flag haddockExecutables) $ do + withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do + let bi = buildInfo exe + exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate + exeArgs' <- prepareSources verbosity tmp + lbi isVersion2 bi (commonArgs `mappend` exeArgs) + runHaddock verbosity confHaddock exeArgs' + _ -> return () + where + verbosity = flag haddockVerbosity + 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 + -> Bool -- haddock == 2.* + -> BuildInfo + -> HaddockArgs + -> IO HaddockArgs +prepareSources verbosity tmp lbi isVersion2 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 + defines | isVersion2 = [] + | otherwise = ["-D__HADDOCK__"] + +-------------------------------------------------------------------------------------------------- +-- constributions to HaddockArgs + +fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs +fromFlags env 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}") + else NoFlag, + argCssFile = haddockCss 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] ] + of [] -> [ Html ] + os -> os, + argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags + } + +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 + } + where + desc = PD.description pkg_descr + showPkg = display (packageId pkg_descr) + subtitle | null (synopsis pkg_descr) = "" + | otherwise = ": " ++ synopsis pkg_descr + +fromLibrary :: Verbosity + -> FilePath + -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo + -> Maybe PathTemplate -- ^ template for html location + -> IO HaddockArgs +fromLibrary verbosity tmp lbi lib clbi htmlTemplate = do + inFiles <- map snd `fmap` getLibSourceFiles lbi lib + ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate + return ifaceArgs { + argHideModules = (mempty,otherModules $ bi), + argGhcOptions = toFlag ((componentGhcOptions normal lbi bi clbi (buildDir lbi)) { + -- Noooooooooo!!!!!111 + -- haddock stomps on our precious .hi + -- and .o files. Workaround by telling + -- haddock to write them elsewhere. + ghcOptObjDir = toFlag tmp, + ghcOptHiDir = toFlag tmp, + ghcOptStubDir = toFlag tmp + },ghcVersion), + argTargets = inFiles + } + where + bi = libBuildInfo lib + ghcVersion = compilerVersion (compiler lbi) + +fromExecutable :: Verbosity + -> FilePath + -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo + -> Maybe PathTemplate -- ^ template for html location + -> IO HaddockArgs +fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do + inFiles <- map snd `fmap` getExeSourceFiles lbi exe + ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate + return ifaceArgs { + argGhcOptions = toFlag ((componentGhcOptions normal lbi bi clbi (buildDir lbi)) { + -- Noooooooooo!!!!!111 + -- haddock stomps on our precious .hi + -- and .o files. Workaround by telling + -- haddock to write them elsewhere. + ghcOptObjDir = toFlag tmp, + ghcOptHiDir = toFlag tmp, + ghcOptStubDir = toFlag tmp + }, ghcVersion), + argOutputDir = Dir (exeName exe), + argTitle = Flag (exeName exe), + argTargets = inFiles + } + where + bi = buildInfo exe + ghcVersion = compilerVersion (compiler lbi) + +getInterfaces :: Verbosity + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> 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 + return $ mempty { + argInterfaces = packageFlags + } + +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 + +---------------------------------------------------------------------------------------------- + +-- | Call haddock with the specified arguments. +runHaddock :: Verbosity -> ConfiguredProgram -> HaddockArgs -> IO () +runHaddock verbosity confHaddock args = do + let haddockVersion = fromMaybe (error "unable to determine haddock version") + (programVersion confHaddock) + renderArgs verbosity haddockVersion args $ \(flags,result)-> do + + rawSystemProgram verbosity confHaddock flags + + notice verbosity $ "Documentation created: " ++ result + + +renderArgs :: Verbosity + -> Version + -> HaddockArgs + -> (([String], FilePath) -> IO a) + -> IO a +renderArgs verbosity version args k = do + createDirectoryIfMissingVerbose verbosity True outputDir + withTempFile outputDir "haddock-prolog.txt" $ \prologFileName h -> do + do + hPutStrLn h $ fromFlag $ argPrologue args + hClose h + let pflag = (:[]).("--prologue="++) $ prologFileName + k $ (pflag ++ renderPureArgs version args, result) + where + isVersion2 = version >= Version [2,0] [] + outputDir = (unDir $ argOutputDir args) + result = intercalate ", " + . map (\o -> outputDir + case o of + Html -> "index.html" + Hoogle -> pkgstr <.> "txt") + $ arg argOutput + where + pkgstr | isVersion2 = display $ packageName pkgid + | otherwise = display pkgid + pkgid = arg argPackageName + arg f = fromFlag $ f args + +renderPureArgs :: Version -> HaddockArgs -> [String] +renderPureArgs version args = concat + [ + (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) f) + . fromFlag . argInterfaceFile $ args, + (\pkgName -> if isVersion2 + then ["--optghc=-package-name", "--optghc=" ++ pkgName] + else ["--package=" ++ pkgName]) . 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, ghcVersion) <- flagToList (argGhcOptions args) + , opt <- renderGhcOptions ghcVersion opts ], + maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and 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] [] + verbosityFlag + | isVersion2_5 = "--verbosity=1" + | otherwise = "--verbose" + +----------------------------------------------------------------------------------------------------------- + +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 transative " + ++ "package dependencies.\nDebug info: " ++ show inf + interfaces <- sequence + [ case interfaceAndHtmlPath ipkg of + Nothing -> return (Left (packageId ipkg)) + Just (interface, html) -> do + exists <- doesFileExist interface + if exists + then return (Right (interface, html)) + else return (Left (packageId ipkg)) + | ipkg <- PackageIndex.allPackages transitiveDeps ] + + 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 ] + + return (flags, if null missing then Nothing else Just warning) + + where + interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (FilePath, FilePath) + interfaceAndHtmlPath pkg = do + interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) + html <- case htmlTemplate of + Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) + Just htmlPathTemplate -> Just (expandTemplateVars htmlPathTemplate) + return (interface, html) + + where expandTemplateVars = fromPathTemplate . substPathTemplate env + env = haddockTemplateEnv lbi (packageId pkg) + +haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv +haddockTemplateEnv lbi pkg_id = (PrefixVar, prefix (installDirTemplates lbi)) + : initialPathTemplateEnv pkg_id (compilerId (compiler lbi)) + +-- -------------------------------------------------------------------------- +-- hscolour support + +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 + where + verbosity = fromFlag (hscolourVerbosity flags) + distPref = fromFlag $ hscolourDistPref flags + +hscolour' :: 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) + + 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 + withComponentsLBI pkg_descr lbi $ \comp _ -> do + pre comp + case comp of + CLib lib -> do + let outputDir = hscolourPref distPref pkg_descr "src" + runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib + CExe exe | fromFlag (hscolourExecutables flags) -> do + let outputDir = hscolourPref distPref pkg_descr exeName exe "src" + runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe + _ -> return () + where + stylesheet = flagToMaybe (hscolourCSS flags) + + verbosity = fromFlag (hscolourVerbosity flags) + + runHsColour prog outputDir moduleFiles = do + createDirectoryIfMissingVerbose verbosity True outputDir + + case stylesheet of -- copy the CSS file + Nothing | programVersion prog >= Just (Version [1,9] []) -> + rawSystemProgram verbosity prog + ["-print-css", "-o" ++ outputDir "hscolour.css"] + | otherwise -> return () + Just s -> copyFileVerbose verbosity s (outputDir "hscolour.css") + + flip mapM_ moduleFiles $ \(m, inFile) -> + rawSystemProgram verbosity prog + ["-css", "-anchor", "-o" ++ outFile m, inFile] + where + outFile m = outputDir intercalate "-" (ModuleName.components m) <.> "html" + +haddockToHscolour :: HaddockFlags -> HscolourFlags +haddockToHscolour flags = + HscolourFlags { + hscolourCSS = haddockHscolourCss flags, + hscolourExecutables = haddockExecutables flags, + hscolourVerbosity = haddockVerbosity flags, + hscolourDistPref = haddockDistPref flags + } +---------------------------------------------------------------------------------------------- +-- TODO these should be moved elsewhere. + +getLibSourceFiles :: LocalBuildInfo + -> Library + -> IO [(ModuleName.ModuleName, FilePath)] +getLibSourceFiles lbi lib = getSourceFiles searchpaths modules + where + bi = libBuildInfo lib + modules = PD.exposedModules lib ++ otherModules bi + searchpaths = autogenModulesDir lbi : buildDir lbi : hsSourceDirs bi + +getExeSourceFiles :: LocalBuildInfo + -> Executable + -> IO [(ModuleName.ModuleName, FilePath)] +getExeSourceFiles lbi exe = do + moduleFiles <- getSourceFiles searchpaths modules + srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe) + return ((ModuleName.main, srcMainPath) : moduleFiles) + where + bi = buildInfo exe + modules = otherModules bi + searchpaths = autogenModulesDir lbi : exeBuildDir lbi exe : hsSourceDirs bi + +getSourceFiles :: [FilePath] + -> [ModuleName.ModuleName] + -> IO [(ModuleName.ModuleName, FilePath)] +getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $ + findFileWithExtension ["hs", "lhs"] dirs (ModuleName.toFilePath m) + >>= maybe (notFound m) (return . normalise) + where + notFound module_ = die $ "can't find source for module " ++ display module_ + +-- | The directory where we put build results for an executable +exeBuildDir :: LocalBuildInfo -> Executable -> FilePath +exeBuildDir lbi exe = buildDir lbi exeName exe exeName exe ++ "-tmp" + +--------------------------------------------------------------------------------------------- + + + + +-- boilerplate monoid instance. +instance Monoid HaddockArgs where + mempty = HaddockArgs { + argInterfaceFile = mempty, + argPackageName = mempty, + argHideModules = mempty, + argIgnoreExports = mempty, + argLinkSource = mempty, + argCssFile = mempty, + argContents = mempty, + argVerbose = mempty, + argOutput = mempty, + argInterfaces = mempty, + argOutputDir = mempty, + argTitle = mempty, + argPrologue = mempty, + argGhcOptions = mempty, + argGhcLibDir = mempty, + argTargets = mempty + } + mappend a b = HaddockArgs { + argInterfaceFile = mult argInterfaceFile, + argPackageName = mult argPackageName, + argHideModules = mult argHideModules, + argIgnoreExports = mult argIgnoreExports, + argLinkSource = mult argLinkSource, + argCssFile = mult argCssFile, + argContents = mult argContents, + argVerbose = mult argVerbose, + argOutput = mult argOutput, + argInterfaces = mult argInterfaces, + argOutputDir = mult argOutputDir, + argTitle = mult argTitle, + argPrologue = mult argPrologue, + argGhcOptions = mult argGhcOptions, + argGhcLibDir = mult argGhcLibDir, + argTargets = mult argTargets + } + where mult f = f a `mappend` f b + +instance Monoid Directory where + mempty = Dir "." + mappend (Dir m) (Dir n) = Dir $ m n diff --git a/cabal/Cabal/Distribution/Simple/Hpc.hs b/cabal/Cabal/Distribution/Simple/Hpc.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Hpc.hs @@ -0,0 +1,170 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Hpc +-- Copyright : Thomas Tuegel 2011 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides functions for locating various HPC-related paths and +-- 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 + , htmlDir + , tixDir + , tixFilePath + , markupPackage + , markupTest + ) where + +import Control.Monad ( when ) +import Distribution.Compiler ( CompilerFlavor(..) ) +import Distribution.ModuleName ( main ) +import Distribution.PackageDescription + ( BuildInfo(..) + , Library(..) + , PackageDescription(..) + , TestSuite(..) + , testModules + ) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.Program ( hpcProgram, requireProgram ) +import Distribution.Simple.Program.Hpc ( markup, union ) +import Distribution.Simple.Utils ( notice ) +import Distribution.Text +import Distribution.Verbosity ( Verbosity() ) +import System.Directory ( createDirectoryIfMissing, doesFileExist ) +import System.FilePath + +-- ------------------------------------------------------------------------- +-- 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) } + +hpcDir :: FilePath -- ^ \"dist/\" prefix + -> FilePath -- ^ Directory containing component's HPC .mix files +hpcDir distPref = distPref "hpc" + +mixDir :: FilePath -- ^ \"dist/\" prefix + -> FilePath -- ^ Component name + -> FilePath -- ^ Directory containing test suite's .mix files +mixDir distPref name = hpcDir distPref "mix" name + +tixDir :: FilePath -- ^ \"dist/\" prefix + -> FilePath -- ^ Component name + -> FilePath -- ^ Directory containing test suite's .tix files +tixDir distPref name = hpcDir distPref "tix" name + +-- | Path to the .tix file containing a test suite's sum statistics. +tixFilePath :: FilePath -- ^ \"dist/\" prefix + -> FilePath -- ^ Component name + -> FilePath -- ^ Path to test suite's .tix file +tixFilePath distPref name = tixDir distPref name name <.> "tix" + +htmlDir :: FilePath -- ^ \"dist/\" prefix + -> FilePath -- ^ Component name + -> FilePath -- ^ Path to test suite's HTML markup directory +htmlDir distPref name = hpcDir distPref "html" name + +-- | Generate the HTML markup for a test suite. +markupTest :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^ \"dist/\" prefix + -> String -- ^ Library name + -> TestSuite + -> IO () +markupTest verbosity lbi distPref libName suite = do + tixFileExists <- doesFileExist $ tixFilePath distPref $ testName suite + when tixFileExists $ do + (hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi + markup hpc verbosity (tixFilePath distPref $ testName suite) + (mixDir distPref libName) + (htmlDir distPref $ testName suite) + (testModules suite ++ [ main ]) + notice verbosity $ "Test coverage report written to " + ++ htmlDir distPref (testName suite) + "hpc_index" <.> "html" + +-- | Generate the HTML markup for all of a package's test suites. +markupPackage :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^ \"dist/\" prefix + -> String -- ^ Library name + -> [TestSuite] + -> IO () +markupPackage verbosity lbi distPref libName suites = do + let tixFiles = map (tixFilePath distPref . testName) suites + tixFilesExist <- mapM doesFileExist tixFiles + when (and tixFilesExist) $ do + (hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi + let outFile = tixFilePath distPref libName + mixDir' = mixDir distPref libName + htmlDir' = htmlDir distPref libName + excluded = concatMap testModules suites ++ [ main ] + createDirectoryIfMissing True $ takeDirectory outFile + union hpc verbosity tixFiles outFile excluded + markup hpc verbosity outFile mixDir' htmlDir' excluded + notice verbosity $ "Package coverage report written to " + ++ htmlDir' "hpc_index.html" diff --git a/cabal/Cabal/Distribution/Simple/Hugs.hs b/cabal/Cabal/Distribution/Simple/Hugs.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Hugs.hs @@ -0,0 +1,634 @@ +----------------------------------------------------------------------------- +-- | +-- 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 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 qualified Data.ByteString.Lazy.Char8 as BS.Char8 + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, 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 + } + return (comp, conf'') + + where + hugsProgram' = hugsProgram { programFindVersion = getVersion } + +getVersion :: Verbosity -> FilePath -> IO (Maybe Version) +getVersion verbosity hugsPath = do + (output, _err, exit) <- rawSystemStdInOut verbosity hugsPath [] + (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 \\/lib\/hugs\/packages\/\ +-- (i.e. \\/lib\/hugs\/packages\/\ on the target system). +-- Each executable goes in \\/lib\/hugs\/programs\/\ +-- (i.e. \\/lib\/hugs\/programs\/\ on the target system) +-- with a script \\/bin\/\ pointing at +-- \\/lib\/hugs\/programs\/\. +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) diff --git a/cabal/Cabal/Distribution/Simple/Install.hs b/cabal/Cabal/Distribution/Simple/Install.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Install.hs @@ -0,0 +1,214 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Install +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into installing a built package. Performs the +-- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into +-- 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 + +import Distribution.PackageDescription ( + PackageDescription(..), BuildInfo(..), Library(..), + hasLibs, withLib, hasExes, withExe ) +import Distribution.Package (Package(..)) +import Distribution.Simple.LocalBuildInfo ( + LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs, + substPathTemplate) +import Distribution.Simple.BuildPaths (haddockName, haddockPref) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, installDirectoryContents + , installOrdinaryFile, die, info, notice, matchDirFileGlob ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), compilerFlavor ) +import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..), 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 Control.Monad (when, unless) +import System.Directory + ( doesDirectoryExist, doesFileExist ) +import System.FilePath + ( takeFileName, takeDirectory, (), isAbsolute ) + +import Distribution.Verbosity +import Distribution.Text + ( display ) + +-- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" +-- actions. Move files into place based on the prefix argument. FIX: +-- nhc isn't implemented yet. + +install :: PackageDescription -- ^information from the .cabal file + -> LocalBuildInfo -- ^information from the configure step + -> CopyFlags -- ^flags sent to copy or install + -> IO () +install pkg_descr lbi flags = do + let distPref = fromFlag (copyDistPref flags) + verbosity = fromFlag (copyVerbosity flags) + copydest = fromFlag (copyDest flags) + installDirs@(InstallDirs { + bindir = binPref, + libdir = libPref, +-- dynlibdir = dynlibPref, --see TODO below + datadir = dataPref, + progdir = progPref, + docdir = docPref, + htmldir = htmlPref, + haddockdir = interfacePref, + includedir = incPref}) + = absoluteInstallDirs pkg_descr lbi copydest + + --TODO: decide if we need the user to be able to control the libdir + -- for shared libs independently of the one for static libs. If so + -- it should also have a flag in the command line UI + -- For the moment use dynlibdir = libdir + dynlibPref = libPref + progPrefixPref = substPathTemplate (packageId pkg_descr) lbi (progPrefix lbi) + progSuffixPref = substPathTemplate (packageId pkg_descr) lbi (progSuffix lbi) + + docExists <- doesDirectoryExist $ haddockPref distPref pkg_descr + info verbosity ("directory " ++ haddockPref distPref pkg_descr ++ + " does exist: " ++ show docExists) + + installDataFiles verbosity pkg_descr dataPref + + when docExists $ do + createDirectoryIfMissingVerbose verbosity True htmlPref + installDirectoryContents verbosity + (haddockPref distPref pkg_descr) htmlPref + -- setPermissionsRecursive [Read] htmlPref + -- The haddock interface file actually already got installed + -- in the recursive copy, but now we install it where we actually + -- want it to be (normally the same place). We could remove the + -- copy in htmlPref first. + let haddockInterfaceFileSrc = haddockPref distPref pkg_descr + haddockName pkg_descr + haddockInterfaceFileDest = interfacePref haddockName pkg_descr + -- We only generate the haddock interface file for libs, So if the + -- package consists only of executables there will not be one: + exists <- doesFileExist haddockInterfaceFileSrc + when exists $ do + createDirectoryIfMissingVerbose verbosity True interfacePref + installOrdinaryFile verbosity haddockInterfaceFileSrc + haddockInterfaceFileDest + + let lfile = licenseFile pkg_descr + unless (null lfile) $ do + createDirectoryIfMissingVerbose verbosity True docPref + installOrdinaryFile verbosity lfile (docPref takeFileName lfile) + + let buildPref = buildDir lbi + when (hasLibs pkg_descr) $ + notice verbosity ("Installing library in " ++ libPref) + when (hasExes pkg_descr) $ + notice verbosity ("Installing executable(s) in " ++ binPref) + + -- install include files for all compilers - they may be needed to compile + -- haskell files (using the CPP extension) + when (hasLibs pkg_descr) $ installIncludeFiles verbosity pkg_descr incPref + + case compilerFlavor (compiler lbi) of + GHC -> do withLib pkg_descr $ + GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + withExe pkg_descr $ + GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr + LHC -> do withLib pkg_descr $ + LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + withExe pkg_descr $ + LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr + JHC -> do withLib pkg_descr $ + 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 withLib pkg_descr $ 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 + _ -> die $ "installing with " + ++ display (compilerFlavor (compiler lbi)) + ++ " is not implemented" + return () + -- register step should be performed by caller. + +-- | Install the files listed in data-files +-- +installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO () +installDataFiles verbosity pkg_descr destDataDir = + flip mapM_ (dataFiles pkg_descr) $ \ file -> do + let srcDataDir = dataDir pkg_descr + files <- matchDirFileGlob srcDataDir file + let dir = takeDirectory file + createDirectoryIfMissingVerbose verbosity True (destDataDir dir) + sequence_ [ installOrdinaryFile verbosity (srcDataDir file') + (destDataDir file') + | file' <- files ] + +-- | Install the files listed in install-includes +-- +installIncludeFiles :: Verbosity -> PackageDescription -> FilePath -> IO () +installIncludeFiles verbosity + PackageDescription { library = Just lib } destIncludeDir = do + + incs <- mapM (findInc relincdirs) (installIncludes lbi) + sequence_ + [ do createDirectoryIfMissingVerbose verbosity True destDir + installOrdinaryFile verbosity srcFile destFile + | (relFile, srcFile) <- incs + , let destFile = destIncludeDir relFile + destDir = takeDirectory destFile ] + where + relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) + lbi = libBuildInfo lib + + findInc [] file = die ("can't find include file " ++ file) + findInc (dir:dirs) file = do + let path = dir file + exists <- doesFileExist path + if exists then return (file, path) else findInc dirs file +installIncludeFiles _ _ _ = die "installIncludeFiles: Can't happen?" diff --git a/cabal/Cabal/Distribution/Simple/InstallDirs.hs b/cabal/Cabal/Distribution/Simple/InstallDirs.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/InstallDirs.hs @@ -0,0 +1,604 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.InstallDirs +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This manages everything to do with where files get installed (though does +-- not get involved with actually doing any installation). It provides an +-- 'InstallDirs' type which is a set of directories for where to install +-- things. It also handles the fact that we use templates in these install +-- dirs. For example most install dirs are relative to some @$prefix@ and by +-- changing the prefix all other dirs still end up changed appropriately. So it +-- 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, + defaultInstallDirs, + combineInstallDirs, + absoluteInstallDirs, + CopyDest(..), + prefixRelativeInstallDirs, + substituteInstallDirTemplates, + + PathTemplate, + PathTemplateVariable(..), + PathTemplateEnv, + toPathTemplate, + fromPathTemplate, + substPathTemplate, + initialPathTemplateEnv, + platformTemplateEnv, + compilerTemplateEnv, + packageTemplateEnv, + installDirsTemplateEnv, + ) where + + +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid(..)) +import System.Directory (getAppUserDataDirectory) +import System.FilePath ((), isPathSeparator, pathSeparator) +#if __HUGS__ || __GLASGOW_HASKELL__ > 606 +import System.FilePath (dropDrive) +#endif + +import Distribution.Package + ( PackageIdentifier, packageName, packageVersion ) +import Distribution.System + ( OS(..), buildOS, Platform(..), buildPlatform ) +import Distribution.Compiler + ( CompilerId, CompilerFlavor(..) ) +import Distribution.Text + ( display ) + +#if mingw32_HOST_OS +import Foreign +import Foreign.C +#endif + +-- --------------------------------------------------------------------------- +-- Instalation 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. +-- +data InstallDirs dir = InstallDirs { + prefix :: dir, + bindir :: dir, + libdir :: dir, + libsubdir :: dir, + dynlibdir :: dir, + libexecdir :: dir, + progdir :: dir, + includedir :: dir, + datadir :: dir, + datasubdir :: dir, + docdir :: dir, + mandir :: dir, + htmldir :: dir, + haddockdir :: dir + } deriving (Read, Show) + +instance Functor InstallDirs where + fmap f dirs = InstallDirs { + prefix = f (prefix dirs), + bindir = f (bindir dirs), + libdir = f (libdir dirs), + 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), + docdir = f (docdir dirs), + mandir = f (mandir dirs), + htmldir = f (htmldir dirs), + haddockdir = f (haddockdir dirs) + } + +instance Monoid dir => Monoid (InstallDirs dir) where + mempty = InstallDirs { + prefix = mempty, + bindir = mempty, + libdir = mempty, + libsubdir = mempty, + dynlibdir = mempty, + libexecdir = mempty, + progdir = mempty, + includedir = mempty, + datadir = mempty, + datasubdir = mempty, + docdir = mempty, + mandir = mempty, + htmldir = mempty, + haddockdir = mempty + } + mappend = combineInstallDirs mappend + +combineInstallDirs :: (a -> b -> c) + -> InstallDirs a + -> InstallDirs b + -> InstallDirs c +combineInstallDirs combine a b = InstallDirs { + prefix = prefix a `combine` prefix b, + bindir = bindir a `combine` bindir b, + libdir = libdir a `combine` libdir b, + 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, + docdir = docdir a `combine` docdir b, + mandir = mandir a `combine` mandir b, + htmldir = htmldir a `combine` htmldir b, + haddockdir = haddockdir a `combine` haddockdir b + } + +appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a +appendSubdirs append dirs = dirs { + libdir = libdir dirs `append` libsubdir dirs, + datadir = datadir dirs `append` datasubdir dirs, + libsubdir = error "internal error InstallDirs.libsubdir", + datasubdir = error "internal error InstallDirs.datasubdir" + } + +-- | The installation directories in terms of 'PathTemplate's that contain +-- variables. +-- +-- The defaults for most of the directories are relative to each other, in +-- particular they are all relative to a single prefix. This makes it +-- 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'). +-- +-- 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 +-- 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@. +-- +-- An additional complication is the need to support relocatable packages on +-- systems which support such things, like Windows. +-- +type InstallDirTemplates = InstallDirs PathTemplate + +-- --------------------------------------------------------------------------- +-- Default installation directories + +defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates +defaultInstallDirs comp userInstall _hasLibs = do + installPrefix <- + if userInstall + then getAppUserDataDirectory "cabal" + else case buildOS of + Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir + return (windowsProgramFilesDir "Haskell") + _ -> return "/usr/local" + installLibDir <- + case buildOS of + Windows -> return "$prefix" + _ -> case comp of + LHC | userInstall -> getAppUserDataDirectory "lhc" + _ -> return ("$prefix" "lib") + return $ fmap toPathTemplate $ InstallDirs { + prefix = installPrefix, + bindir = "$prefix" "bin", + libdir = installLibDir, + libsubdir = case comp of + Hugs -> "hugs" "packages" "$pkg" + JHC -> "$compiler" + LHC -> "$compiler" + UHC -> "$pkgid" + _other -> "$pkgid" "$compiler", + dynlibdir = "$libdir", + libexecdir = case buildOS of + Windows -> "$prefix" "$pkgid" + _other -> "$prefix" "libexec", + progdir = "$libdir" "hugs" "programs", + includedir = "$libdir" "$libsubdir" "include", + datadir = case buildOS of + Windows -> "$prefix" + _other -> "$prefix" "share", + datasubdir = "$pkgid", + docdir = "$datadir" "doc" "$pkgid", + mandir = "$datadir" "man", + htmldir = "$docdir" "html", + haddockdir = "$htmldir" + } + +-- --------------------------------------------------------------------------- +-- Converting directories, absolute or prefix-relative + +-- | Substitute the install dir templates into each other. +-- +-- To prevent cyclic substitutions, only some variables are allowed in +-- particular dir templates. If out of scope vars are present, they are not +-- substituted for. Checking for any remaining unsubstituted vars can be done +-- as a subsequent operation. +-- +-- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we +-- can replace 'prefix' with the 'PrefixVar' and get resulting +-- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it +-- each to check which paths are relative to the $prefix. +-- +substituteInstallDirTemplates :: PathTemplateEnv + -> InstallDirTemplates -> InstallDirTemplates +substituteInstallDirTemplates env dirs = dirs' + where + dirs' = InstallDirs { + -- So this specifies exactly which vars are allowed in each template + prefix = subst prefix [], + bindir = subst bindir [prefixVar], + libdir = subst libdir [prefixVar, bindirVar], + 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 [], + docdir = subst docdir prefixBinLibDataVars, + mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]), + htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]), + haddockdir = subst haddockdir (prefixBinLibDataVars ++ + [docdirVar, htmldirVar]) + } + subst dir env' = substPathTemplate (env'++env) (dir dirs) + + prefixVar = (PrefixVar, prefix dirs') + bindirVar = (BindirVar, bindir dirs') + libdirVar = (LibdirVar, libdir dirs') + libsubdirVar = (LibsubdirVar, libsubdir dirs') + datadirVar = (DatadirVar, datadir dirs') + datasubdirVar = (DatasubdirVar, datasubdir dirs') + docdirVar = (DocdirVar, docdir dirs') + htmldirVar = (HtmldirVar, htmldir dirs') + prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar] + prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] + +-- | 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 + -> InstallDirs PathTemplate + -> InstallDirs FilePath +absoluteInstallDirs pkgId compilerId copydest dirs = + (case copydest of + CopyTo destdir -> fmap ((destdir ) . dropDrive) + _ -> id) + . appendSubdirs () + . fmap fromPathTemplate + $ substituteInstallDirTemplates env dirs + where + env = initialPathTemplateEnv pkgId compilerId + + +-- |The location prefix for the /copy/ command. +data CopyDest + = NoCopyDest + | CopyTo FilePath + deriving (Eq, Show) + +-- | Check which of the paths are relative to the installation $prefix. +-- +-- If any of the paths are not relative, ie they are absolute paths, then it +-- prevents us from making a relocatable package (also known as a \"prefix +-- independent\" package). +-- +prefixRelativeInstallDirs :: PackageIdentifier -> CompilerId + -> InstallDirTemplates + -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs pkgId compilerId dirs = + fmap relative + . appendSubdirs combinePathTemplate + $ -- substitute the path template into each other, except that we map + -- \$prefix back to $prefix. We're trying to end up with templates that + -- mention no vars except $prefix. + substituteInstallDirTemplates env dirs { + prefix = PathTemplate [Variable PrefixVar] + } + where + env = initialPathTemplateEnv pkgId compilerId + + -- If it starts with $prefix then it's relative and produce the relative + -- path by stripping off $prefix/ or $prefix + relative dir = case dir of + PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) + relative' (Variable PrefixVar : Ordinary (s:rest) : rest') + | isPathSeparator s = Just (Ordinary rest : rest') + relative' (Variable PrefixVar : rest) = Just rest + relative' _ = Nothing + +-- --------------------------------------------------------------------------- +-- Path templates + +-- | An abstract path, posibly containing variables that need to be +-- substituted for to get a real 'FilePath'. +-- +newtype PathTemplate = PathTemplate [PathComponent] + +data PathComponent = + Ordinary FilePath + | Variable PathTemplateVariable + deriving Eq + +data PathTemplateVariable = + PrefixVar -- ^ The @$prefix@ path variable + | BindirVar -- ^ The @$bindir@ path variable + | LibdirVar -- ^ The @$libdir@ path variable + | LibsubdirVar -- ^ The @$libsubdir@ path variable + | DatadirVar -- ^ The @$datadir@ path variable + | DatasubdirVar -- ^ The @$datasubdir@ path variable + | DocdirVar -- ^ The @$docdir@ path variable + | HtmldirVar -- ^ The @$htmldir@ path variable + | 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@ + | 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@ + | 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 + +type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] + +-- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. +-- +toPathTemplate :: FilePath -> PathTemplate +toPathTemplate = PathTemplate . read + +-- | Convert back to a path, any remaining vars are included +-- +fromPathTemplate :: PathTemplate -> FilePath +fromPathTemplate (PathTemplate template) = show template + +combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate +combinePathTemplate (PathTemplate t1) (PathTemplate t2) = + PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2) + +substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate +substPathTemplate environment (PathTemplate template) = + PathTemplate (concatMap subst template) + + where subst component@(Ordinary _) = [component] + subst component@(Variable variable) = + case lookup variable environment of + Just (PathTemplate components) -> components + Nothing -> [component] + +-- | The initial environment has all the static stuff but no paths +initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> PathTemplateEnv +initialPathTemplateEnv pkgId compilerId = + packageTemplateEnv pkgId + ++ compilerTemplateEnv compilerId + ++ platformTemplateEnv buildPlatform -- platform should be param if we want + -- to do cross-platform configuation + +packageTemplateEnv :: PackageIdentifier -> PathTemplateEnv +packageTemplateEnv pkgId = + [(PkgNameVar, PathTemplate [Ordinary $ display (packageName pkgId)]) + ,(PkgVerVar, PathTemplate [Ordinary $ display (packageVersion pkgId)]) + ,(PkgIdVar, PathTemplate [Ordinary $ display pkgId]) + ] + +compilerTemplateEnv :: CompilerId -> PathTemplateEnv +compilerTemplateEnv compilerId = + [(CompilerVar, PathTemplate [Ordinary $ display compilerId]) + ] + +platformTemplateEnv :: Platform -> PathTemplateEnv +platformTemplateEnv (Platform arch os) = + [(OSVar, PathTemplate [Ordinary $ display os]) + ,(ArchVar, PathTemplate [Ordinary $ display arch]) + ] + +installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv +installDirsTemplateEnv dirs = + [(PrefixVar, prefix dirs) + ,(BindirVar, bindir dirs) + ,(LibdirVar, libdir dirs) + ,(LibsubdirVar, libsubdir dirs) + ,(DatadirVar, datadir dirs) + ,(DatasubdirVar, datasubdir dirs) + ,(DocdirVar, docdir dirs) + ,(HtmldirVar, htmldir dirs) + ] + + +-- --------------------------------------------------------------------------- +-- Parsing and showing path templates: + +-- The textual format is that of an ordinary Haskell String, eg +-- "$prefix/bin" +-- and this gets parsed to the internal representation as a sequence of path +-- spans which are either strings or variables, eg: +-- PathTemplate [Variable PrefixVar, Ordinary "/bin" ] + +instance Show PathTemplateVariable where + show PrefixVar = "prefix" + show BindirVar = "bindir" + show LibdirVar = "libdir" + show LibsubdirVar = "libsubdir" + show DatadirVar = "datadir" + show DatasubdirVar = "datasubdir" + show DocdirVar = "docdir" + show HtmldirVar = "htmldir" + show PkgNameVar = "pkg" + show PkgVerVar = "version" + show PkgIdVar = "pkgid" + show CompilerVar = "compiler" + show OSVar = "os" + show ArchVar = "arch" + show ExecutableNameVar = "executablename" + show TestSuiteNameVar = "test-suite" + show TestSuiteResultVar = "result" + show BenchmarkNameVar = "benchmark" + +instance Read PathTemplateVariable where + readsPrec _ s = + take 1 + [ (var, drop (length varStr) s) + | (varStr, var) <- vars + , varStr `isPrefixOf` s ] + where vars = [("prefix", PrefixVar) + ,("bindir", BindirVar) + ,("libdir", LibdirVar) + ,("libsubdir", LibsubdirVar) + ,("datadir", DatadirVar) + ,("datasubdir", DatasubdirVar) + ,("docdir", DocdirVar) + ,("htmldir", HtmldirVar) + ,("pkgid", PkgIdVar) + ,("pkg", PkgNameVar) + ,("version", PkgVerVar) + ,("compiler", CompilerVar) + ,("os", OSVar) + ,("arch", ArchVar) + ,("executablename", ExecutableNameVar) + ,("test-suite", TestSuiteNameVar) + ,("result", TestSuiteResultVar) + ,("benchmark", BenchmarkNameVar)] + +instance Show PathComponent where + show (Ordinary path) = path + show (Variable var) = '$':show var + showList = foldr (\x -> (shows x .)) id + +instance Read PathComponent where + -- for some reason we colapse multiple $ symbols here + readsPrec _ = lex0 + where lex0 [] = [] + lex0 ('$':'$':s') = lex0 ('$':s') + lex0 ('$':s') = case [ (Variable var, s'') + | (var, s'') <- reads s' ] of + [] -> lex1 "$" s' + ok -> ok + lex0 s' = lex1 [] s' + lex1 "" "" = [] + lex1 acc "" = [(Ordinary (reverse acc), "")] + lex1 acc ('$':'$':s) = lex1 acc ('$':s) + lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)] + lex1 acc (c:s) = lex1 (c:acc) s + readList [] = [([],"")] + readList s = [ (component:components, s'') + | (component, s') <- reads s + , (components, s'') <- readList s' ] + +instance Show PathTemplate where + show (PathTemplate template) = show (show template) + +instance Read PathTemplate where + readsPrec p s = [ (PathTemplate template, s') + | (path, s') <- readsPrec p s + , (template, "") <- reads path ] + +-- --------------------------------------------------------------------------- +-- Internal utilities + +getWindowsProgramFilesDir :: IO FilePath +getWindowsProgramFilesDir = do +#if mingw32_HOST_OS + m <- shGetFolderPath csidl_PROGRAM_FILES +#else + let m = Nothing +#endif + return (fromMaybe "C:\\Program Files" m) + +#if mingw32_HOST_OS +shGetFolderPath :: CInt -> IO (Maybe FilePath) +shGetFolderPath n = +# if __HUGS__ + return Nothing +# else + allocaArray long_path_size $ \pPath -> do + r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath + if (r /= 0) + then return Nothing + else do s <- peekCWString pPath; return (Just s) + where + long_path_size = 1024 -- MAX_PATH is 260, this should be plenty +# endif + +csidl_PROGRAM_FILES :: CInt +csidl_PROGRAM_FILES = 0x0026 +-- csidl_PROGRAM_FILES_COMMON :: CInt +-- csidl_PROGRAM_FILES_COMMON = 0x002b + +foreign import stdcall unsafe "shlobj.h SHGetFolderPathW" + c_SHGetFolderPath :: Ptr () + -> CInt + -> Ptr () + -> CInt + -> CWString + -> IO CInt +#endif + +#if !(__HUGS__ || __GLASGOW_HASKELL__ > 606) +-- Compat: this function only appears in FilePath > 1.0 +-- (which at the time of writing is unreleased) +dropDrive :: FilePath -> FilePath +dropDrive (c:cs) | isPathSeparator c = cs +dropDrive (_:':':c:cs) | isWindows + && isPathSeparator c = cs -- path with drive letter +dropDrive (_:':':cs) | isWindows = cs +dropDrive cs = cs + +isWindows :: Bool +isWindows = case buildOS of + Windows -> True + _ -> False +#endif diff --git a/cabal/Cabal/Distribution/Simple/JHC.hs b/cabal/Cabal/Distribution/Simple/JHC.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/JHC.hs @@ -0,0 +1,222 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.JHC +-- Copyright : Isaac Jones 2003-2006 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- 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, + installLib, installExe + ) where + +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..), Executable(..) + , Library(..), libModules, hcOptions, usedExtensions ) +import Distribution.InstalledPackageInfo + ( emptyInstalledPackageInfo, ) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.Simple.PackageIndex (PackageIndex) +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(..) + , PackageDBStack, Flag, languageToFlags, extensionsToFlags ) +import Language.Haskell.Extension + ( Language(Haskell98), Extension(..), KnownExtension(..)) +import Distribution.Simple.Program + ( ConfiguredProgram(..), jhcProgram, ProgramConfiguration + , userMaybeSpecifyPath, requireProgramVersion, lookupProgram + , rawSystemProgram, rawSystemProgramStdoutConf ) +import Distribution.Version + ( Version(..), orLaterVersion ) +import Distribution.Package + ( Package(..), InstalledPackageId(InstalledPackageId), + pkgName, pkgVersion, ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, writeFileAtomic + , installOrdinaryFile, installExecutableFile + , intercalate ) +import System.FilePath ( () ) +import Distribution.Verbosity +import Distribution.Text + ( Text(parse), display ) +import Distribution.Compat.ReadP + ( readP_to_S, string, skipSpaces ) + +import Data.List ( nub ) +import Data.Char ( isSpace ) +import Data.Maybe ( fromMaybe ) + +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 + + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (jhcProg, _, conf') <- requireProgramVersion verbosity + jhcProgram (orLaterVersion (Version [0,7,2] [])) + (userMaybeSpecifyPath "jhc" hcPath conf) + + let Just version = programVersion jhcProg + comp = Compiler { + compilerId = CompilerId JHC version, + compilerLanguages = jhcLanguages, + compilerExtensions = jhcLanguageExtensions + } + return (comp, conf') + +jhcLanguages :: [(Language, Flag)] +jhcLanguages = [(Haskell98, "")] + +-- | The flags for the supported extensions +jhcLanguageExtensions :: [(Extension, Flag)] +jhcLanguageExtensions = + [(EnableExtension TypeSynonymInstances , "") + ,(DisableExtension TypeSynonymInstances , "") + ,(EnableExtension ForeignFunctionInterface , "") + ,(DisableExtension ForeignFunctionInterface , "") + ,(EnableExtension ImplicitPrelude , "") -- Wrong + ,(DisableExtension ImplicitPrelude , "--noprelude") + ,(EnableExtension CPP , "-fcpp") + ,(DisableExtension CPP , "-fno-cpp") + ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity _packageDBs conf = do + -- jhc --list-libraries lists all available libraries. + -- How shall I find out, whether they are global or local + -- without checking all files and locations? + str <- rawSystemProgramStdoutConf verbosity jhcProgram conf ["--list-libraries"] + let pCheck :: [(a, String)] -> [a] + pCheck rs = [ r | (r,s) <- rs, all isSpace s ] + let parseLine ln = + pCheck (readP_to_S + (skipSpaces >> string "Name:" >> skipSpaces >> parse) ln) + return $ + PackageIndex.fromList $ + map (\p -> emptyInstalledPackageInfo { + InstalledPackageInfo.installedPackageId = + InstalledPackageId (display p), + InstalledPackageInfo.sourcePackageId = p + }) $ + concatMap parseLine $ + lines str + +-- ----------------------------------------------------------------------------- +-- Building + +-- | Building a package for JHC. +-- Currently C source files are not supported. +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) + let libBi = libBuildInfo lib + let args = constructJHCCmdLine lbi libBi clbi (buildDir lbi) verbosity + let pkgid = display (packageId pkg_descr) + pfile = buildDir lbi "jhc-pkg.conf" + hlfile= buildDir lbi (pkgid ++ ".hl") + writeFileAtomic pfile . BS.Char8.pack $ jhcPkgConf pkg_descr + rawSystemProgram verbosity jhcProg $ + ["--build-hl="++pfile, "-o", hlfile] ++ + args ++ map display (libModules lib) + +-- | Building an executable for JHC. +-- Currently C source files are not supported. +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi exe clbi = do + let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) + let exeBi = buildInfo exe + let out = buildDir lbi exeName exe + let args = constructJHCCmdLine lbi exeBi clbi (buildDir lbi) verbosity + rawSystemProgram verbosity jhcProg (["-o",out] ++ args ++ [modulePath exe]) + +constructJHCCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> Verbosity -> [String] +constructJHCCmdLine lbi bi clbi _odir verbosity = + (if verbosity >= deafening then ["-v"] else []) + ++ hcOptions JHC bi + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + ++ ["--noauto","-i-"] + ++ concat [["-i", l] | l <- nub (hsSourceDirs bi)] + ++ ["-i", autogenModulesDir lbi] + ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] + -- It would be better if JHC would accept package names with versions, + -- but JHC-0.7.2 doesn't accept this. + -- Thus, we have to strip the version with 'pkgName'. + ++ (concat [ ["-p", display (pkgName pkgid)] + | (_, pkgid) <- componentPackageDeps clbi ]) + +jhcPkgConf :: PackageDescription -> String +jhcPkgConf pd = + let sline name sel = name ++ ": "++sel pd + lib = fromMaybe (error "no library available") . library + comma = intercalate "," . map display + in unlines [sline "name" (display . pkgName . packageId) + ,sline "version" (display . pkgVersion . packageId) + ,sline "exposed-modules" (comma . PD.exposedModules . lib) + ,sline "hidden-modules" (comma . otherModules . libBuildInfo . lib) + ] + +installLib :: Verbosity -> FilePath -> FilePath -> PackageDescription -> Library -> IO () +installLib verb dest build_dir pkg_descr _ = do + let p = display (packageId pkg_descr)++".hl" + createDirectoryIfMissingVerbose verb True dest + installOrdinaryFile verb (build_dir p) (dest p) + +installExe :: Verbosity -> FilePath -> FilePath -> (FilePath,FilePath) -> PackageDescription -> Executable -> IO () +installExe verb dest build_dir (progprefix,progsuffix) _ exe = do + let exe_name = exeName exe + src = exe_name exeExtension + out = (progprefix ++ exe_name ++ progsuffix) exeExtension + createDirectoryIfMissingVerbose verb True dest + installExecutableFile verb (build_dir src) (dest out) diff --git a/cabal/Cabal/Distribution/Simple/LHC.hs b/cabal/Cabal/Distribution/Simple/LHC.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/LHC.hs @@ -0,0 +1,820 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.LHC +-- 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.LHC ( + configure, getInstalledPackages, + buildLib, buildExe, + installLib, installExe, + registerPackage, + ghcOptions, + ghcVerbosityOptions + ) where + +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..), Executable(..) + , Library(..), libModules, hcOptions, usedExtensions, allExtensions ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo + , parseInstalledPackageInfo ) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo_(..) ) +import Distribution.Simple.PackageIndex +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.ParseUtils ( ParseResult(..) ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) +import Distribution.Simple.InstallDirs +import Distribution.Simple.BuildPaths +import Distribution.Simple.Utils +import Distribution.Package + ( PackageIdentifier, Package(..) ) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Simple.Program + ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg + , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf + , rawSystemProgramStdout, rawSystemProgramStdoutConf + , requireProgramVersion + , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram + , arProgram, ranlibProgram, ldProgram + , gccProgram, stripProgram + , lhcProgram, lhcPkgProgram ) +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import Distribution.Simple.Compiler + ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion + , OptimisationLevel(..), PackageDB(..), PackageDBStack + , Flag, languageToFlags, extensionsToFlags ) +import Distribution.Version + ( Version(..), orLaterVersion ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Verbosity +import Distribution.Text + ( display, simpleParse ) +import Language.Haskell.Extension + ( Language(Haskell98), Extension(..), KnownExtension(..) ) + +import Control.Monad ( unless, when ) +import Data.List +import Data.Maybe ( catMaybes ) +import Data.Monoid ( Monoid(..) ) +import System.Directory ( removeFile, renameFile, + getDirectoryContents, doesFileExist, + getTemporaryDirectory ) +import System.FilePath ( (), (<.>), takeExtension, + takeDirectory, replaceExtension ) +import System.IO (hClose, hPutStrLn) +import Distribution.Compat.Exception (catchExit, catchIO) + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath hcPkgPath conf = do + + (lhcProg, lhcVersion, conf') <- + requireProgramVersion verbosity lhcProgram + (orLaterVersion (Version [0,7] [])) + (userMaybeSpecifyPath "lhc" hcPath conf) + + (lhcPkgProg, lhcPkgVersion, conf'') <- + requireProgramVersion verbosity lhcPkgProgram + (orLaterVersion (Version [0,7] [])) + (userMaybeSpecifyPath "lhc-pkg" hcPkgPath conf') + + when (lhcVersion /= lhcPkgVersion) $ die $ + "Version mismatch between lhc and lhc-pkg: " + ++ programPath lhcProg ++ " is version " ++ display lhcVersion ++ " " + ++ programPath lhcPkgProg ++ " is version " ++ display lhcPkgVersion + + languages <- getLanguages verbosity lhcProg + extensions <- getExtensions verbosity lhcProg + + let comp = Compiler { + compilerId = CompilerId LHC lhcVersion, + compilerLanguages = languages, + compilerExtensions = extensions + } + conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld + return (comp, conf''') + +-- | Adjust the way we find and configure gcc and ld +-- +configureToolchain :: ConfiguredProgram -> ProgramConfiguration + -> ProgramConfiguration +configureToolchain lhcProg = + addKnownProgram gccProgram { + programFindLocation = findProg gccProgram (baseDir "gcc.exe"), + programPostConf = configureGcc + } + . addKnownProgram ldProgram { + programFindLocation = findProg ldProgram (libDir "ld.exe"), + programPostConf = configureLd + } + where + compilerDir = takeDirectory (programPath lhcProg) + baseDir = takeDirectory compilerDir + libDir = baseDir "gcc-lib" + includeDir = baseDir "include" "mingw" + isWindows = case buildOS of Windows -> True; _ -> False + + -- on Windows finding and configuring ghc's gcc and ld is a bit special + findProg :: Program -> FilePath -> Verbosity -> IO (Maybe FilePath) + findProg prog location | isWindows = \verbosity -> do + exists <- doesFileExist location + if exists then return (Just location) + else do warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.") + programFindLocation prog verbosity + | otherwise = programFindLocation prog + + configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + 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 + -- that means we should add this extra flag to tell ghc's gcc + -- where it lives and thus where gcc can find its various files: + FoundOnSystem {} -> return ["-B" ++ libDir, "-I" ++ includeDir] + UserSpecified {} -> return [] + | otherwise = \_ _ -> return [] + + -- we need to find out if ld supports the -x flag + configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureLd verbosity ldProg = do + tempDir <- getTemporaryDirectory + ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> + withTempFile tempDir ".o" $ \testofile testohnd -> do + hPutStrLn testchnd "int foo() {}" + hClose testchnd; hClose testohnd + rawSystemProgram verbosity lhcProg ["-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 ["-x"] + else return [] + +getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)] +getLanguages _ _ = return [(Haskell98, "")] +--FIXME: does lhc support -XHaskell98 flag? from what version? + +getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] +getExtensions verbosity lhcProg = do + exts <- rawSystemStdout verbosity (programPath lhcProg) + ["--supported-languages"] + -- GHC has the annoying habit of inverting some of the extensions + -- so we have to try parsing ("No" ++ ghcExtensionName) first + let readExtension str = do + ext <- simpleParse ("No" ++ str) + case ext of + UnknownExtension _ -> simpleParse str + _ -> return ext + return $ [ (ext, "-X" ++ display ext) + | Just ext <- map readExtension (lines exts) ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity packagedbs conf = do + checkPackageDbStack packagedbs + pkgss <- getInstalledPackages' lhcPkg verbosity packagedbs conf + let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss ] + return $! (mconcat indexes) + + where + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it + Just ghcProg = lookupProgram lhcProgram conf + Just lhcPkg = lookupProgram lhcPkgProgram conf + compilerDir = takeDirectory (programPath ghcProg) + topDir = takeDirectory compilerDir + +checkPackageDbStack :: PackageDBStack -> IO () +checkPackageDbStack (GlobalPackageDB:rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStack _ = + die $ "GHC.getInstalledPackages: the global package db must be " + ++ "specified first and cannot be specified multiple times" + +-- | Get the packages from specific PackageDBs, not cumulative. +-- +getInstalledPackages' :: ConfiguredProgram -> Verbosity + -> [PackageDB] -> ProgramConfiguration + -> IO [(PackageDB, [InstalledPackageInfo])] +getInstalledPackages' lhcPkg verbosity packagedbs conf + = + sequence + [ do str <- rawSystemProgramStdoutConf verbosity lhcPkgProgram conf + ["dump", packageDbGhcPkgFlag packagedb] + `catchExit` \_ -> die $ "ghc-pkg dump failed" + case parsePackages str of + Left ok -> return (packagedb, ok) + _ -> die "failed to parse output of 'ghc-pkg dump'" + | packagedb <- packagedbs ] + + where + parsePackages str = + let parsed = map parseInstalledPackageInfo (splitPkgs str) + in case [ msg | ParseFailed msg <- parsed ] of + [] -> Left [ pkg | ParseOk _ pkg <- parsed ] + msgs -> Right msgs + + splitPkgs :: String -> [String] + splitPkgs = map unlines . splitWith ("---" ==) . lines + where + splitWith :: (a -> Bool) -> [a] -> [[a]] + splitWith p xs = ys : case zs of + [] -> [] + _:ws -> splitWith p ws + where (ys,zs) = break p xs + + packageDbGhcPkgFlag GlobalPackageDB = "--global" + packageDbGhcPkgFlag UserPackageDB = "--user" + packageDbGhcPkgFlag (SpecificPackageDB path) = "--" ++ packageDbFlag ++ "=" ++ path + + packageDbFlag + | programVersion lhcPkg < Just (Version [7,5] []) + = "package-conf" + | otherwise + = "package-db" + + +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 LHC. +-- +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + let pref = buildDir lbi + pkgid = packageId pkg_descr + runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) + ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) + ifProfLib = when (withProfLib lbi) + ifSharedLib = when (withSharedLib lbi) + ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) + + libBi <- hackThreadedFlag verbosity + (compiler lbi) (withProfLib lbi) (libBuildInfo lib) + + let libTargetDir = pref + forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi + -- 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? + let ghcArgs = + ["-package-name", display pkgid ] + ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity + ++ map display (libModules lib) + lhcWrap x = ["--build-library", "--ghc-opts=" ++ unwords x] + ghcArgsProf = ghcArgs + ++ ["-prof", + "-hisuf", "p_hi", + "-osuf", "p_o" + ] + ++ ghcProfOptions libBi + ghcArgsShared = ghcArgs + ++ ["-dynamic", + "-hisuf", "dyn_hi", + "-osuf", "dyn_o", "-fPIC" + ] + ++ ghcSharedOptions libBi + unless (null (libModules lib)) $ + do ifVanillaLib forceVanillaLib (runGhcProg $ lhcWrap ghcArgs) + ifProfLib (runGhcProg $ lhcWrap ghcArgsProf) + ifSharedLib (runGhcProg $ lhcWrap ghcArgsShared) + + -- build any C sources + unless (null (cSources libBi)) $ do + info verbosity "Building C Sources..." + sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref + filename verbosity + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg args + ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"])) + | filename <- cSources libBi] + + -- link: + info verbosity "Linking..." + let cObjs = map (`replaceExtension` objExtension) (cSources libBi) + cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) + vanillaLibFilePath = libTargetDir mkLibName pkgid + profileLibFilePath = libTargetDir mkProfLibName pkgid + sharedLibFilePath = libTargetDir mkSharedLibName pkgid + (compilerId (compiler lbi)) + ghciLibFilePath = libTargetDir mkGHCiLibName pkgid + + stubObjs <- fmap catMaybes $ sequence + [ findFileWithExtension [objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + stubProfObjs <- fmap catMaybes $ sequence + [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + stubSharedObjs <- fmap catMaybes $ sequence + [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + + hObjs <- getHaskellObjects lib lbi + pref objExtension True + hProfObjs <- + if (withProfLib lbi) + then getHaskellObjects lib lbi + pref ("p_" ++ objExtension) True + else return [] + hSharedObjs <- + if (withSharedLib lbi) + then getHaskellObjects lib lbi + pref ("dyn_" ++ objExtension) False + else return [] + + unless (null hObjs && null cObjs && null stubObjs) $ do + -- first remove library files if they exists + sequence_ + [ removeFile libFilePath `catchIO` \_ -> return () + | libFilePath <- [vanillaLibFilePath, profileLibFilePath + ,sharedLibFilePath, ghciLibFilePath] ] + + let arVerbosity | verbosity >= deafening = "v" + | verbosity >= normal = "" + | otherwise = "c" + arArgs = ["q"++ arVerbosity] + ++ [vanillaLibFilePath] + arObjArgs = + hObjs + ++ map (pref ) cObjs + ++ stubObjs + arProfArgs = ["q"++ arVerbosity] + ++ [profileLibFilePath] + arProfObjArgs = + hProfObjs + ++ map (pref ) cObjs + ++ stubProfObjs + ldArgs = ["-r"] + ++ ["-o", ghciLibFilePath <.> "tmp"] + ldObjArgs = + hObjs + ++ map (pref ) cObjs + ++ stubObjs + ghcSharedObjArgs = + hSharedObjs + ++ map (pref ) 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 = + [ "-no-auto-link-packages", + "-shared", + "-dynamic", + "-o", sharedLibFilePath ] + ++ ghcSharedObjArgs + ++ ["-package-name", display pkgid ] + ++ ghcPackageFlags lbi clbi + ++ ["-l"++extraLib | extraLib <- extraLibs libBi] + ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi] + + runLd ldLibName args = do + exists <- doesFileExist ldLibName + -- This method is called iteratively by xargs. The + -- output goes to .tmp, and any existing file + -- named is included when linking. The + -- output is renamed to . + rawSystemProgramConf verbosity ldProgram (withPrograms lbi) + (args ++ if exists then [ldLibName] else []) + renameFile (ldLibName <.> "tmp") ldLibName + + 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 + maxCommandLineSize = 30 * 1024 + + ifVanillaLib False $ xargs maxCommandLineSize + runAr arArgs arObjArgs + + ifProfLib $ xargs maxCommandLineSize + runAr arProfArgs arProfObjArgs + + ifGHCiLib $ xargs maxCommandLineSize + (runLd ghciLibFilePath) ldArgs ldObjArgs + + ifSharedLib $ runGhcProg ghcSharedLinkArgs + + +-- | Build an executable with LHC. +-- +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi + exe@Executable { exeName = exeName', modulePath = modPath } clbi = do + let pref = buildDir lbi + runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) + + exeBi <- hackThreadedFlag verbosity + (compiler lbi) (withProfExe lbi) (buildInfo exe) + + -- exeNameReal, the name that GHC really uses (with .exe on Windows) + let exeNameReal = exeName' <.> + (if null $ takeExtension exeName' then exeExtension else "") + + let targetDir = pref exeName' + let exeDir = targetDir (exeName' ++ "-tmp") + createDirectoryIfMissingVerbose verbosity True targetDir + createDirectoryIfMissingVerbose verbosity True exeDir + -- TODO: do we need to put hs-boot files into place for mutually recursive modules? + -- FIX: what about exeName.hi-boot? + + -- build executables + unless (null (cSources exeBi)) $ do + info verbosity "Building C Sources." + sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi + exeDir filename verbosity + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg args + | filename <- cSources exeBi] + + srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath + + let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) + let lhcWrap x = ("--ghc-opts\"":x) ++ ["\""] + let binArgs linkExe profExe = + (if linkExe + then ["-o", targetDir exeNameReal] + else ["-c"]) + ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity + ++ [exeDir x | x <- cObjs] + ++ [srcMainFile] + ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi] + ++ ["-l"++lib | lib <- extraLibs exeBi] + ++ ["-L"++libDir | libDir <- extraLibDirs exeBi] + ++ concat [["-framework", f] | f <- PD.frameworks exeBi] + ++ if profExe + then ["-prof", + "-hisuf", "p_hi", + "-osuf", "p_o" + ] ++ ghcProfOptions exeBi + else [] + + -- For building exe's for profiling that use TH we actually + -- have to build twice, once without profiling and the again + -- with profiling. 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. + when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi) + (runGhcProg $ lhcWrap (binArgs False False)) + + runGhcProg (binArgs True (withProfExe lbi)) + +-- | 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 ] + +-- 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 dirs = [ pref (ModuleName.toFilePath x ++ "_split") + | 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 ] + + +constructGHCCmdLine + :: LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> Verbosity + -> [String] +constructGHCCmdLine lbi bi clbi odir verbosity = + ["--make"] + ++ ghcVerbosityOptions verbosity + -- Unsupported extensions have already been checked by configure + ++ ghcOptions lbi bi clbi odir + +ghcVerbosityOptions :: Verbosity -> [String] +ghcVerbosityOptions verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-w", "-v0"] + +ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> [String] +ghcOptions lbi bi clbi odir + = ["-hide-all-packages"] + ++ ghcPackageDbOptions lbi + ++ (if splitObjs lbi then ["-split-objs"] else []) + ++ ["-i"] + ++ ["-i" ++ odir] + ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ autogenModulesDir lbi] + ++ ["-I" ++ autogenModulesDir lbi] + ++ ["-I" ++ odir] + ++ ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ ["-optP" ++ opt | opt <- cppOptions bi] + ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] + ++ [ "-#include \"" ++ inc ++ "\"" | inc <- PD.includes bi ] + ++ [ "-odir", odir, "-hidir", odir ] + ++ (if compilerVersion c >= Version [6,8] [] + then ["-stubdir", odir] else []) + ++ ghcPackageFlags lbi clbi + ++ (case withOptimization lbi of + NoOptimisation -> [] + NormalOptimisation -> ["-O"] + MaximumOptimisation -> ["-O2"]) + ++ hcOptions GHC bi + ++ languageToFlags c (defaultLanguage bi) + ++ extensionsToFlags c (usedExtensions bi) + where c = compiler lbi + +ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String] +ghcPackageFlags lbi clbi + | ghcVer >= Version [6,11] [] + = concat [ ["-package-id", display ipkgid] + | (ipkgid, _) <- componentPackageDeps clbi ] + + | otherwise = concat [ ["-package", display pkgid] + | (_, pkgid) <- componentPackageDeps clbi ] + where + ghcVer = compilerVersion (compiler lbi) + +ghcPackageDbOptions :: LocalBuildInfo -> [String] +ghcPackageDbOptions lbi = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> ("-no-user-" ++ packageDbFlag) + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ '-':packageDbFlag, db ] + specific _ = ierror + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + + dbstack = withPackageDB lbi + packageDbFlag + | compilerVersion (compiler lbi) < Version [7,5] [] + = "package-conf" + | otherwise + = "package-db" + +constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath -> Verbosity -> (FilePath,[String]) +constructCcCmdLine lbi bi clbi pref filename verbosity + = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref + | otherwise = pref takeDirectory filename + -- ghc 6.4.1 fixed a bug in -odir handling + -- for C compilations. + in + (odir, + ghcCcOptions lbi bi clbi odir + ++ (if verbosity >= deafening then ["-v"] else []) + ++ ["-c",filename]) + + +ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> [String] +ghcCcOptions lbi bi clbi odir + = ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ ghcPackageDbOptions lbi + ++ ghcPackageFlags lbi clbi + ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] + ++ (case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-optc-O2"]) + ++ ["-odir", odir] + +mkGHCiLibName :: PackageIdentifier -> String +mkGHCiLibName lib = "HS" ++ display 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) + stripExe verbosity lbi exeFileName (dest <.> exeExtension) + installBinary (binDir fixedExeBaseName) + +stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () +stripExe verbosity lbi name path = when (stripExes lbi) $ + case lookupProgram stripProgram (withPrograms lbi) of + Just strip -> rawSystemProgram verbosity strip args + Nothing -> unless (buildOS == Windows) $ + -- Don't bother warning on windows, we don't expect them to + -- have the strip program anyway. + warn verbosity $ "Unable to strip executable '" ++ name + ++ "' (missing the 'strip' program)" + where + args = path : case buildOS 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. + _ -> [] + +-- |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 + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do + -- copy .hi files over: + let copy src dst n = do + createDirectoryIfMissingVerbose verbosity True dst + installOrdinaryFile verbosity (src n) (dst n) + copyModuleFiles ext = + findModuleFiles [builtDir] [ext] (libModules lib) + >>= installOrdinaryFiles verbosity targetDir + ifVanilla $ copyModuleFiles "hi" + ifProf $ copyModuleFiles "p_hi" + hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (libModules lib) + flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase srcFile] + + -- copy the built library files over: + ifVanilla $ copy builtDir targetDir vanillaLibName + ifProf $ copy builtDir targetDir profileLibName + ifGHCi $ copy builtDir targetDir ghciLibName + ifShared $ copy builtDir dynlibTargetDir sharedLibName + + -- run ranlib if necessary: + ifVanilla $ updateLibArchive verbosity lbi + (targetDir vanillaLibName) + ifProf $ updateLibArchive verbosity lbi + (targetDir profileLibName) + + where + vanillaLibName = mkLibName pkgid + profileLibName = mkProfLibName pkgid + ghciLibName = mkGHCiLibName pkgid + sharedLibName = mkSharedLibName pkgid (compilerId (compiler lbi)) + + pkgid = packageId pkg + + hasLib = not $ null (libModules lib) + && null (cSources (libBuildInfo lib)) + ifVanilla = when (hasLib && withVanillaLib lbi) + ifProf = when (hasLib && withProfLib lbi) + ifGHCi = when (hasLib && withGHCiLib lbi) + ifShared = when (hasLib && withSharedLib lbi) + + runLhc = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) + +-- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems +-- like MacOS X. If we can't find those, don't worry too much about it. +-- +updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO () +updateLibArchive verbosity lbi path = + case lookupProgram ranlibProgram (withPrograms lbi) of + Just ranlib -> rawSystemProgram verbosity ranlib [path] + Nothing -> case lookupProgram arProgram (withPrograms lbi) of + Just ar -> rawSystemProgram verbosity ar ["-s", path] + Nothing -> warn verbosity $ + "Unable to generate a symbol index for the static " + ++ "library '" ++ path + ++ "' (missing the 'ranlib' and 'ar' programs)" + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> 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) diff --git a/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs b/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs @@ -0,0 +1,337 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.LocalBuildInfo +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Once a package has been configured we have resolved conditionals and +-- dependencies, configured the compiler and other needed external programs. +-- The 'LocalBuildInfo' is used to hold all this information. It holds the +-- install dirs, the compiler, the exact package dependencies, the configured +-- programs, the package database to use and a bunch of miscellaneous configure +-- 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, + + -- * Buildable package components + Component(..), + foldComponent, + componentBuildInfo, + allComponentsBy, + ComponentName(..), + ComponentLocalBuildInfo(..), + withComponentsLBI, + withLibLBI, + withExeLBI, + withTestLBI, + + -- * Installation directories + module Distribution.Simple.InstallDirs, + absoluteInstallDirs, prefixRelativeInstallDirs, + substPathTemplate + ) where + + +import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, + prefixRelativeInstallDirs, + substPathTemplate, ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.Program (ProgramConfiguration) +import Distribution.PackageDescription + ( PackageDescription(..), withLib, Library(libBuildInfo), withExe + , Executable(exeName, buildInfo), withTest, TestSuite(..) + , BuildInfo(buildable), Benchmark(..) ) +import Distribution.Package + ( PackageId, Package(..), InstalledPackageId(..) ) +import Distribution.Simple.Compiler + ( Compiler(..), PackageDBStack, OptimisationLevel ) +import Distribution.Simple.PackageIndex + ( PackageIndex ) +import Distribution.Simple.Utils + ( die ) +import Distribution.Simple.Setup + ( ConfigFlags ) +import Distribution.Text + ( display ) + +import Data.List (nub, find) + +-- | Data cached after configuration step. See also +-- 'Distribution.Simple.Setup.ConfigFlags'. +data LocalBuildInfo = LocalBuildInfo { + configFlags :: ConfigFlags, + -- ^ Options passed to the configuration step. + -- Needed to re-run configuration when .cabal is out of date + extraConfigArgs :: [String], + -- ^ Extra args on the command line for the configuration step. + -- Needed to re-run configuration when .cabal is out of date + installDirTemplates :: InstallDirTemplates, + -- ^ The installation directories for the various differnt + -- kinds of files + --TODO: inplaceDirTemplates :: InstallDirs FilePath + compiler :: Compiler, + -- ^ The compiler we're building with + 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. + libraryConfig :: Maybe ComponentLocalBuildInfo, + executableConfigs :: [(String, ComponentLocalBuildInfo)], + compBuildOrder :: [ComponentName], + -- ^ All the components to build, ordered by topological sort + -- over the intrapackage dependency graph + testSuiteConfigs :: [(String, ComponentLocalBuildInfo)], + benchmarkConfigs :: [(String, ComponentLocalBuildInfo)], + installedPkgs :: PackageIndex, + -- ^ All the info about the installed packages that the + -- current package depends on (directly or indirectly). + pkgDescrFile :: Maybe FilePath, + -- ^ the filename containing the .cabal file, if available + localPkgDescr :: PackageDescription, + -- ^ The resolved package description, that does not contain + -- any conditionals. + withPrograms :: ProgramConfiguration, -- ^Location and args for all programs + withPackageDB :: PackageDBStack, -- ^What package database to use, global\/user + withVanillaLib:: Bool, -- ^Whether to build normal libs. + withProfLib :: Bool, -- ^Whether to build profiling versions of libs. + withSharedLib :: Bool, -- ^Whether to build shared versions of libs. + withDynExe :: Bool, -- ^Whether to link executables dynamically + withProfExe :: Bool, -- ^Whether to build executables for profiling. + withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (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 + progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables + progSuffix :: PathTemplate -- ^Suffix to be appended to installed executables + } deriving (Read, Show) + +-- | 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)] +externalPackageDeps lbi = filter (not . internal . snd) $ nub $ + -- TODO: what about non-buildable components? + maybe [] componentPackageDeps (libraryConfig lbi) + ++ concatMap (componentPackageDeps . snd) (executableConfigs lbi) + ++ concatMap (componentPackageDeps . snd) (testSuiteConfigs lbi) + ++ concatMap (componentPackageDeps . snd) (benchmarkConfigs lbi) + where + -- True if this dependency is an internal one (depends on the library + -- defined in the same package). + internal pkgid = pkgid == packageId (localPkgDescr lbi) + +-- | The installed package Id we use for local packages registered in the local +-- package db. This is what is used for intra-package deps between components. +-- +inplacePackageId :: PackageId -> InstalledPackageId +inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace") + +-- ----------------------------------------------------------------------------- +-- Buildable components + +data Component = CLib Library + | CExe Executable + | CTest TestSuite + | CBench Benchmark + deriving (Show, Eq, Read) + +data ComponentName = CLibName -- currently only a single lib + | CExeName String + | CTestName String + | CBenchName String + deriving (Show, Eq, Read) + +data ComponentLocalBuildInfo = ComponentLocalBuildInfo { + -- | Resolved internal and external package dependencies for this component. + -- The 'BuildInfo' specifies a set of build dependencies that must be + -- satisfied in terms of version ranges. This field fixes those dependencies + -- to the specific versions available on this machine for this compiler. + componentPackageDeps :: [(InstalledPackageId, PackageId)] + } + deriving (Read, Show) + +foldComponent :: (Library -> a) + -> (Executable -> a) + -> (TestSuite -> a) + -> (Benchmark -> a) + -> Component + -> a +foldComponent f _ _ _ (CLib lib) = f lib +foldComponent _ f _ _ (CExe exe) = f exe +foldComponent _ _ f _ (CTest tst) = f tst +foldComponent _ _ _ f (CBench bch) = f bch + +componentBuildInfo :: Component -> BuildInfo +componentBuildInfo = + foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo + +-- | Obtains all components (libs, exes, or test suites), transformed by the +-- given function. Useful for gathering dependencies with component context. +allComponentsBy :: PackageDescription + -> (Component -> a) + -> [a] +allComponentsBy pkg_descr f = + [ f (CLib lib) | Just lib <- [library pkg_descr] + , buildable (libBuildInfo lib) ] + ++ [ f (CExe exe) | exe <- executables pkg_descr + , buildable (buildInfo exe) ] + ++ [ f (CTest tst) | tst <- testSuites pkg_descr + , buildable (testBuildInfo tst) + , testEnabled tst ] + ++ [ f (CBench bm) | bm <- benchmarks pkg_descr + , buildable (benchmarkBuildInfo bm) + , benchmarkEnabled bm ] + +-- |If the package description has a library section, call the given +-- function with the library build info as argument. Extended version of +-- 'withLib' that also gives corresponding build info. +withLibLBI :: PackageDescription -> LocalBuildInfo + -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO () +withLibLBI pkg_descr lbi f = withLib pkg_descr $ \lib -> + case libraryConfig lbi of + Just clbi -> f lib clbi + Nothing -> die missingLibConf + +-- | Perform the action on each buildable 'Executable' in the package +-- description. Extended version of 'withExe' that also gives corresponding +-- build info. +withExeLBI :: PackageDescription -> LocalBuildInfo + -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO () +withExeLBI pkg_descr lbi f = withExe pkg_descr $ \exe -> + case lookup (exeName exe) (executableConfigs lbi) of + Just clbi -> f exe clbi + Nothing -> die (missingExeConf (exeName exe)) + +withTestLBI :: PackageDescription -> LocalBuildInfo + -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO () +withTestLBI pkg_descr lbi f = withTest pkg_descr $ \test -> + case lookup (testName test) (testSuiteConfigs lbi) of + Just clbi -> f test clbi + Nothing -> die (missingTestConf (testName test)) + +-- | Perform the action on each buildable 'Library' or 'Executable' (Component) +-- in the PackageDescription, subject to the build order specified by the +-- 'compBuildOrder' field of the given 'LocalBuildInfo' +withComponentsLBI :: PackageDescription -> LocalBuildInfo + -> (Component -> ComponentLocalBuildInfo -> IO ()) + -> IO () +withComponentsLBI pkg_descr lbi f = mapM_ compF (compBuildOrder lbi) + where + compF CLibName = + case library pkg_descr of + Nothing -> die missinglib + Just lib -> case libraryConfig lbi of + Nothing -> die missingLibConf + Just clbi -> f (CLib lib) clbi + where + missinglib = "internal error: component list includes a library " + ++ "but the package description contains no library" + + compF (CExeName name) = + case find (\exe -> exeName exe == name) (executables pkg_descr) of + Nothing -> die missingexe + Just exe -> case lookup name (executableConfigs lbi) of + Nothing -> die (missingExeConf name) + Just clbi -> f (CExe exe) clbi + where + missingexe = "internal error: component list includes an executable " + ++ name ++ " but the package contains no such executable." + + compF (CTestName name) = + case find (\tst -> testName tst == name) (testSuites pkg_descr) of + Nothing -> die missingtest + Just tst -> case lookup name (testSuiteConfigs lbi) of + Nothing -> die (missingTestConf name) + Just clbi -> f (CTest tst) clbi + where + missingtest = "internal error: component list includes a test suite " + ++ name ++ " but the package contains no such test suite." + + compF (CBenchName name) = + case find (\bch -> benchmarkName bch == name) (benchmarks pkg_descr) of + Nothing -> die missingbench + Just bch -> case lookup name (benchmarkConfigs lbi) of + Nothing -> die (missingBenchConf name) + Just clbi -> f (CBench bch) clbi + where + missingbench = "internal error: component list includes a benchmark " + ++ name ++ " but the package contains no such benchmark." + +missingLibConf :: String +missingExeConf, missingTestConf, missingBenchConf :: String -> String + +missingLibConf = "internal error: the package contains a library " + ++ "but there is no corresponding configuration data" +missingExeConf name = "internal error: the package contains an executable " + ++ name ++ " but there is no corresponding configuration data" +missingTestConf name = "internal error: the package contains a test suite " + ++ name ++ " but there is no corresponding configuration data" +missingBenchConf name = "internal error: the package contains a benchmark " + ++ name ++ " but there is no corresponding configuration data" + + +-- ----------------------------------------------------------------------------- +-- Wrappers for a couple functions from InstallDirs + +-- |See 'InstallDirs.absoluteInstallDirs' +absoluteInstallDirs :: PackageDescription -> LocalBuildInfo -> CopyDest + -> InstallDirs FilePath +absoluteInstallDirs pkg lbi copydest = + InstallDirs.absoluteInstallDirs + (packageId pkg) + (compilerId (compiler lbi)) + copydest + (installDirTemplates lbi) + +-- |See 'InstallDirs.prefixRelativeInstallDirs' +prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo + -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs pkg_descr lbi = + InstallDirs.prefixRelativeInstallDirs + (packageId pkg_descr) + (compilerId (compiler lbi)) + (installDirTemplates lbi) + +substPathTemplate :: PackageId -> LocalBuildInfo + -> PathTemplate -> FilePath +substPathTemplate pkgid lbi = fromPathTemplate + . ( InstallDirs.substPathTemplate env ) + where env = initialPathTemplateEnv + pkgid + (compilerId (compiler lbi)) diff --git a/cabal/Cabal/Distribution/Simple/NHC.hs b/cabal/Cabal/Distribution/Simple/NHC.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/NHC.hs @@ -0,0 +1,424 @@ +----------------------------------------------------------------------------- +-- | +-- 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(..) + , packageId, 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 Data.Monoid ( Monoid(..) ) +import Control.Monad ( when, unless ) +import Distribution.Compat.Exception + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, 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 + } + return (comp, 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 + 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 (packageId pkg_descr) + 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 + -> IO () +installLib verbosity pref buildPref pkgid lib + = do let bi = libBuildInfo lib + modules = exposedModules lib ++ otherModules bi + findModuleFiles [buildPref] ["hi"] modules + >>= installOrdinaryFiles verbosity pref + let libName = mkLibName pkgid + installOrdinaryFile verbosity (buildPref libName) (pref libName) diff --git a/cabal/Cabal/Distribution/Simple/PackageIndex.hs b/cabal/Cabal/Distribution/Simple/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/PackageIndex.hs @@ -0,0 +1,574 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PackageIndex +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007, +-- Duncan Coutts 2008-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- An index of packages. +-- +module Distribution.Simple.PackageIndex ( + -- * Package index data type + PackageIndex, + + -- * Creating an index + fromList, + + -- * Updates + merge, + + insert, + + deleteInstalledPackageId, + deleteSourcePackageId, + deletePackageName, +-- deleteDependency, + + -- * Queries + + -- ** Precise lookups + lookupInstalledPackageId, + lookupSourcePackageId, + lookupPackageName, + lookupDependency, + + -- ** Case-insensitive searches + searchByName, + SearchResult(..), + searchByNameSubstring, + + -- ** Bulk queries + allPackages, + allPackagesByName, + allPackagesBySourcePackageId, + + -- ** Special queries + brokenPackages, + dependencyClosure, + reverseDependencyClosure, + topologicalOrder, + reverseTopologicalOrder, + dependencyInconsistencies, + dependencyCycles, + dependencyGraph, + 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 Data.List as List + ( null, foldl', sort + , groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy ) +import Data.Monoid (Monoid(..)) +import Data.Maybe (isNothing, fromMaybe) + +import Distribution.Package + ( PackageName(..), PackageId + , Package(..), packageName, packageVersion + , Dependency(Dependency)--, --PackageFixedDeps(..) + , InstalledPackageId(..) ) +import Distribution.ModuleName + ( ModuleName ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo, installedPackageId ) +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. +-- +-- Packages are uniquely identified in by their 'InstalledPackageId', they can +-- also be effeciently looked up by package name or by name and version. +-- +data PackageIndex = PackageIndex + -- The primary index. Each InstalledPackageInfo record is uniquely identified + -- by its InstalledPackageId. + -- + !(Map InstalledPackageId InstalledPackageInfo) + + -- This auxillary 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. + -- + -- It is a three-level index. The first level is the package name, + -- the second is the package version and the final level is instances + -- of the same package version. These are unique by InstalledPackageId + -- and are kept in preference order. + -- + !(Map PackageName (Map Version [InstalledPackageInfo])) + + deriving (Show, Read) + +instance Monoid PackageIndex 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 (PackageIndex pids pnames) = + map installedPackageId (Map.elems pids) + == sort + [ assert pinstOk (installedPackageId pinst) + | (pname, pvers) <- Map.toList pnames + , let pversOk = not (Map.null pvers) + , (pver, pinsts) <- assert pversOk $ Map.toList pvers + , let pinsts' = sortBy (comparing installedPackageId) pinsts + pinstsOk = all (\g -> length g == 1) + (groupBy (equating installedPackageId) pinsts') + , pinst <- assert pinstsOk $ pinsts' + , let pinstOk = packageName pinst == pname + && packageVersion pinst == pver + ] + + +-- +-- * Internal helpers +-- + +mkPackageIndex :: Map InstalledPackageId InstalledPackageInfo + -> Map PackageName (Map Version [InstalledPackageInfo]) + -> PackageIndex +mkPackageIndex pids pnames = assert (invariant index) index + where index = PackageIndex pids pnames + + +-- +-- * Construction +-- + +-- | Build an index out of a bunch of packages. +-- +-- If there are duplicates by 'InstalledPackageId' then later ones mask earlier +-- ones. +-- +fromList :: [InstalledPackageInfo] -> PackageIndex +fromList pkgs = mkPackageIndex pids pnames + where + pids = Map.fromList [ (installedPackageId pkg, pkg) | pkg <- pkgs ] + pnames = + Map.fromList + [ (packageName (head pkgsN), pvers) + | pkgsN <- groupBy (equating packageName) + . sortBy (comparing packageId) + $ pkgs + , let pvers = + Map.fromList + [ (packageVersion (head pkgsNV), + nubBy (equating installedPackageId) (reverse pkgsNV)) + | pkgsNV <- groupBy (equating packageVersion) pkgsN + ] + ] + +-- +-- * Updates +-- + +-- | Merge two indexes. +-- +-- Packages from the second mask packages from the first if they have the exact +-- same 'InstalledPackageId'. +-- +-- For packages with the same source 'PackageId', packages from the second are +-- \"preferred\" over those from the first. Being preferred means they are top +-- 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 (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = + mkPackageIndex (Map.union pids1 pids2) + (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) + where + -- Packages in the second list mask those in the first, however preferred + -- packages go first in the list. + mergeBuckets xs ys = ys ++ (xs \\ ys) + (\\) = deleteFirstsBy (equating installedPackageId) + + +-- | Inserts a single package into the index. +-- +-- This is equivalent to (but slightly quicker than) using 'mappend' or +-- 'merge' with a singleton index. +-- +insert :: InstalledPackageInfo -> PackageIndex -> PackageIndex +insert pkg (PackageIndex pids pnames) = + mkPackageIndex pids' pnames' + + where + pids' = Map.insert (installedPackageId pkg) pkg pids + pnames' = insertPackageName pnames + insertPackageName = + Map.insertWith' (\_ -> insertPackageVersion) + (packageName pkg) + (Map.singleton (packageVersion pkg) [pkg]) + + insertPackageVersion = + Map.insertWith' (\_ -> insertPackageInstance) + (packageVersion pkg) [pkg] + + insertPackageInstance pkgs = + pkg : deleteBy (equating installedPackageId) pkg pkgs + + +-- | Removes a single installed package from the index. +-- +deleteInstalledPackageId :: InstalledPackageId -> PackageIndex -> PackageIndex +deleteInstalledPackageId ipkgid original@(PackageIndex pids pnames) = + case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of + (Nothing, _) -> original + (Just spkgid, pids') -> mkPackageIndex pids' + (deletePkgName spkgid pnames) + + where + deletePkgName spkgid = + Map.update (deletePkgVersion spkgid) (packageName spkgid) + + deletePkgVersion spkgid = + (\m -> if Map.null m then Nothing else Just m) + . Map.update deletePkgInstance (packageVersion spkgid) + + deletePkgInstance = + (\xs -> if List.null xs then Nothing else Just xs) + . List.deleteBy (\_ pkg -> installedPackageId pkg == ipkgid) undefined + + +-- | Removes all packages with this source 'PackageId' from the index. +-- +deleteSourcePackageId :: PackageId -> PackageIndex -> PackageIndex +deleteSourcePackageId pkgid original@(PackageIndex pids pnames) = + case Map.lookup (packageName pkgid) pnames of + Nothing -> original + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> original + Just pkgs -> mkPackageIndex + (foldl' (flip (Map.delete . installedPackageId)) pids pkgs) + (deletePkgName pnames) + where + deletePkgName = + Map.update deletePkgVersion (packageName pkgid) + + deletePkgVersion = + (\m -> if Map.null m then Nothing else Just m) + . Map.delete (packageVersion pkgid) + + +-- | Removes all packages with this (case-sensitive) name from the index. +-- +deletePackageName :: PackageName -> PackageIndex -> PackageIndex +deletePackageName name original@(PackageIndex pids pnames) = + case Map.lookup name pnames of + Nothing -> original + Just pvers -> mkPackageIndex + (foldl' (flip (Map.delete . installedPackageId)) pids + (concat (Map.elems pvers))) + (Map.delete name pnames) + +{- +-- | Removes all packages satisfying this dependency from the index. +-- +deleteDependency :: Dependency -> PackageIndex -> PackageIndex +deleteDependency (Dependency name verstionRange) = + delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange) +-} + +-- +-- * Bulk queries +-- + +-- | Get all the packages from the index. +-- +allPackages :: PackageIndex -> [InstalledPackageInfo] +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 _ pnames) = + [ (pkgname, concat (Map.elems pvers)) + | (pkgname, pvers) <- Map.toList pnames ] + +-- | Get all the packages from the index. +-- +-- They are grouped by source package id (package name and version). +-- +allPackagesBySourcePackageId :: PackageIndex -> [(PackageId, [InstalledPackageInfo])] +allPackagesBySourcePackageId (PackageIndex _ pnames) = + [ (packageId ipkg, ipkgs) + | pvers <- Map.elems pnames + , ipkgs@(ipkg:_) <- Map.elems pvers ] + +-- +-- * Lookups +-- + +-- | Does a lookup by source package id (name & version). +-- +-- Since multiple package DBs mask each other by 'InstalledPackageId', +-- then we get back at most one package. +-- +lookupInstalledPackageId :: PackageIndex -> InstalledPackageId + -> Maybe InstalledPackageInfo +lookupInstalledPackageId (PackageIndex pids _) pid = Map.lookup pid pids + + +-- | Does a lookup by source package id (name & version). +-- +-- There can be multiple installed packages with the same source 'PackageId' +-- but different 'InstalledPackageId'. They are returned in order of +-- preference, with the most preferred first. +-- +lookupSourcePackageId :: PackageIndex -> PackageId -> [InstalledPackageInfo] +lookupSourcePackageId (PackageIndex _ pnames) pkgid = + case Map.lookup (packageName pkgid) pnames of + Nothing -> [] + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> [] + Just pkgs -> pkgs -- in preference order + + +-- | Does a lookup by source package name. +-- +lookupPackageName :: PackageIndex -> PackageName + -> [(Version, [InstalledPackageInfo])] +lookupPackageName (PackageIndex _ pnames) name = + case Map.lookup name pnames of + Nothing -> [] + Just pvers -> Map.toList pvers + + +-- | Does a lookup by source package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +lookupDependency :: PackageIndex -> Dependency + -> [(Version, [InstalledPackageInfo])] +lookupDependency (PackageIndex _ pnames) (Dependency name versionRange) = + case Map.lookup name pnames of + Nothing -> [] + Just pvers -> [ entry + | entry@(ver, _) <- Map.toList pvers + , ver `withinRange` versionRange ] + +-- +-- * Case insensitive name lookups +-- + +-- | Does a case-insensitive search by package name. +-- +-- If there is only one package that compares case-insentiviely 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 +-- unambiguous. +-- +-- If however several match case-insentiviely 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 _ pnames) name = + case [ pkgs | pkgs@(PackageName name',_) <- Map.toList pnames + , lowercase name' == lname ] of + [] -> None + [(_,pvers)] -> Unambiguous (concat (Map.elems pvers)) + pkgss -> case find ((PackageName name==) . fst) pkgss of + Just (_,pvers) -> Unambiguous (concat (Map.elems pvers)) + Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) + where lname = lowercase name + +data SearchResult a = None | Unambiguous a | Ambiguous [a] + +-- | Does a case-insensitive substring search by package name. +-- +-- That is, all packages that contain the given string in their name. +-- +searchByNameSubstring :: PackageIndex -> String -> [InstalledPackageInfo] +searchByNameSubstring (PackageIndex _ pnames) searchterm = + [ pkg + | (PackageName name, pvers) <- Map.toList pnames + , lsearchterm `isInfixOf` lowercase name + , pkgs <- Map.elems pvers + , pkg <- pkgs ] + where lsearchterm = lowercase searchterm + + +-- +-- * Special queries +-- + +-- None of the stuff below depends on the internal representation of the index. +-- + +-- | 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 :: PackageIndex -> [[InstalledPackageInfo]] +dependencyCycles index = + [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] + where + adjacencyList = [ (pkg, installedPackageId pkg, IPI.depends pkg) + | pkg <- allPackages index ] + + +-- | All packages that have immediate dependencies that are not in the index. +-- +-- Returns such packages along with the dependencies that they're missing. +-- +brokenPackages :: PackageIndex -> [(InstalledPackageInfo, [InstalledPackageId])] +brokenPackages index = + [ (pkg, missing) + | pkg <- allPackages index + , let missing = [ pkg' | pkg' <- IPI.depends 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 +-- 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 'PackageId's do not occur in the index. +-- +dependencyClosure :: PackageIndex + -> [InstalledPackageId] + -> Either PackageIndex + [(InstalledPackageInfo, [InstalledPackageId])] +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 lookupInstalledPackageId index pkgid of + Nothing -> closure completed (pkgid:failed) pkgids + Just pkg -> case lookupInstalledPackageId completed (installedPackageId pkg) of + Just _ -> closure completed failed pkgids + Nothing -> closure completed' failed pkgids' + where completed' = insert pkg completed + pkgids' = IPI.depends pkg ++ pkgids + +-- | Takes the transitive closure of the packages reverse dependencies. +-- +-- * The given 'PackageId's must be in the index. +-- +reverseDependencyClosure :: PackageIndex + -> [InstalledPackageId] + -> [InstalledPackageInfo] +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 :: PackageIndex -> [InstalledPackageInfo] +topologicalOrder index = map toPkgId + . Graph.topSort + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +reverseTopologicalOrder :: PackageIndex -> [InstalledPackageInfo] +reverseTopologicalOrder index = map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkgId, _) = dependencyGraph 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 :: PackageIndex + -> (Graph.Graph, + Graph.Vertex -> InstalledPackageInfo, + 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) ] + | pkg <- pkgs ] + + pkgs = sortBy (comparing packageId) (allPackages index) + vertices = zip (map installedPackageId pkgs) [0..] + vertex_map = Map.fromList vertices + id_to_vertex pid = Map.lookup pid vertex_map + + vertex_to_pkg vertex = pkgTable ! vertex + + pkgTable = Array.listArray bounds pkgs + topBound = length pkgs - 1 + bounds = (0, topBound) + +-- | 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 :: PackageIndex + -> [(PackageName, [(PackageId, Version)])] +dependencyInconsistencies index = + [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids]) + | (name, ipid_map) <- Map.toList inverseIndex + , let uses = Map.elems ipid_map + , reallyIsInconsistent (map fst uses) ] + + where -- for each PackageName, + -- 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 + , Just dep <- [lookupInstalledPackageId index ipid] + ] + + reallyIsInconsistent :: [InstalledPackageInfo] -> Bool + reallyIsInconsistent [] = False + reallyIsInconsistent [_p] = False + reallyIsInconsistent [p1, p2] = + installedPackageId p1 `notElem` IPI.depends p2 + && installedPackageId p2 `notElem` IPI.depends p1 + reallyIsInconsistent _ = True + + +moduleNameIndex :: PackageIndex -> Map ModuleName [InstalledPackageInfo] +moduleNameIndex index = + Map.fromListWith (++) + [ (moduleName, [pkg]) + | pkg <- allPackages index + , moduleName <- IPI.exposedModules pkg ] diff --git a/cabal/Cabal/Distribution/Simple/PreProcess.hs b/cabal/Cabal/Distribution/Simple/PreProcess.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/PreProcess.hs @@ -0,0 +1,608 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PreProcess +-- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines a 'PreProcessor' abstraction which represents a pre-processor +-- that can transform one kind of file into another. There is also a +-- 'PPSuffixHandler' which is a combination of a file extension and a function +-- for configuring a 'PreProcessor'. It defines a bunch of known built-in +-- preprocessors like @cpp@, @cpphs@, @c2hs@, @hsc2hs@, @happy@, @alex@ etc and +-- lists them in 'knownSuffixHandlers'. On top of this it provides a function +-- for actually preprocessing some sources given a bunch of known suffix +-- 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(..), + mkSimplePreProcessor, runSimplePreProcessor, + ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, + ppHappy, ppAlex, ppUnlit + ) + where + + +import Control.Monad +import Distribution.Simple.PreProcess.Unlit (unlit) +import Distribution.Package + ( Package(..), PackageName(..) ) +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..) + , Executable(..) + , Library(..), libModules + , TestSuite(..), testModules + , TestSuiteInterface(..) + , Benchmark(..), benchmarkModules, BenchmarkInterface(..) ) +import qualified Distribution.InstalledPackageInfo as Installed + ( InstalledPackageInfo_(..) ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.Compiler + ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), Component(..) ) +import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File + , die, setupMessage, intercalate, copyFileVerbose + , findFileWithExtension, findFileWithExtension' ) +import Distribution.Simple.Program + ( Program(..), ConfiguredProgram(..), programPath + , lookupProgram, requireProgram, requireProgramVersion + , rawSystemProgramConf, rawSystemProgram + , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram + , happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram ) +import Distribution.Simple.Test ( writeSimpleTestStub, stubFilePath, stubName ) +import Distribution.System + ( OS(OSX, Windows), buildOS ) +import Distribution.Text +import Distribution.Version + ( Version(..), anyVersion, orLaterVersion ) +import Distribution.Verbosity + +import Data.Maybe (fromMaybe) +import Data.List (nub) +import System.Directory (getModificationTime, doesFileExist) +import System.Info (os, arch) +import System.FilePath (splitExtension, dropExtensions, (), (<.>), + takeDirectory, normalise, replaceExtension) + +-- |The interface to a preprocessor, which may be implemented using an +-- external program, but need not be. The arguments are the name of +-- the input file, the name of the output file and a verbosity level. +-- Here is a simple example that merely prepends a comment to the given +-- source file: +-- +-- > ppTestHandler :: PreProcessor +-- > ppTestHandler = +-- > PreProcessor { +-- > platformIndependent = True, +-- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> +-- > do info verbosity (inFile++" has been preprocessed to "++outFile) +-- > stuff <- readFile inFile +-- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) +-- > return ExitSuccess +-- +-- We split the input and output file names into a base directory and the +-- rest of the file name. The input base dir is the path in the list of search +-- dirs that this file was found in. The output base dir is the build dir where +-- all the generated source files are put. +-- +-- 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 +-- .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 +-- 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) +-- +-- Most pre-processors do not care of course, so mkSimplePreProcessor and +-- runSimplePreProcessor functions handle the simple case. +-- +data PreProcessor = PreProcessor { + + -- Is the output of the pre-processor platform independent? eg happy output + -- is portable haskell but c2hs's output is platform dependent. + -- This matters since only platform independent generated code can be + -- inlcuded into a source tarball. + platformIndependent :: Bool, + + -- TODO: deal with pre-processors that have implementaion dependent output + -- eg alex and happy have --ghc flags. However we can't really inlcude + -- ghc-specific code into supposedly portable source tarballs. + + runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir + -> (FilePath, FilePath) -- Output file name, relative to an output base dir + -> Verbosity -- verbosity + -> IO () -- Should exit if the preprocessor fails + } + +mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ()) + -> (FilePath, FilePath) + -> (FilePath, FilePath) -> Verbosity -> IO () +mkSimplePreProcessor simplePP + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity + where inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity + -> IO () +runSimplePreProcessor pp inFile outFile verbosity = + runPreProcessor pp (".", inFile) (".", outFile) verbosity + +-- |A preprocessor for turning non-Haskell files with the given extension +-- into plain Haskell source files. +type PPSuffixHandler + = (String, BuildInfo -> LocalBuildInfo -> PreProcessor) + +-- | Apply preprocessors to the sources from 'hsSourceDirs' for a given +-- component (lib, exe, or test suite). +preprocessComponent :: PackageDescription + -> Component + -> LocalBuildInfo + -> Bool + -> Verbosity + -> [PPSuffixHandler] + -> IO () +preprocessComponent pd comp lbi isSrcDist verbosity handlers = case comp of + (CLib lib@Library{ libBuildInfo = bi }) -> do + let dirs = hsSourceDirs bi ++ [autogenModulesDir lbi] + setupMessage verbosity "Preprocessing library" (packageId pd) + forM_ (map ModuleName.toFilePath $ libModules lib) $ + pre dirs (buildDir lbi) (localHandlers bi) + (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do + let exeDir = buildDir lbi nm nm ++ "-tmp" + dirs = hsSourceDirs bi ++ [autogenModulesDir lbi] + setupMessage verbosity ("Preprocessing executable '" ++ nm ++ "' for") (packageId pd) + forM_ (map ModuleName.toFilePath $ otherModules bi) $ + pre dirs exeDir (localHandlers bi) + pre (hsSourceDirs bi) exeDir (localHandlers bi) $ + dropExtensions (modulePath exe) + CTest test@TestSuite{ testName = nm } -> do + setupMessage verbosity ("Preprocessing test suite '" ++ nm ++ "' for") (packageId pd) + case testInterface test of + TestSuiteExeV10 _ f -> + preProcessTest test f $ buildDir lbi testName test + testName test ++ "-tmp" + TestSuiteLibV09 _ _ -> do + let testDir = buildDir lbi stubName test + stubName test ++ "-tmp" + writeSimpleTestStub test testDir + preProcessTest test (stubFilePath test) testDir + TestSuiteUnsupported tt -> die $ "No support for preprocessing test " + ++ "suite type " ++ display tt + CBench bm@Benchmark{ benchmarkName = nm } -> do + setupMessage verbosity ("Preprocessing benchmark '" ++ nm ++ "' for") (packageId pd) + case benchmarkInterface bm of + BenchmarkExeV10 _ f -> + preProcessBench bm f $ buildDir lbi benchmarkName bm + benchmarkName bm ++ "-tmp" + BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark " + ++ "type " ++ display tt + where + builtinSuffixes + | NHC == compilerFlavor (compiler lbi) = ["hs", "lhs", "gc"] + | otherwise = ["hs", "lhs"] + localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] + pre dirs dir lhndlrs fp = + preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs + preProcessTest test = preProcessComponent (testBuildInfo test) + (testModules test) + preProcessBench bm = preProcessComponent (benchmarkBuildInfo bm) + (benchmarkModules bm) + preProcessComponent bi modules exePath dir = do + let biHandlers = localHandlers bi + sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ] + sequence_ [ preprocessFile sourceDirs (buildDir lbi) isSrcDist + (ModuleName.toFilePath modu) verbosity builtinSuffixes + biHandlers + | modu <- modules ] + preprocessFile (dir : (hsSourceDirs bi)) dir isSrcDist + (dropExtensions $ exePath) verbosity + builtinSuffixes biHandlers + +--TODO: try to list all the modules that could not be found +-- not just the first one. It's annoying and slow due to the need +-- to reconfigure after editing the .cabal file each time. + +-- |Find the first extension of the file that exists, and preprocess it +-- if required. +preprocessFile + :: [FilePath] -- ^source directories + -> FilePath -- ^build directory + -> Bool -- ^preprocess for sdist + -> FilePath -- ^module file name + -> Verbosity -- ^verbosity + -> [String] -- ^builtin suffixes + -> [(String, PreProcessor)] -- ^possible preprocessors + -> IO () +preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers = do + -- look for files in the various source dirs with this module name + -- and a file extension of a known preprocessor + psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc baseFile + case psrcFiles of + -- no preprocessor file exists, look for an ordinary source file + -- just to make sure one actually exists at all for this module. + -- Note: by looking in the target/output build dir too, we allow + -- source files to appear magically in the target build dir without + -- any corresponding "real" source file. This lets custom Setup.hs + -- files generate source modules directly into the build dir without + -- the rest of the build system being aware of it (somewhat dodgy) + Nothing -> do + bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : searchLoc) baseFile + case bsrcFiles of + Nothing -> die $ "can't find source for " ++ baseFile + ++ " in " ++ intercalate ", " searchLoc + _ -> return () + -- found a pre-processable file in one of the source dirs + Just (psrcLoc, psrcRelFile) -> do + let (srcStem, ext) = splitExtension psrcRelFile + psrcFile = psrcLoc psrcRelFile + pp = fromMaybe (error "Internal error in preProcess module: Just expected") + (lookup (tailNotNull ext) handlers) + -- Preprocessing files for 'sdist' is different from preprocessing + -- for 'build'. When preprocessing for sdist we preprocess to + -- avoid that the user has to have the preprocessors available. + -- ATM, we don't have a way to specify which files are to be + -- preprocessed and which not, so for sdist we only process + -- platform independent files and put them into the 'buildLoc' + -- (which we assume is set to the temp. directory that will become + -- the tarball). + --TODO: eliminate sdist variant, just supply different handlers + when (not forSDist || forSDist && platformIndependent pp) $ do + -- look for existing pre-processed source file in the dest dir to + -- see if we really have to re-run the preprocessor. + ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile + recomp <- case ppsrcFiles of + Nothing -> return True + Just ppsrcFile -> do + btime <- getModificationTime ppsrcFile + ptime <- getModificationTime psrcFile + return (btime < ptime) + when recomp $ do + let destDir = buildLoc dirName srcStem + createDirectoryIfMissingVerbose verbosity True destDir + runPreProcessorWithHsBootHack pp + (psrcLoc, psrcRelFile) + (buildLoc, srcStem <.> "hs") + + where + dirName = takeDirectory + tailNotNull [] = [] + tailNotNull x = tail x + + -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files + -- be in the same place as the hs files, so if we put the hs file in dist/ + -- then we need to copy the hs-boot file there too. This should probably be + -- done another way. Possibly we should also be looking for .lhs-boot + -- files, but I think that preprocessors only produce .hs files. + runPreProcessorWithHsBootHack pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) = do + runPreProcessor pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity + + exists <- doesFileExist inBoot + when exists $ copyFileVerbose verbosity inBoot outBoot + + where + inBoot = replaceExtension inFile "hs-boot" + outBoot = replaceExtension outFile "hs-boot" + + inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +-- ------------------------------------------------------------ +-- * known preprocessors +-- ------------------------------------------------------------ + +ppGreenCard :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppGreenCard _ lbi + = PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + rawSystemProgramConf verbosity greencardProgram (withPrograms lbi) + (["-tffi", "-o" ++ outFile, inFile]) + } + +-- This one is useful for preprocessors that can't handle literate source. +-- We also need a way to chain preprocessors. +ppUnlit :: PreProcessor +ppUnlit = + PreProcessor { + platformIndependent = True, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> + withUTF8FileContents inFile $ \contents -> + either (writeUTF8File outFile) die (unlit inFile contents) + } + +ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpp = ppCpp' [] + +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 + + where cppArgs = getCppOptions bi lbi + +ppGhcCpp :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppGhcCpp extraArgs _bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (ghcProg, ghcVersion, _) <- requireProgramVersion verbosity + ghcProgram anyVersion (withPrograms lbi) + rawSystemProgram verbosity ghcProg $ + ["-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 []) + ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] + ++ ["-o", outFile, inFile] + ++ extraArgs + } + +ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpphs extraArgs _bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity + cpphsProgram anyVersion (withPrograms lbi) + rawSystemProgram verbosity cpphsProg $ + ("-O" ++ outFile) : inFile + : "--noline" : "--strip" + : (if cpphsVersion >= Version [1,6] [] + then ["--include="++ (autogenModulesDir lbi cppHeaderName)] + else []) + ++ 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 { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + rawSystemProgramConf verbosity hsc2hsProgram (withPrograms lbi) $ + [ "--cc=" ++ programPath gccProg + , "--ld=" ++ programPath gccProg ] + + -- Additional gcc options + ++ [ "--cflag=" ++ opt | opt <- programDefaultArgs gccProg + ++ programOverrideArgs gccProg ] + ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs gccProg + ++ programOverrideArgs gccProg ] + + -- OSX frameworks: + ++ [ what ++ "=-F" ++ opt + | isOSX + , opt <- nub (concatMap Installed.frameworkDirs pkgs) + , what <- ["--cflag", "--lflag"] ] + ++ [ "--lflag=" ++ arg + | isOSX + , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs + , arg <- ["-framework", opt] ] + + -- Note that on ELF systems, wherever we use -L, we must also use -R + -- because presumably that -L dir is not on the normal path for the + -- system's dynamic linker. This is needed because hsc2hs works by + -- compiling a C program and then running it. + + ++ [ "--cflag=" ++ opt | opt <- hcDefines (compiler lbi) ] + ++ [ "--cflag=" ++ opt | opt <- sysDefines ] + + -- Options from the current package: + ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ] + ++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi + ++ PD.cppOptions bi ] + ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ] + ++ [ "--lflag=-Wl,-R," ++ opt | isELF + , opt <- PD.extraLibDirs bi ] + ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs bi ] + ++ [ "--lflag=" ++ opt | opt <- PD.ldOptions bi ] + + -- Options from dependent packages + ++ [ "--cflag=" ++ opt + | pkg <- pkgs + , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] + ++ [ opt | opt <- Installed.ccOptions pkg ] + ++ [ "-I" ++ autogenModulesDir lbi, + "-include", autogenModulesDir lbi cppHeaderName ] ] + ++ [ "--lflag=" ++ opt + | pkg <- pkgs + , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] + ++ [ "-Wl,-R," ++ opt | isELF + , opt <- Installed.libraryDirs pkg ] + ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ] + ++ [ opt | opt <- Installed.ldOptions pkg ] ] + ++ ["-o", outFile, inFile] + } + where + pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi)) + 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 + -- 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 + -- ldOptions for GHC's rts package: + hackRtsPackage index = + case PackageIndex.lookupPackageName index (PackageName "rts") of + [(_, [rts])] + -> PackageIndex.insert rts { Installed.ldOptions = [] } index + _ -> error "No (or multiple) ghc rts package is registered!!" + + +ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppC2hs bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = \(inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity -> do + (c2hsProg, _, _) <- requireProgramVersion verbosity + c2hsProgram (orLaterVersion (Version [0,15] [])) + (withPrograms lbi) + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + rawSystemProgram verbosity c2hsProg $ + + -- Options from the current package: + [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] + ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ] + ++ [ "--include=" ++ outBaseDir ] + + -- Options from dependent packages + ++ [ "--cppopts=" ++ opt + | pkg <- pkgs + , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] + ++ [ opt | opt@('-':c:_) <- Installed.ccOptions pkg + , c `elem` "DIU" ] ] + --TODO: install .chi files for packages, so we can --include + -- those dirs here, for the dependencies + + -- input and output files + ++ [ "--output-dir=" ++ outBaseDir + , "--output=" ++ outRelativeFile + , inBaseDir inRelativeFile ] + } + where + pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) + +--TODO: perhaps use this with hsc2hs too +--TODO: remove cc-options from cpphs for cabal-version: >= 1.10 +getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] +getCppOptions bi lbi + = hcDefines (compiler lbi) + ++ sysDefines + ++ cppOptions bi + ++ ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ [opt | opt@('-':c:_) <- PD.ccOptions bi, c `elem` "DIU"] + +sysDefines :: [String] +sysDefines = ["-D" ++ os ++ "_" ++ loc ++ "_OS" | loc <- locations] + ++ ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations] + where + locations = ["BUILD", "HOST"] + +hcDefines :: Compiler -> [String] +hcDefines comp = + case compilerFlavor comp of + GHC -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version] + JHC -> ["-D__JHC__=" ++ versionInt version] + NHC -> ["-D__NHC__=" ++ versionInt version] + Hugs -> ["-D__HUGS__"] + _ -> [] + where version = compilerVersion 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. +versionInt :: Version -> String +versionInt (Version { versionBranch = [] }) = "1" +versionInt (Version { versionBranch = [n] }) = show n +versionInt (Version { versionBranch = n1:n2:_ }) + = -- 6.8.x -> 608 + -- 6.10.x -> 610 + let s1 = show n1 + s2 = show n2 + middle = case s2 of + _ : _ : _ -> "" + _ -> "0" + in s1 ++ middle ++ s2 + +ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppHappy _ lbi = pp { platformIndependent = True } + where pp = standardPP lbi happyProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-agc"] + hcFlags _ = [] + +ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppAlex _ lbi = pp { platformIndependent = True } + where pp = standardPP lbi alexProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-g"] + hcFlags _ = [] + +standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor +standardPP lbi prog args = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + rawSystemProgramConf verbosity prog (withPrograms lbi) + (args ++ ["-o", outFile, inFile]) + } + +-- |Convenience function; get the suffixes of these preprocessors. +ppSuffixes :: [ PPSuffixHandler ] -> [String] +ppSuffixes = map fst + +-- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. +knownSuffixHandlers :: [ PPSuffixHandler ] +knownSuffixHandlers = + [ ("gc", ppGreenCard) + , ("chs", ppC2hs) + , ("hsc", ppHsc2hs) + , ("x", ppAlex) + , ("y", ppHappy) + , ("ly", ppHappy) + , ("cpphs", ppCpp) + ] diff --git a/cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs b/cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs @@ -0,0 +1,165 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PreProcess.Unlit +-- Copyright : ... +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Remove the \"literal\" markups from a Haskell source file, including +-- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\" + +-- This version is interesting because instead of striping comment lines, it +-- turns them into "-- " style comments. This allows using haddock markup +-- in literate scripts without having to use "> --" prefix. + +module Distribution.Simple.PreProcess.Unlit (unlit,plain) where + +import Data.Char +import Data.List + +data Classified = BirdTrack String | Blank String | Ordinary String + | Line !Int String | CPP String + | BeginCode | EndCode + -- output only: + | Error String | Comment String + +-- | No unliteration. +plain :: String -> String -> String +plain _ hs = hs + +classify :: String -> Classified +classify ('>':s) = BirdTrack s +classify ('#':s) = case tokens s of + (line:file:_) | all isDigit line + && length file >= 2 + && head file == '"' + && last file == '"' + -> Line (read line) (tail (init file)) + _ -> CPP s + where tokens = unfoldr $ \str -> case lex str of + (t@(_:_), str'):_ -> Just (t, str') + _ -> Nothing +classify ('\\':s) + | "begin{code}" `isPrefixOf` s = BeginCode + | "end{code}" `isPrefixOf` s = EndCode +classify s | all isSpace s = Blank s +classify s = Ordinary s + +-- So the weird exception for comment indenting is to make things work with +-- haddock, see classifyAndCheckForBirdTracks below. +unclassify :: Bool -> Classified -> String +unclassify _ (BirdTrack s) = ' ':s +unclassify _ (Blank s) = s +unclassify _ (Ordinary s) = s +unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file +unclassify _ (CPP s) = '#':s +unclassify True (Comment "") = " --" +unclassify True (Comment s) = " -- " ++ s +unclassify False (Comment "") = "--" +unclassify False (Comment s) = "-- " ++ s +unclassify _ _ = internalError + +-- | 'unlit' takes a filename (for error reports), and transforms the +-- given string, to eliminate the literate comments from the program text. +unlit :: FilePath -> String -> Either String String +unlit file input = + let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks + . inlines + $ input + in either (Left . unlines . map (unclassify usesBirdTracks)) + Right + . checkErrors + . reclassify + $ classified + + where + -- So haddock requires comments and code to align, since it treats comments + -- as following the layout rule. This is a pain for us since bird track + -- style literate code typically gets indented by two since ">" is replaced + -- by " " and people usually use one additional space of indent ie + -- "> then the code". On the other hand we cannot just go and indent all + -- the comments by two since that does not work for latex style literate + -- code. So the hacky solution we use here is that if we see any bird track + -- style code then we'll indent all comments by two, otherwise by none. + -- Of course this will not work for mixed latex/bird track .lhs files but + -- nobody does that, it's silly and specifically recommended against in the + -- H98 unlit spec. + -- + classifyAndCheckForBirdTracks = + flip mapAccumL False $ \seenBirdTrack line -> + let classification = classify line + in (seenBirdTrack || isBirdTrack classification, classification) + + isBirdTrack (BirdTrack _) = True + isBirdTrack _ = False + + checkErrors ls = case [ e | Error e <- ls ] of + [] -> Left ls + (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message) + where (f, n) = errorPos file 1 ls + errorPos f n [] = (f, n) + errorPos f n (Error _:_) = (f, n) + errorPos _ _ (Line n' f':ls) = errorPos f' n' ls + errorPos f n (_ :ls) = errorPos f (n+1) ls + +-- Here we model a state machine, with each state represented by +-- a local function. We only have four states (well, five, +-- if you count the error state), but the rules +-- to transition between then are not so simple. +-- Would it be simpler to have more states? +-- +-- Each state represents the type of line that was last read +-- i.e. are we in a comment section, or a latex-code section, +-- or a bird-code section, etc? +reclassify :: [Classified] -> [Classified] +reclassify = blank -- begin in blank state + where + latex [] = [] + latex (EndCode :ls) = Blank "" : comment ls + latex (BeginCode :_ ) = [Error "\\begin{code} in code section"] + latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls + latex ( l:ls) = l : latex ls + + blank [] = [] + blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] + blank (BeginCode :ls) = Blank "" : latex ls + blank (BirdTrack l:ls) = BirdTrack l : bird ls + blank (Ordinary l:ls) = Comment l : comment ls + blank ( l:ls) = l : blank ls + + bird [] = [] + bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] + bird (BeginCode :ls) = Blank "" : latex ls + bird (Blank l :ls) = Blank l : blank ls + bird (Ordinary _:_ ) = [Error "program line before comment line"] + bird ( l:ls) = l : bird ls + + comment [] = [] + comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] + comment (BeginCode :ls) = Blank "" : latex ls + comment (CPP l :ls) = CPP l : comment ls + comment (BirdTrack _:_ ) = [Error "comment line before program line"] + -- a blank line and another ordinary line following a comment + -- will be treated as continuing the comment. Otherwise it's + -- then end of the comment, with a blank line. + comment (Blank l:ls@(Ordinary _:_)) = Comment l : comment ls + comment (Blank l:ls) = Blank l : blank ls + comment (Line n f :ls) = Line n f : comment ls + comment (Ordinary l:ls) = Comment l : comment ls + comment (Comment _: _) = internalError + comment (Error _: _) = internalError + +-- Re-implementation of 'lines', for better efficiency (but decreased laziness). +-- Also, importantly, accepts non-standard DOS and Mac line ending characters. +inlines :: String -> [String] +inlines xs = lines' xs id + where + lines' [] acc = [acc []] + lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS + lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS + lines' ('\n':s) acc = acc [] : lines' s id -- Unix + lines' (c:s) acc = lines' s (acc . (c:)) + +internalError :: a +internalError = error "unlit: internal error" diff --git a/cabal/Cabal/Distribution/Simple/Program.hs b/cabal/Cabal/Distribution/Simple/Program.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Program.hs @@ -0,0 +1,218 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides an abstraction which deals with configuring and running +-- programs. A 'Program' is a static notion of a known program. A +-- 'ConfiguredProgram' is a 'Program' that has been found on the current +-- machine and is ready to be run (possibly with some user-supplied default +-- args). Configuring a program involves finding its location and if necessary +-- finding its version. There is also a 'ProgramConfiguration' type which holds +-- configured and not-yet configured programs. It is the parameter to lots of +-- actions elsewhere in Cabal that need to look up and run programs. If we had +-- a Cabal monad, the 'ProgramConfiguration' would probably be a reader or +-- state component of it. +-- +-- The module also defines all the known built-in 'Program's and the +-- 'defaultProgramConfiguration' which contains them all. +-- +-- One nice thing about using it is that any program that is +-- registered with Cabal will get some \"configure\" and \".cabal\" +-- helpers like --with-foo-args --foo-path= and extra-foo-args. +-- +-- There's also good default behavior for trying to find \"foo\" in +-- PATH, being able to override its location, etc. +-- +-- There's also a hook for adding programs in a Setup.lhs script. See +-- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a +-- hook user the ability to get the above flags and such so that they +-- don't have to write all the PATH logic inside Setup.lhs. + +module Distribution.Simple.Program ( + -- * Program and functions for constructing them + Program(..) + , simpleProgram + , findProgramLocation + , findProgramVersion + + -- * Configured program and related functions + , ConfiguredProgram(..) + , programPath + , ProgArg + , ProgramLocation(..) + , runProgram + , getProgramOutput + + -- * Program invocations + , ProgramInvocation(..) + , emptyProgramInvocation + , simpleProgramInvocation + , programInvocation + , runProgramInvocation + , getProgramInvocationOutput + + -- * The collection of unconfigured and configured progams + , builtinPrograms + + -- * The collection of configured programs we can run + , ProgramConfiguration + , emptyProgramConfiguration + , defaultProgramConfiguration + , restoreProgramConfiguration + , addKnownProgram + , addKnownPrograms + , lookupKnownProgram + , knownPrograms + , userSpecifyPath + , userSpecifyPaths + , userMaybeSpecifyPath + , userSpecifyArgs + , userSpecifyArgss + , userSpecifiedArgs + , lookupProgram + , updateProgram + , configureProgram + , configureAllKnownPrograms + , reconfigurePrograms + , requireProgram + , requireProgramVersion + , runDbProgram + , getDbProgramOutput + + -- * Programs that Cabal knows about + , ghcProgram + , ghcPkgProgram + , lhcProgram + , lhcPkgProgram + , nhcProgram + , hmakeProgram + , jhcProgram + , hugsProgram + , ffihugsProgram + , uhcProgram + , gccProgram + , ranlibProgram + , arProgram + , stripProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , hscolourProgram + , haddockProgram + , greencardProgram + , ldProgram + , tarProgram + , cppProgram + , pkgConfigProgram + , hpcProgram + + -- * deprecated + , rawSystemProgram + , rawSystemProgramStdout + , rawSystemProgramConf + , rawSystemProgramStdoutConf + , findProgramOnPath + + ) where + +import Distribution.Simple.Program.Types +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Builtin + +import Distribution.Simple.Utils + ( die, findProgramLocation, findProgramVersion ) +import Distribution.Verbosity + ( Verbosity ) + + +-- | Runs the given configured program. +-- +runProgram :: Verbosity -- ^Verbosity + -> ConfiguredProgram -- ^The program to run + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO () +runProgram verbosity prog args = + runProgramInvocation verbosity (programInvocation prog args) + + +-- | Runs the given configured program and gets the output. +-- +getProgramOutput :: Verbosity -- ^Verbosity + -> ConfiguredProgram -- ^The program to run + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO String +getProgramOutput verbosity prog args = + getProgramInvocationOutput verbosity (programInvocation prog args) + + +-- | Looks up the given program in the program database and runs it. +-- +runDbProgram :: Verbosity -- ^verbosity + -> Program -- ^The program to run + -> ProgramDb -- ^look up the program here + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO () +runDbProgram verbosity prog programDb args = + case lookupProgram prog programDb of + Nothing -> die notFound + Just configuredProg -> runProgram verbosity configuredProg args + where + 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. +-- +getDbProgramOutput :: Verbosity -- ^verbosity + -> Program -- ^The program to run + -> ProgramDb -- ^look up the program here + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO String +getDbProgramOutput verbosity prog programDb args = + case lookupProgram prog programDb of + Nothing -> die notFound + Just configuredProg -> getProgramOutput verbosity configuredProg args + where + notFound = "The program " ++ programName prog + ++ " is required but it could not be found" + + +--------------------- +-- Deprecated aliases +-- + +rawSystemProgram :: Verbosity -> ConfiguredProgram + -> [ProgArg] -> IO () +rawSystemProgram = runProgram + +rawSystemProgramStdout :: Verbosity -> ConfiguredProgram + -> [ProgArg] -> IO String +rawSystemProgramStdout = getProgramOutput + +rawSystemProgramConf :: Verbosity -> Program -> ProgramConfiguration + -> [ProgArg] -> IO () +rawSystemProgramConf = runDbProgram + +rawSystemProgramStdoutConf :: Verbosity -> Program -> ProgramConfiguration + -> [ProgArg] -> IO String +rawSystemProgramStdoutConf = getDbProgramOutput + +type ProgramConfiguration = ProgramDb + +emptyProgramConfiguration, defaultProgramConfiguration :: ProgramConfiguration +emptyProgramConfiguration = emptyProgramDb +defaultProgramConfiguration = defaultProgramDb + +restoreProgramConfiguration :: [Program] -> ProgramConfiguration + -> ProgramConfiguration +restoreProgramConfiguration = restoreProgramDb + +{-# DEPRECATED findProgramOnPath "use findProgramLocation instead" #-} +findProgramOnPath :: String -> Verbosity -> IO (Maybe FilePath) +findProgramOnPath = flip findProgramLocation diff --git a/cabal/Cabal/Distribution/Simple/Program/Ar.hs b/cabal/Cabal/Distribution/Simple/Program/Ar.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Program/Ar.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Ar +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @ar@ program. + +module Distribution.Simple.Program.Ar ( + createArLibArchive, + multiStageProgramInvocation, + ) where + +import Distribution.Simple.Program.Types + ( ConfiguredProgram(..) ) +import Distribution.Simple.Program.Run + ( programInvocation, multiStageProgramInvocation + , runProgramInvocation ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Verbosity + ( Verbosity, deafening, verbose ) + +-- | Call @ar@ to create a library archive from a bunch of object files. +-- +createArLibArchive :: Verbosity -> ConfiguredProgram + -> FilePath -> [FilePath] -> IO () +createArLibArchive verbosity ar target files = + + -- The args to use with "ar" are actually rather subtle and system-dependent. + -- In particular we have the following issues: + -- + -- -- On OS X, "ar q" does not make an archive index. Archives with no + -- index cannot be used. + -- + -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us + -- do that. We have duplicates because of modules like "A.M" and "B.M" + -- both make an object file "M.o" and ar does not consider the directory. + -- + -- Our solution is to use "ar r" in the simple case when one call is enough. + -- 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 + OSX -> ["-r", "-s"] + _ -> ["-r"] + + initialArgs = ["-q"] + finalArgs = case buildOS of + OSX -> ["-q", "-s"] + _ -> ["-q"] + + extraArgs = verbosityOpts verbosity ++ [target] + + simple = programInvocation ar (simpleArgs ++ extraArgs) + initial = programInvocation ar (initialArgs ++ extraArgs) + middle = initial + final = programInvocation ar (finalArgs ++ extraArgs) + + in sequence_ + [ runProgramInvocation verbosity inv + | inv <- multiStageProgramInvocation + simple (initial, middle, final) files ] + + where + verbosityOpts v | v >= deafening = ["-v"] + | v >= verbose = [] + | otherwise = ["-c"] diff --git a/cabal/Cabal/Distribution/Simple/Program/Builtin.hs b/cabal/Cabal/Distribution/Simple/Program/Builtin.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Program/Builtin.hs @@ -0,0 +1,269 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Builtin +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- The module defines all the known built-in 'Program's. +-- +-- Where possible we try to find their version numbers. +-- +module Distribution.Simple.Program.Builtin ( + + -- * The collection of unconfigured and configured progams + builtinPrograms, + + -- * Programs that Cabal knows about + ghcProgram, + ghcPkgProgram, + lhcProgram, + lhcPkgProgram, + nhcProgram, + hmakeProgram, + jhcProgram, + hugsProgram, + ffihugsProgram, + uhcProgram, + gccProgram, + ranlibProgram, + arProgram, + stripProgram, + happyProgram, + alexProgram, + hsc2hsProgram, + c2hsProgram, + cpphsProgram, + hscolourProgram, + haddockProgram, + greencardProgram, + ldProgram, + tarProgram, + cppProgram, + pkgConfigProgram, + hpcProgram, + ) where + +import Distribution.Simple.Program.Types + ( Program(..), simpleProgram ) +import Distribution.Simple.Utils + ( findProgramLocation, findProgramVersion ) + +-- ------------------------------------------------------------ +-- * Known programs +-- ------------------------------------------------------------ + +-- | The default list of programs. +-- These programs are typically used internally to Cabal. +builtinPrograms :: [Program] +builtinPrograms = + [ + -- compilers and related progs + ghcProgram + , ghcPkgProgram + , hugsProgram + , ffihugsProgram + , nhcProgram + , hmakeProgram + , jhcProgram + , lhcProgram + , lhcPkgProgram + , uhcProgram + , hpcProgram + -- preprocessors + , hscolourProgram + , haddockProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , greencardProgram + -- platform toolchain + , gccProgram + , ranlibProgram + , arProgram + , stripProgram + , ldProgram + , tarProgram + -- configuration tools + , pkgConfigProgram + ] + +ghcProgram :: Program +ghcProgram = (simpleProgram "ghc") { + programFindVersion = findProgramVersion "--numeric-version" id + } + +ghcPkgProgram :: Program +ghcPkgProgram = (simpleProgram "ghc-pkg") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "ghc-pkg --version" gives a string like + -- "GHC package manager version 6.4.1" + case words str of + (_:_:_:_:ver:_) -> ver + _ -> "" + } + +lhcProgram :: Program +lhcProgram = (simpleProgram "lhc") { + programFindVersion = findProgramVersion "--numeric-version" id + } + +lhcPkgProgram :: Program +lhcPkgProgram = (simpleProgram "lhc-pkg") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "lhc-pkg --version" gives a string like + -- "LHC package manager version 0.7" + case words str of + (_:_:_:_:ver:_) -> ver + _ -> "" + } + +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 -> + -- Invoking "hmake --version" gives a string line + -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +jhcProgram :: Program +jhcProgram = (simpleProgram "jhc") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- invoking "jhc --version" gives a string like + -- "jhc 0.3.20080208 (wubgipkamcep-2) + -- compiled by ghc-6.8 on a x86_64 running linux" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +uhcProgram :: Program +uhcProgram = (simpleProgram "uhc") { + programFindVersion = findProgramVersion "--version-dotted" id + } + +hpcProgram :: Program +hpcProgram = (simpleProgram "hpc") + { + programFindVersion = findProgramVersion "version" $ \str -> + case words str of + (_ : _ : _ : ver : _) -> ver + _ -> "" + } + +-- AArgh! Finding the version of hugs or ffihugs is almost impossible. +hugsProgram :: Program +hugsProgram = simpleProgram "hugs" + +ffihugsProgram :: Program +ffihugsProgram = simpleProgram "ffihugs" + +happyProgram :: Program +happyProgram = (simpleProgram "happy") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "happy --version" gives a string like + -- "Happy Version 1.16 Copyright (c) ...." + case words str of + (_:_:ver:_) -> ver + _ -> "" + } + +alexProgram :: Program +alexProgram = (simpleProgram "alex") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- 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 + _ -> "" + } + +gccProgram :: Program +gccProgram = (simpleProgram "gcc") { + programFindVersion = findProgramVersion "-dumpversion" id + } + +ranlibProgram :: Program +ranlibProgram = simpleProgram "ranlib" + +arProgram :: Program +arProgram = simpleProgram "ar" + +stripProgram :: Program +stripProgram = simpleProgram "strip" + +hsc2hsProgram :: Program +hsc2hsProgram = (simpleProgram "hsc2hs") { + programFindVersion = + findProgramVersion "--version" $ \str -> + -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" + case words str of + (_:_:ver:_) -> ver + _ -> "" + } + +c2hsProgram :: Program +c2hsProgram = (simpleProgram "c2hs") { + programFindVersion = findProgramVersion "--numeric-version" id + } + +cpphsProgram :: Program +cpphsProgram = (simpleProgram "cpphs") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "cpphs --version" gives a string like "cpphs 1.3" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +hscolourProgram :: Program +hscolourProgram = (simpleProgram "hscolour") { + programFindLocation = \v -> findProgramLocation v "HsColour", + programFindVersion = findProgramVersion "-version" $ \str -> + -- Invoking "HsColour -version" gives a string like "HsColour 1.7" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +haddockProgram :: Program +haddockProgram = (simpleProgram "haddock") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "haddock --version" gives a string like + -- "Haddock version 0.8, (c) Simon Marlow 2006" + case words str of + (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver + _ -> "" + } + +greencardProgram :: Program +greencardProgram = simpleProgram "greencard" + +ldProgram :: Program +ldProgram = simpleProgram "ld" + +tarProgram :: Program +tarProgram = simpleProgram "tar" + +cppProgram :: Program +cppProgram = simpleProgram "cpp" + +pkgConfigProgram :: Program +pkgConfigProgram = (simpleProgram "pkg-config") { + programFindVersion = findProgramVersion "--version" id + } diff --git a/cabal/Cabal/Distribution/Simple/Program/Db.hs b/cabal/Cabal/Distribution/Simple/Program/Db.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Program/Db.hs @@ -0,0 +1,409 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Db +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides a 'ProgramDb' type which holds configured and not-yet +-- configured programs. It is the parameter to lots of actions elsewhere in +-- Cabal that need to look up and run programs. If we had a Cabal monad, +-- the 'ProgramDb' would probably be a reader or state component of it. +-- +-- One nice thing about using it is that any program that is +-- registered with Cabal will get some \"configure\" and \".cabal\" +-- helpers like --with-foo-args --foo-path= and extra-foo-args. +-- +-- There's also a hook for adding programs in a Setup.lhs script. See +-- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a +-- hook user the ability to get the above flags and such so that they +-- don't have to write all the PATH logic inside Setup.lhs. + +module Distribution.Simple.Program.Db ( + -- * The collection of configured programs we can run + ProgramDb, + emptyProgramDb, + defaultProgramDb, + restoreProgramDb, + + -- ** Query and manipulate the program db + addKnownProgram, + addKnownPrograms, + lookupKnownProgram, + knownPrograms, + userSpecifyPath, + userSpecifyPaths, + userMaybeSpecifyPath, + userSpecifyArgs, + userSpecifyArgss, + userSpecifiedArgs, + lookupProgram, + updateProgram, + + -- ** Query and manipulate the program db + configureProgram, + configureAllKnownPrograms, + reconfigurePrograms, + requireProgram, + requireProgramVersion, + + ) where + +import Distribution.Simple.Program.Types + ( Program(..), ProgArg, ConfiguredProgram(..), ProgramLocation(..) ) +import Distribution.Simple.Program.Builtin + ( builtinPrograms ) +import Distribution.Simple.Utils + ( die, findProgramLocation ) +import Distribution.Version + ( Version, VersionRange, isAnyVersion, withinRange ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity ) + +import Data.List + ( foldl' ) +import Data.Maybe + ( catMaybes ) +import qualified Data.Map as Map +import Control.Monad + ( join, foldM ) +import System.Directory + ( doesFileExist ) + + +-- ------------------------------------------------------------ +-- * Programs database +-- ------------------------------------------------------------ + +-- | The configuration is a collection of information about programs. It +-- contains information both about configured programs and also about programs +-- that we are yet to configure. +-- +-- The idea is that we start from a collection of unconfigured programs and one +-- by one we try to configure them at which point we move them into the +-- configured collection. For unconfigured programs we record not just the +-- 'Program' but also any user-provided arguments and location for the program. +data ProgramDb = ProgramDb { + unconfiguredProgs :: UnconfiguredProgs, + configuredProgs :: ConfiguredProgs + } + +type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) +type UnconfiguredProgs = Map.Map String UnconfiguredProgram +type ConfiguredProgs = Map.Map String ConfiguredProgram + + +emptyProgramDb :: ProgramDb +emptyProgramDb = ProgramDb Map.empty Map.empty + + +defaultProgramDb :: ProgramDb +defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb + + +-- internal helpers: +updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs) + -> ProgramDb -> ProgramDb +updateUnconfiguredProgs update conf = + conf { unconfiguredProgs = update (unconfiguredProgs conf) } + +updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs) + -> ProgramDb -> ProgramDb +updateConfiguredProgs update conf = + conf { configuredProgs = update (configuredProgs conf) } + + +-- Read & Show instances are based on listToFM +-- Note that we only serialise the configured part of the database, this is +-- because we don't need the unconfigured part after the configure stage, and +-- additionally because we cannot read/show 'Program' as it contains functions. +instance Show ProgramDb where + show = show . Map.toAscList . configuredProgs + +instance Read ProgramDb where + readsPrec p s = + [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r) + | (s', r) <- readsPrec p s ] + + +-- | 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 +-- back all the known 'Program's. +-- +-- * It does not add the default programs, but you probably want them, use +-- 'builtinPrograms' in addition to any extra you might need. +-- +restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb +restoreProgramDb = addKnownPrograms + + +-- ------------------------------- +-- Managing unconfigured programs + +-- | Add a known program that we may configure later +-- +addKnownProgram :: Program -> ProgramDb -> ProgramDb +addKnownProgram prog = updateUnconfiguredProgs $ + Map.insertWith combine (programName prog) (prog, Nothing, []) + where combine _ (_, path, args) = (prog, path, args) + + +addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb +addKnownPrograms progs conf = foldl' (flip addKnownProgram) conf progs + + +lookupKnownProgram :: String -> ProgramDb -> Maybe Program +lookupKnownProgram name = + fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs + + +knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)] +knownPrograms conf = + [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf) + , let p' = Map.lookup (programName p) (configuredProgs conf) ] + + +-- |User-specify this path. Basically override any path information +-- for this program in the configuration. If it's not a known +-- program ignore it. +-- +userSpecifyPath :: String -- ^Program name + -> FilePath -- ^user-specified path to the program + -> ProgramDb -> ProgramDb +userSpecifyPath name path = updateUnconfiguredProgs $ + flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args) + + +userMaybeSpecifyPath :: String -> Maybe FilePath + -> ProgramDb -> ProgramDb +userMaybeSpecifyPath _ Nothing conf = conf +userMaybeSpecifyPath name (Just path) conf = userSpecifyPath name path conf + + +-- |User-specify the arguments for this program. Basically override +-- any args information for this program in the configuration. If it's +-- not a known program, ignore it.. +userSpecifyArgs :: String -- ^Program name + -> [ProgArg] -- ^user-specified args + -> ProgramDb + -> ProgramDb +userSpecifyArgs name args' = + updateUnconfiguredProgs + (flip Map.update name $ + \(prog, path, args) -> Just (prog, path, args ++ args')) + . updateConfiguredProgs + (flip Map.update name $ + \prog -> Just prog { programOverrideArgs = programOverrideArgs prog + ++ args' }) + + +-- | Like 'userSpecifyPath' but for a list of progs and their paths. +-- +userSpecifyPaths :: [(String, FilePath)] + -> ProgramDb + -> ProgramDb +userSpecifyPaths paths conf = + foldl' (\conf' (prog, path) -> userSpecifyPath prog path conf') conf paths + + +-- | Like 'userSpecifyPath' but for a list of progs and their args. +-- +userSpecifyArgss :: [(String, [ProgArg])] + -> ProgramDb + -> ProgramDb +userSpecifyArgss argss conf = + foldl' (\conf' (prog, args) -> userSpecifyArgs prog args conf') conf argss + + +-- | Get the path that has been previously specified for a program, if any. +-- +userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath +userSpecifiedPath prog = + join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs + + +-- | Get any extra args that have been previously specified for a program. +-- +userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg] +userSpecifiedArgs prog = + maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs + + +-- ----------------------------- +-- Managing configured programs + +-- | Try to find a configured program +lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram +lookupProgram prog = Map.lookup (programName prog) . configuredProgs + + +-- | Update a configured program in the database. +updateProgram :: ConfiguredProgram -> ProgramDb + -> ProgramDb +updateProgram prog = updateConfiguredProgs $ + Map.insert (programId prog) prog + + +-- --------------------------- +-- 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 +-- added to the configured collection. +-- +-- Note that it is not a failure if the program cannot be configured. It's only +-- a failure if the user supplied a location and the program could not be found +-- at that location. +-- +-- 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 +-- 'requireProgram'. +-- +configureProgram :: Verbosity + -> Program + -> ProgramDb + -> IO ProgramDb +configureProgram verbosity prog conf = do + let name = programName prog + maybeLocation <- case userSpecifiedPath prog conf of + Nothing -> programFindLocation prog verbosity + >>= return . fmap FoundOnSystem + Just path -> do + absolute <- doesFileExist path + if absolute + then return (Just (UserSpecified path)) + else findProgramLocation verbosity path + >>= maybe (die notFound) (return . Just . UserSpecified) + where notFound = "Cannot find the program '" ++ name ++ "' at '" + ++ path ++ "' or on the path" + case maybeLocation of + Nothing -> return conf + Just location -> do + version <- programFindVersion prog verbosity (locationPath location) + let configuredProg = ConfiguredProgram { + programId = name, + programVersion = version, + programDefaultArgs = [], + programOverrideArgs = userSpecifiedArgs prog conf, + programLocation = location + } + extraArgs <- programPostConf prog verbosity configuredProg + let configuredProg' = configuredProg { + programDefaultArgs = extraArgs + } + return (updateConfiguredProgs (Map.insert name configuredProg') conf) + + +-- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. +-- +configurePrograms :: Verbosity + -> [Program] + -> ProgramDb + -> IO ProgramDb +configurePrograms verbosity progs conf = + foldM (flip (configureProgram verbosity)) conf progs + + +-- | Try to configure all the known programs that have not yet been configured. +-- +configureAllKnownPrograms :: Verbosity + -> ProgramDb + -> IO ProgramDb +configureAllKnownPrograms verbosity conf = + configurePrograms verbosity + [ prog | (prog,_,_) <- Map.elems notYetConfigured ] conf + where + notYetConfigured = unconfiguredProgs conf + `Map.difference` configuredProgs conf + + +-- | reconfigure a bunch of programs given new user-specified args. It takes +-- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs +-- with a new path it calls 'configureProgram'. +-- +reconfigurePrograms :: Verbosity + -> [(String, FilePath)] + -> [(String, [ProgArg])] + -> ProgramDb + -> IO ProgramDb +reconfigurePrograms verbosity paths argss conf = do + configurePrograms verbosity progs + . userSpecifyPaths paths + . userSpecifyArgss argss + $ conf + + where + progs = catMaybes [ lookupKnownProgram name conf | (name,_) <- paths ] + + +-- | Check that a program is configured and available to be run. +-- +-- It raises an exception if the program could not be configured, otherwise +-- it returns the configured program. +-- +requireProgram :: Verbosity -> Program -> ProgramDb + -> IO (ConfiguredProgram, ProgramDb) +requireProgram verbosity prog conf = 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 + + case lookupProgram prog conf' of + Nothing -> die notFound + Just configuredProg -> return (configuredProg, conf') + + 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] [])@ +-- +-- 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. +-- +requireProgramVersion :: Verbosity -> Program -> VersionRange + -> ProgramDb + -> IO (ConfiguredProgram, Version, ProgramDb) +requireProgramVersion verbosity prog range conf = 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 + + case lookupProgram prog conf' of + Nothing -> die 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) + + where notFound = "The program " + ++ programName prog ++ versionRequirement + ++ " is required but it could not be found." + 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 + ++ " is required but the version of " + ++ locationPath l ++ " could not be determined." + versionRequirement + | isAnyVersion range = "" + | otherwise = " version " ++ display range diff --git a/cabal/Cabal/Distribution/Simple/Program/GHC.hs b/cabal/Cabal/Distribution/Simple/Program/GHC.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Program/GHC.hs @@ -0,0 +1,458 @@ +module Distribution.Simple.Program.GHC ( + GhcOptions(..), + GhcMode(..), + GhcOptimisation(..), + + ghcInvocation, + renderGhcOptions, + + runGHC, + + ) where + +import Distribution.Package +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 Language.Haskell.Extension ( Language(..), Extension(..) ) + +import Data.Monoid + + +-- | A structured set of GHC options/flags +-- +data GhcOptions = GhcOptions { + + -- | The major mode for the ghc invocation. + ghcOptMode :: Flag GhcMode, + + -- | Any extra options to pass directly to ghc. These go at the end and hence + -- override other stuff. + ghcOptExtra :: [String], + + -- | Extra default flags to pass directly to ghc. These go at the beginning + -- and so can be overridden by other stuff. + ghcOptExtraDefault :: [String], + + ----------------------- + -- Inputs and outputs + + -- | The main input files; could be .hs, .hi, .c, .o, depending on mode. + ghcOptInputFiles :: [FilePath], + + -- | The names of input Haskell modules, mainly for @--make@ mode. + ghcOptInputModules :: [ModuleName], + + -- | Location for output file; the @ghc -o@ flag. + ghcOptOutputFile :: Flag FilePath, + + -- | Start with an empty search path for Haskell source files; + -- the @ghc -i@ flag (@-i@ on it's own with no path argument). + ghcOptSourcePathClear :: Flag Bool, + + -- | Search path for Haskell source files; the @ghc -i@ flag. + ghcOptSourcePath :: [FilePath], + + ------------- + -- Packages + + -- | The package name the modules will belong to; the @ghc -package-name@ flag + ghcOptPackageName :: Flag PackageId, + + -- | 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)], + + -- | 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. + ghcOptNoAutoLinkPackages :: Flag Bool, + + ----------------- + -- Linker stuff + + -- | Names of libraries to link in; the @ghc -l@ flag. + ghcOptLinkLibs :: [FilePath], + + -- | Search path for libraries to link in; the @ghc -L@ flag. + ghcOptLinkLibPath :: [FilePath], + + -- | Options to pass through to the linker; the @ghc -optl@ flag. + ghcOptLinkOptions :: [String], + + -- | OSX only: frameworks to link in; the @ghc -framework@ flag. + ghcOptLinkFrameworks :: [String], + + -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag. + ghcOptNoLink :: Flag Bool, + + -------------------- + -- C and CPP stuff + + -- | Options to pass through to the C compiler; the @ghc -optc@ flag. + ghcOptCcOptions :: [String], + + -- | Options to pass through to CPP; the @ghc -optP@ flag. + ghcOptCppOptions :: [String], + + -- | Search path for CPP includes like header files; the @ghc -I@ flag. + ghcOptCppIncludePath :: [FilePath], + + -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag. + ghcOptCppIncludes :: [FilePath], + + -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag. + ghcOptFfiIncludes :: [FilePath], + + ---------------------------- + -- Language and extensions + + -- | The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag. + ghcOptLanguage :: Flag Language, + + -- | The language extensions; the @ghc -X@ flag. + ghcOptExtensions :: [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)], + + ---------------- + -- Compilation + + -- | What optimisation level to use; the @ghc -O@ flag. + ghcOptOptimisation :: Flag GhcOptimisation, + + -- | Compile in profiling mode; the @ghc -prof@ flag. + ghcOptProfilingMode :: Flag Bool, + + -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag. + ghcOptSplitObjs :: Flag Bool, + + ---------------- + -- GHCi + + -- | Extra GHCi startup scripts; the @-ghci-script@ flag + ghcOptGHCiScripts :: [FilePath], + + ------------------------ + -- Redirecting outputs + + ghcOptHiSuffix :: Flag String, + ghcOptObjSuffix :: Flag String, + ghcOptHiDir :: Flag FilePath, + ghcOptObjDir :: Flag FilePath, + ghcOptStubDir :: Flag FilePath, + + -------------------- + -- Dynamic linking + + ghcOptDynamic :: Flag Bool, + ghcOptShared :: Flag Bool, + ghcOptFPic :: Flag Bool, + ghcOptDylibName :: Flag String, + + --------------- + -- Misc flags + + -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. + ghcOptVerbosity :: Flag Verbosity, + + -- | Let GHC know that it is Cabal that's calling it. + -- Modifies some of the GHC error messages. + ghcOptCabal :: Flag Bool + +} deriving Show + + +data GhcMode = GhcModeCompile -- ^ @ghc -c@ + | GhcModeLink -- ^ @ghc@ + | GhcModeMake -- ^ @ghc --make@ + | GhcModeInteractive -- ^ @ghci@ \/ @ghc --interactive@ + | GhcModeAbiHash -- ^ @ghc --abi-hash@ +-- | GhcModeDepAnalysis -- ^ @ghc -M@ +-- | GhcModeEvaluate -- ^ @ghc -e@ + deriving (Show, Eq) + +data GhcOptimisation = GhcNoOptimisation -- ^ @-O0@ + | GhcNormalOptimisation -- ^ @-O@ + | GhcMaximumOptimisation -- ^ @-O2@ + | GhcSpecialOptimisation String -- ^ e.g. @-Odph@ + deriving (Show, Eq) + + +runGHC :: Verbosity -> ConfiguredProgram -> GhcOptions -> IO () +runGHC verbosity ghcProg opts = do + runProgramInvocation verbosity (ghcInvocation ghcProg opts) + + +ghcInvocation :: ConfiguredProgram -> GhcOptions -> ProgramInvocation +ghcInvocation ConfiguredProgram { programVersion = Nothing } _ = + error "ghcInvocation: the programVersion must not be Nothing" +ghcInvocation prog@ConfiguredProgram { programVersion = Just ver } opts = + programInvocation prog (renderGhcOptions ver opts) + + +renderGhcOptions :: Version -> GhcOptions -> [String] +renderGhcOptions version@(Version ver _) opts = + concat + [ case flagToMaybe (ghcOptMode opts) of + Nothing -> [] + Just GhcModeCompile -> ["-c"] + Just GhcModeLink -> [] + Just GhcModeMake -> ["--make"] + Just GhcModeInteractive -> ["--interactive"] + Just GhcModeAbiHash -> ["--abi-hash"] +-- Just GhcModeDepAnalysis -> ["-M"] +-- Just GhcModeEvaluate -> ["-e", expr] + + , flags ghcOptExtraDefault + + , [ "-no-link" | flagBool ghcOptNoLink ] + + --------------- + -- Misc flags + + , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts)) + + , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal, ver >= [6,11] ] + + ---------------- + -- Compilation + + , case flagToMaybe (ghcOptOptimisation opts) of + Nothing -> [] + Just GhcNoOptimisation -> ["-O0"] + Just GhcNormalOptimisation -> ["-O"] + Just GhcMaximumOptimisation -> ["-O2"] + Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph + + , [ "-prof" | flagBool ghcOptProfilingMode ] + + , [ "-split-objs" | flagBool ghcOptSplitObjs ] + + -------------------- + -- Dynamic linking + + , [ "-shared" | flagBool ghcOptShared ] + , [ "-dynamic" | flagBool ghcOptDynamic ] + , [ "-fPIC" | flagBool ghcOptFPic ] + + , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ] + + ------------------------ + -- Redirecting outputs + + , concat [ ["-osuf", suf] | suf <- flag ghcOptObjSuffix ] + , concat [ ["-hisuf", suf] | suf <- flag ghcOptHiSuffix ] + , concat [ ["-odir", dir] | dir <- flag ghcOptObjDir ] + , concat [ ["-hidir", dir] | dir <- flag ghcOptHiDir ] + , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir, ver >= [6,8] ] + + ----------------------- + -- Source search path + + , [ "-i" | flagBool ghcOptSourcePathClear ] + , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ] + + -------------------- + -- C and CPP stuff + + , [ "-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] ] + , [ "-optc" ++ opt | opt <- flags ghcOptCcOptions ] + + ----------------- + -- Linker stuff + + , [ "-optl" ++ opt | opt <- flags ghcOptLinkOptions ] + , ["-l" ++ lib | lib <- flags ghcOptLinkLibs ] + , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath ] + , concat [ ["-framework", fmwk] | fmwk <- flags ghcOptLinkFrameworks ] + + ------------- + -- Packages + + , concat [ ["-package-name", display pkgid] | pkgid <- flag ghcOptPackageName ] + + , [ "-hide-all-packages" | flagBool ghcOptHideAllPackages ] + , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ] + + , packageDbArgs version (flags ghcOptPackageDBs) + + , concat $ if ver >= [6,11] + then [ ["-package-id", display ipkgid] | (ipkgid,_) <- flags ghcOptPackages ] + else [ ["-package", display pkgid] | (_,pkgid) <- flags ghcOptPackages ] + + ---------------------------- + -- Language and extensions + + , if ver >= [7] + then [ "-X" ++ display lang | lang <- flag ghcOptLanguage ] + else [] + + , [ case lookup ext (ghcOptExtensionMap opts) of + Just arg -> arg + Nothing -> error $ "renderGhcOptions: " ++ display ext + ++ " not present in ghcOptExtensionMap." + | ext <- ghcOptExtensions opts ] + + ---------------- + -- GHCi + + , concat [ [ "-ghci-script", script ] | script <- flags ghcOptGHCiScripts + , ver >= [7,2] ] + + --------------- + -- Inputs + + , [ display modu | modu <- flags ghcOptInputModules ] + , ghcOptInputFiles opts + + , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ] + + --------------- + -- Extra + + , ghcOptExtra opts + + ] + + + where + flag flg = flagToList (flg opts) + flags flg = flg opts + flagBool flg = fromFlagOrDefault False (flg opts) + + +verbosityOpts :: Verbosity -> [String] +verbosityOpts verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-w", "-v0"] + + +packageDbArgs :: Version -> PackageDBStack -> [String] +packageDbArgs (Version ver _) dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> ("-no-user-" ++ packageDbFlag) + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ '-':packageDbFlag , db ] + specific _ = ierror + ierror = error $ "internal error: unexpected package db stack: " + ++ show dbstack + + packageDbFlag + | ver < [7,5] + = "package-conf" + | otherwise + = "package-db" + + +-- ----------------------------------------------------------------------------- +-- Boilerplate Monoid instance for GhcOptions + +instance Monoid GhcOptions where + mempty = GhcOptions { + ghcOptMode = mempty, + ghcOptExtra = mempty, + ghcOptExtraDefault = mempty, + ghcOptInputFiles = mempty, + ghcOptInputModules = mempty, + ghcOptOutputFile = mempty, + ghcOptSourcePathClear = mempty, + ghcOptSourcePath = mempty, + ghcOptPackageName = mempty, + ghcOptPackageDBs = mempty, + ghcOptPackages = mempty, + ghcOptHideAllPackages = mempty, + ghcOptNoAutoLinkPackages = mempty, + ghcOptLinkLibs = mempty, + ghcOptLinkLibPath = mempty, + ghcOptLinkOptions = mempty, + ghcOptLinkFrameworks = mempty, + ghcOptNoLink = mempty, + ghcOptCcOptions = mempty, + ghcOptCppOptions = mempty, + ghcOptCppIncludePath = mempty, + ghcOptCppIncludes = mempty, + ghcOptFfiIncludes = mempty, + ghcOptLanguage = mempty, + ghcOptExtensions = mempty, + ghcOptExtensionMap = mempty, + ghcOptOptimisation = mempty, + ghcOptProfilingMode = mempty, + ghcOptSplitObjs = mempty, + ghcOptGHCiScripts = mempty, + ghcOptHiSuffix = mempty, + ghcOptObjSuffix = mempty, + ghcOptHiDir = mempty, + ghcOptObjDir = mempty, + ghcOptStubDir = mempty, + ghcOptDynamic = mempty, + ghcOptShared = mempty, + ghcOptFPic = mempty, + ghcOptDylibName = mempty, + ghcOptVerbosity = mempty, + ghcOptCabal = mempty + } + mappend a b = GhcOptions { + ghcOptMode = combine ghcOptMode, + ghcOptExtra = combine ghcOptExtra, + ghcOptExtraDefault = combine ghcOptExtraDefault, + ghcOptInputFiles = combine ghcOptInputFiles, + ghcOptInputModules = combine ghcOptInputModules, + ghcOptOutputFile = combine ghcOptOutputFile, + ghcOptSourcePathClear = combine ghcOptSourcePathClear, + ghcOptSourcePath = combine ghcOptSourcePath, + ghcOptPackageName = combine ghcOptPackageName, + ghcOptPackageDBs = combine ghcOptPackageDBs, + ghcOptPackages = combine ghcOptPackages, + ghcOptHideAllPackages = combine ghcOptHideAllPackages, + ghcOptNoAutoLinkPackages = combine ghcOptNoAutoLinkPackages, + ghcOptLinkLibs = combine ghcOptLinkLibs, + ghcOptLinkLibPath = combine ghcOptLinkLibPath, + ghcOptLinkOptions = combine ghcOptLinkOptions, + ghcOptLinkFrameworks = combine ghcOptLinkFrameworks, + ghcOptNoLink = combine ghcOptNoLink, + ghcOptCcOptions = combine ghcOptCcOptions, + ghcOptCppOptions = combine ghcOptCppOptions, + ghcOptCppIncludePath = combine ghcOptCppIncludePath, + ghcOptCppIncludes = combine ghcOptCppIncludes, + ghcOptFfiIncludes = combine ghcOptFfiIncludes, + ghcOptLanguage = combine ghcOptLanguage, + ghcOptExtensions = combine ghcOptExtensions, + ghcOptExtensionMap = combine ghcOptExtensionMap, + ghcOptOptimisation = combine ghcOptOptimisation, + ghcOptProfilingMode = combine ghcOptProfilingMode, + ghcOptSplitObjs = combine ghcOptSplitObjs, + ghcOptGHCiScripts = combine ghcOptGHCiScripts, + ghcOptHiSuffix = combine ghcOptHiSuffix, + ghcOptObjSuffix = combine ghcOptObjSuffix, + ghcOptHiDir = combine ghcOptHiDir, + ghcOptObjDir = combine ghcOptObjDir, + ghcOptStubDir = combine ghcOptStubDir, + ghcOptDynamic = combine ghcOptDynamic, + ghcOptShared = combine ghcOptShared, + ghcOptFPic = combine ghcOptFPic, + ghcOptDylibName = combine ghcOptDylibName, + ghcOptVerbosity = combine ghcOptVerbosity, + ghcOptCabal = combine ghcOptCabal + } + where + combine field = field a `mappend` field b diff --git a/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs b/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs @@ -0,0 +1,365 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.HcPkg +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hc-pkg@ program. +-- Currently only GHC and LHC have hc-pkg programs. + +module Distribution.Simple.Program.HcPkg ( + init, + register, + reregister, + unregister, + expose, + hide, + dump, + + -- * Program invocations + initInvocation, + registerInvocation, + reregisterInvocation, + unregisterInvocation, + exposeInvocation, + hideInvocation, + dumpInvocation, + ) where + +import Prelude hiding (init) +import Distribution.Package + ( PackageId, InstalledPackageId(..) ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo, InstalledPackageInfo_(..) + , showInstalledPackageInfo + , emptyInstalledPackageInfo, fieldsInstalledPackageInfo ) +import Distribution.ParseUtils +import Distribution.Simple.Compiler + ( PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program.Types + ( ConfiguredProgram(programId, programVersion) ) +import Distribution.Simple.Program.Run + ( ProgramInvocation(..), IOEncoding(..), programInvocation + , runProgramInvocation, getProgramInvocationOutput ) +import Distribution.Version + ( Version(..) ) +import Distribution.Text + ( display ) +import Distribution.Simple.Utils + ( die ) +import Distribution.Verbosity + ( Verbosity, deafening, silent ) +import Distribution.Compat.Exception + ( catchExit ) + +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 + + +-- | 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) + +-- | Call @hc-pkg@ to register a package. +-- +-- > hc-pkg register {filename | -} [--user | --global | --package-db] +-- +register :: Verbosity -> ConfiguredProgram -> PackageDBStack + -> Either FilePath + InstalledPackageInfo + -> IO () +register verbosity hcPkg packagedb pkgFile = + runProgramInvocation verbosity + (registerInvocation hcPkg verbosity packagedb pkgFile) + + +-- | Call @hc-pkg@ to re-register a package. +-- +-- > hc-pkg register {filename | -} [--user | --global | --package-db] +-- +reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack + -> Either FilePath + InstalledPackageInfo + -> IO () +reregister verbosity hcPkg packagedb pkgFile = + runProgramInvocation verbosity + (reregisterInvocation hcPkg 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 = + runProgramInvocation verbosity + (unregisterInvocation hcPkg 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 = + runProgramInvocation verbosity + (exposeInvocation hcPkg verbosity packagedb pkgid) + + +-- | Call @hc-pkg@ to expose a package. +-- +-- > hc-pkg expose [pkgid] [--user | --global | --package-db] +-- +hide :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () +hide verbosity hcPkg packagedb pkgid = + runProgramInvocation verbosity + (hideInvocation hcPkg verbosity packagedb pkgid) + + +-- | Call @hc-pkg@ to get all the installed packages. +-- +dump :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [InstalledPackageInfo] +dump verbosity hcPkg packagedb = do + + output <- getProgramInvocationOutput verbosity + (dumpInvocation hcPkg verbosity packagedb) + `catchExit` \_ -> die $ programId hcPkg ++ " dump failed" + + case parsePackages output of + Left ok -> return ok + _ -> die $ "failed to parse output of '" + ++ programId hcPkg ++ " dump'" + + where + parsePackages str = + let parsed = map parseInstalledPackageInfo' (splitPkgs str) + in case [ msg | ParseFailed msg <- parsed ] of + [] -> Left [ setInstalledPackageId + . maybe id mungePackagePaths pkgroot + $ pkg + | ParseOk _ (pkgroot, 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)) + + --TODO: this could be a lot faster. We're doing normaliseLineEndings twice + -- and converting back and forth with lines/unlines. + splitPkgs :: String -> [String] + splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines + where + -- Handle the case of there being no packages at all. + checkEmpty [s] | all isSpace s = [] + checkEmpty ss = ss + + splitWith :: (a -> Bool) -> [a] -> [[a]] + splitWith p xs = ys : case zs of + [] -> [] + _:ws -> splitWith p ws + where (ys,zs) = break p xs + +mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +mungePackagePaths pkgroot pkginfo = + pkginfo { + importDirs = mungePaths (importDirs pkginfo), + includeDirs = mungePaths (includeDirs pkginfo), + libraryDirs = mungePaths (libraryDirs pkginfo), + frameworkDirs = mungePaths (frameworkDirs pkginfo), + haddockInterfaces = mungePaths (haddockInterfaces pkginfo), + haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) + } + where + mungePaths = map mungePath + mungeUrls = map mungeUrl + + mungePath p = case stripVarPrefix "${pkgroot}" p of + Just p' -> pkgroot p' + Nothing -> p + + mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of + Just p' -> toUrlPath pkgroot p' + Nothing -> p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) + + stripVarPrefix var p = + case splitPath p of + (root:path') -> case stripPrefix var root of + Just [sep] | isPathSeparator sep -> Just (joinPath path') + _ -> Nothing + _ -> 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 + + +-------------------------- +-- The program invocations +-- + +initInvocation :: ConfiguredProgram + -> Verbosity -> FilePath -> ProgramInvocation +initInvocation hcPkg verbosity path = + programInvocation hcPkg args + where + args = ["init", path] + ++ verbosityOpts hcPkg verbosity + +registerInvocation, reregisterInvocation + :: ConfiguredProgram -> Verbosity -> PackageDBStack + -> Either FilePath InstalledPackageInfo + -> ProgramInvocation +registerInvocation = registerInvocation' "register" +reregisterInvocation = registerInvocation' "update" + + +registerInvocation' :: String + -> ConfiguredProgram -> Verbosity -> PackageDBStack + -> Either FilePath InstalledPackageInfo + -> ProgramInvocation +registerInvocation' cmdname hcPkg verbosity packagedbs (Left pkgFile) = + programInvocation hcPkg args + where + args = [cmdname, pkgFile] + ++ (if legacyVersion hcPkg + then [packageDbOpts hcPkg (last packagedbs)] + else packageDbStackOpts hcPkg packagedbs) + ++ verbosityOpts hcPkg verbosity + +registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) = + (programInvocation hcPkg 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 + + +unregisterInvocation :: ConfiguredProgram + -> Verbosity -> PackageDB -> PackageId + -> ProgramInvocation +unregisterInvocation hcPkg verbosity packagedb pkgid = + programInvocation hcPkg $ + ["unregister", packageDbOpts hcPkg packagedb, display pkgid] + ++ verbosityOpts hcPkg verbosity + + +exposeInvocation :: ConfiguredProgram + -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation +exposeInvocation hcPkg verbosity packagedb pkgid = + programInvocation hcPkg $ + ["expose", packageDbOpts hcPkg packagedb, display pkgid] + ++ verbosityOpts hcPkg verbosity + + +hideInvocation :: ConfiguredProgram + -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation +hideInvocation hcPkg verbosity packagedb pkgid = + programInvocation hcPkg $ + ["hide", packageDbOpts hcPkg packagedb, display pkgid] + ++ verbosityOpts hcPkg verbosity + + +dumpInvocation :: ConfiguredProgram + -> Verbosity -> PackageDB -> ProgramInvocation +dumpInvocation hcPkg _verbosity packagedb = + (programInvocation hcPkg args) { + progInvokeOutputEncoding = IOEncodingUTF8 + } + where + args = ["dump", packageDbOpts hcPkg packagedb] + ++ verbosityOpts hcPkg 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 + (GlobalPackageDB:UserPackageDB:dbs) -> "--global" + : "--user" + : map specific dbs + (GlobalPackageDB:dbs) -> "--global" + : ("--no-user-" ++ packageDbFlag hcPkg) + : map specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = "--" ++ packageDbFlag hcPkg ++ "=" ++ 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] []) + = "package-conf" + | otherwise + = "package-db" + +packageDbOpts :: ConfiguredProgram -> PackageDB -> String +packageDbOpts _ GlobalPackageDB = "--global" +packageDbOpts _ UserPackageDB = "--user" +packageDbOpts hcPkg (SpecificPackageDB db) = "--" ++ packageDbFlag hcPkg ++ "=" ++ db + +verbosityOpts :: ConfiguredProgram -> Verbosity -> [String] +verbosityOpts hcPkg v + + -- ghc-pkg < 6.11 does not support -v + | programId hcPkg == "ghc-pkg" + && programVersion hcPkg < Just (Version [6,11] []) + = [] + + | 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] []) diff --git a/cabal/Cabal/Distribution/Simple/Program/Hpc.hs b/cabal/Cabal/Distribution/Simple/Program/Hpc.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Program/Hpc.hs @@ -0,0 +1,73 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Hpc +-- Copyright : Thomas Tuegel 2011 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hpc@ program. + +module Distribution.Simple.Program.Hpc + ( markup + , union + ) where + +import Distribution.ModuleName ( ModuleName ) +import Distribution.Simple.Program.Run + ( ProgramInvocation, programInvocation, runProgramInvocation ) +import Distribution.Simple.Program.Types ( ConfiguredProgram ) +import Distribution.Text ( display ) +import Distribution.Verbosity ( Verbosity ) + +markup :: ConfiguredProgram + -> Verbosity + -> FilePath -- ^ Path to .tix file + -> FilePath -- ^ Path to directory with .mix files + -> FilePath -- ^ Path where html output should be located + -> [ModuleName] -- ^ List of modules to exclude from report + -> IO () +markup hpc verbosity tixFile hpcDir destDir excluded = + runProgramInvocation verbosity + (markupInvocation hpc tixFile hpcDir destDir excluded) + +markupInvocation :: ConfiguredProgram + -> FilePath -- ^ Path to .tix file + -> FilePath -- ^ Path to directory with .mix files + -> FilePath -- ^ Path where html output should be + -- located + -> [ModuleName] -- ^ List of modules to exclude from + -- report + -> ProgramInvocation +markupInvocation hpc tixFile hpcDir destDir excluded = + let args = [ "markup", tixFile + , "--hpcdir=" ++ hpcDir + , "--destdir=" ++ destDir + ] + ++ ["--exclude=" ++ display moduleName + | moduleName <- excluded ] + in programInvocation hpc args + +union :: ConfiguredProgram + -> Verbosity + -> [FilePath] -- ^ Paths to .tix files + -> FilePath -- ^ Path to resultant .tix file + -> [ModuleName] -- ^ List of modules to exclude from union + -> IO () +union hpc verbosity tixFiles outFile excluded = + runProgramInvocation verbosity + (unionInvocation hpc tixFiles outFile excluded) + +unionInvocation :: ConfiguredProgram + -> [FilePath] -- ^ Paths to .tix files + -> FilePath -- ^ Path to resultant .tix file + -> [ModuleName] -- ^ List of modules to exclude from union + -> ProgramInvocation +unionInvocation hpc tixFiles outFile excluded = + programInvocation hpc $ concat + [ ["sum", "--union"] + , tixFiles + , ["--output=" ++ outFile] + , ["--exclude=" ++ display moduleName + | moduleName <- excluded ] + ] diff --git a/cabal/Cabal/Distribution/Simple/Program/Ld.hs b/cabal/Cabal/Distribution/Simple/Program/Ld.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Program/Ld.hs @@ -0,0 +1,62 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Ld +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @ld@ linker program. + +module Distribution.Simple.Program.Ld ( + combineObjectFiles, + ) where + +import Distribution.Simple.Program.Types + ( ConfiguredProgram(..) ) +import Distribution.Simple.Program.Run + ( programInvocation, multiStageProgramInvocation + , runProgramInvocation ) +import Distribution.Verbosity + ( Verbosity ) + +import System.Directory + ( renameFile ) +import System.FilePath + ( (<.>) ) + +-- | Call @ld -r@ to link a bunch of object files together. +-- +combineObjectFiles :: Verbosity -> ConfiguredProgram + -> FilePath -> [FilePath] -> IO () +combineObjectFiles verbosity ld target files = + + -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is, + -- if we have more object files than fit on a single command line then we + -- have a slight problem. What we have to do is link files in batches into + -- a temp object file and then include that one in the next batch. + + let simpleArgs = ["-r", "-o", target] + + initialArgs = ["-r", "-o", target] + middleArgs = ["-r", "-o", target, tmpfile] + finalArgs = middleArgs + + simple = programInvocation ld simpleArgs + initial = programInvocation ld initialArgs + middle = programInvocation ld middleArgs + final = programInvocation ld finalArgs + + invocations = multiStageProgramInvocation + simple (initial, middle, final) files + + in run invocations + + where + tmpfile = target <.> "tmp" -- perhaps should use a proper temp file + + run [] = return () + run [inv] = runProgramInvocation verbosity inv + run (inv:invs) = do runProgramInvocation verbosity inv + renameFile target tmpfile + run invs diff --git a/cabal/Cabal/Distribution/Simple/Program/Run.hs b/cabal/Cabal/Distribution/Simple/Program/Run.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Program/Run.hs @@ -0,0 +1,218 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Run +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides a data type for program invocations and functions to +-- run them. + +module Distribution.Simple.Program.Run ( + ProgramInvocation(..), + IOEncoding(..), + emptyProgramInvocation, + simpleProgramInvocation, + programInvocation, + multiStageProgramInvocation, + + runProgramInvocation, + getProgramInvocationOutput, + + ) where + +import Distribution.Simple.Program.Types + ( ConfiguredProgram(..), programPath ) +import Distribution.Simple.Utils + ( die, rawSystemExit, rawSystemStdInOut + , toUTF8, fromUTF8, normaliseLineEndings ) +import Distribution.Verbosity + ( Verbosity ) + +import Data.List + ( foldl', unfoldr ) +import Control.Monad + ( when ) +import System.Exit + ( ExitCode(..) ) + +-- | Represents a specific invocation of a specific program. +-- +-- This is used as an intermediate type between deciding how to call a program +-- and actually doing it. This provides the opportunity to the caller to +-- adjust how the program will be called. These invocations can either be run +-- directly or turned into shell or batch scripts. +-- +data ProgramInvocation = ProgramInvocation { + progInvokePath :: FilePath, + progInvokeArgs :: [String], + progInvokeEnv :: [(String, String)], + progInvokeCwd :: Maybe FilePath, + progInvokeInput :: Maybe String, + progInvokeInputEncoding :: IOEncoding, + progInvokeOutputEncoding :: IOEncoding + } + +data IOEncoding = IOEncodingText -- locale mode text + | IOEncodingUTF8 -- always utf8 + +emptyProgramInvocation :: ProgramInvocation +emptyProgramInvocation = + ProgramInvocation { + progInvokePath = "", + progInvokeArgs = [], + progInvokeEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Nothing, + progInvokeInputEncoding = IOEncodingText, + progInvokeOutputEncoding = IOEncodingText + } + +simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation +simpleProgramInvocation path args = + emptyProgramInvocation { + progInvokePath = path, + progInvokeArgs = args + } + +programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation +programInvocation prog args = + emptyProgramInvocation { + progInvokePath = programPath prog, + progInvokeArgs = programDefaultArgs prog + ++ args + ++ programOverrideArgs prog + } + + +runProgramInvocation :: Verbosity -> ProgramInvocation -> IO () +runProgramInvocation verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Nothing + } = + rawSystemExit verbosity path args + +runProgramInvocation verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Just inputStr, + progInvokeInputEncoding = encoding + } = do + (_, errors, exitCode) <- rawSystemStdInOut verbosity + path args + (Just input) False + when (exitCode /= ExitSuccess) $ + die errors + where + input = case encoding of + IOEncodingText -> (inputStr, False) + IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8 + +runProgramInvocation _ _ = + die "runProgramInvocation: not yet implemented for this form of invocation" + + +getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String +getProgramInvocationOutput verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Nothing, + progInvokeOutputEncoding = encoding + } = do + let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False + decode | utf8 = fromUTF8 . normaliseLineEndings + | otherwise = id + (output, errors, exitCode) <- rawSystemStdInOut verbosity + path args + Nothing utf8 + when (exitCode /= ExitSuccess) $ + die errors + return (decode output) + + +getProgramInvocationOutput _ _ = + die "getProgramInvocationOutput: not yet implemented for this form of invocation" + + +-- | 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. +-- +-- It takes four template invocations corresponding to the simple, initial, +-- middle and last invocations. If the number of args given is small enough +-- that we can get away with just a single invocation then the simple one is +-- used: +-- +-- > $ simple args +-- +-- If the number of args given means that we need to use multiple invocations +-- then the templates for the initial, middle and last invocations are used: +-- +-- > $ initial args_0 +-- > $ middle args_1 +-- > $ middle args_2 +-- > ... +-- > $ final args_n +-- +multiStageProgramInvocation + :: ProgramInvocation + -> (ProgramInvocation, ProgramInvocation, ProgramInvocation) + -> [String] + -> [ProgramInvocation] +multiStageProgramInvocation simple (initial, middle, final) args = + + let argSize inv = length (progInvokePath inv) + + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) + fixedArgSize = maximum (map argSize [simple, initial, middle, final]) + chunkSize = maxCommandLineSize - fixedArgSize + + in case splitChunks chunkSize args of + [] -> [ simple ] + + [c] -> [ simple `appendArgs` c ] + + [c,c'] -> [ initial `appendArgs` c ] + ++ [ final `appendArgs` c'] + + (c:cs) -> [ initial `appendArgs` c ] + ++ [ middle `appendArgs` c'| c' <- init cs ] + ++ [ final `appendArgs` c'| let c' = last cs ] + + where + inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as } + + splitChunks len = unfoldr $ \s -> + if null s then Nothing + else Just (chunk len s) + + chunk len (s:_) | length s >= len = error toolong + chunk len ss = chunk' [] len ss + + chunk' acc _ [] = (reverse acc,[]) + chunk' acc len (s:ss) + | len' < len = chunk' (s:acc) (len-len'-1) ss + | otherwise = (reverse acc, s:ss) + where len' = length s + + toolong = "multiStageProgramInvocation: a single program arg is larger " + ++ "than the maximum command line length!" + + +--FIXME: 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 :: Int +maxCommandLineSize = 30 * 1024 diff --git a/cabal/Cabal/Distribution/Simple/Program/Script.hs b/cabal/Cabal/Distribution/Simple/Program/Script.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Program/Script.hs @@ -0,0 +1,105 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Script +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hc-pkg@ program. +-- Currently only GHC and LHC have hc-pkg programs. + +module Distribution.Simple.Program.Script ( + + invocationAsSystemScript, + invocationAsShellScript, + invocationAsBatchFile, + ) where + +import Distribution.Simple.Program.Run + ( ProgramInvocation(..) ) +import Distribution.System + ( OS(..) ) + +import Data.Maybe + ( maybeToList ) + +-- | Generate a system script, either POSIX shell script or Windows batch file +-- as appropriate for the given system. +-- +invocationAsSystemScript :: OS -> ProgramInvocation -> String +invocationAsSystemScript Windows = invocationAsBatchFile +invocationAsSystemScript _ = invocationAsShellScript + + +-- | Generate a POSIX shell script that invokes a program. +-- +invocationAsShellScript :: ProgramInvocation -> String +invocationAsShellScript + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envExtra, + progInvokeCwd = mcwd, + progInvokeInput = minput + } = unlines $ + [ "#!/bin/sh" ] + ++ [ "export " ++ var ++ "=" ++ quote val + | (var,val) <- envExtra ] + ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ] + ++ [ (case minput of + Nothing -> "" + Just input -> "echo " ++ quote input ++ " | ") + ++ unwords (map quote $ path : args) ++ " \"$@\""] + + where + quote :: String -> String + quote s = "'" ++ escape s ++ "'" + + escape [] = [] + escape ('\'':cs) = "'\\''" ++ escape cs + escape (c :cs) = c : escape cs + + +-- | Generate a Windows batch file that invokes a program. +-- +invocationAsBatchFile :: ProgramInvocation -> String +invocationAsBatchFile + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envExtra, + progInvokeCwd = mcwd, + progInvokeInput = minput + } = unlines $ + [ "@echo off" ] + ++ [ "set " ++ var ++ "=" ++ escape val | (var,val) <- envExtra ] + ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ] + ++ case minput of + Nothing -> + [ path ++ concatMap (' ':) args ] + + Just input -> + [ "(" ] + ++ [ "echo " ++ escape line | line <- lines input ] + ++ [ ") | " + ++ "\"" ++ path ++ "\"" + ++ concatMap (\arg -> ' ':quote arg) args ] + + where + quote :: String -> String + quote s = "\"" ++ escapeQ s ++ "\"" + + escapeQ [] = [] + escapeQ ('"':cs) = "\"\"\"" ++ escapeQ cs + escapeQ (c :cs) = c : escapeQ cs + + escape [] = [] + escape ('|':cs) = "^|" ++ escape cs + escape ('<':cs) = "^<" ++ escape cs + escape ('>':cs) = "^>" ++ escape cs + escape ('&':cs) = "^&" ++ escape cs + escape ('(':cs) = "^(" ++ escape cs + escape (')':cs) = "^)" ++ escape cs + escape ('^':cs) = "^^" ++ escape cs + escape (c :cs) = c : escape cs diff --git a/cabal/Cabal/Distribution/Simple/Program/Types.hs b/cabal/Cabal/Distribution/Simple/Program/Types.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Program/Types.hs @@ -0,0 +1,130 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Types +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides an abstraction which deals with configuring and running +-- programs. A 'Program' is a static notion of a known program. A +-- 'ConfiguredProgram' is a 'Program' that has been found on the current +-- machine and is ready to be run (possibly with some user-supplied default +-- args). Configuring a program involves finding its location and if necessary +-- finding its version. There's reasonable default behavior for trying to find +-- \"foo\" in PATH, being able to override its location, etc. +-- +module Distribution.Simple.Program.Types ( + -- * Program and functions for constructing them + Program(..), + simpleProgram, + + -- * Configured program and related functions + ConfiguredProgram(..), + programPath, + ProgArg, + ProgramLocation(..), + simpleConfiguredProgram, + ) where + +import Distribution.Simple.Utils + ( findProgramLocation ) +import Distribution.Version + ( Version ) +import Distribution.Verbosity + ( Verbosity ) + +-- | Represents a program which can be configured. +-- +-- Note: rather than constructing this directly, start with 'simpleProgram' and +-- override any extra fields. +-- +data Program = Program { + -- | The simple name of the program, eg. ghc + programName :: String, + + -- | A function to search for the program if it's location was not + -- specified by the user. Usually this will just be a + programFindLocation :: Verbosity -> 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. + programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version), + + -- | A function to do any additional configuration after we have + -- located the program (and perhaps identified its version). It is + -- allowed to return additional flags that will be passed to the + -- program on every invocation. + programPostConf :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + } + +type ProgArg = String + +-- | Represents a program which has been configured and is thus ready to be run. +-- +-- These are usually made by configuring a 'Program', but if you have to +-- construct one directly then start with 'simpleConfiguredProgram' and +-- override any extra fields. +-- +data ConfiguredProgram = ConfiguredProgram { + -- | Just the name again + programId :: String, + + -- | The version of this program, if it is known. + programVersion :: Maybe Version, + + -- | Default command-line args for this program. + -- These flags will appear first on the command line, so they can be + -- overridden by subsequent flags. + programDefaultArgs :: [String], + + -- | Override command-line args for this program. + -- These flags will appear last on the command line, so they override + -- all earlier flags. + programOverrideArgs :: [String], + + -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ + programLocation :: ProgramLocation + } deriving (Read, Show, Eq) + +-- | Where a program was found. Also tells us whether it's specifed by user or +-- not. This includes not just the path, but the program as well. +data ProgramLocation + = UserSpecified { locationPath :: FilePath } + -- ^The user gave the path to this program, + -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 + | FoundOnSystem { locationPath :: FilePath } + -- ^The program was found automatically. + deriving (Read, Show, Eq) + +-- | The full path of a configured program. +programPath :: ConfiguredProgram -> FilePath +programPath = locationPath . programLocation + +-- | Make a simple named program. +-- +-- By default we'll just search for it in the path and not try to find the +-- version name. You can override these behaviours if necessary, eg: +-- +-- > simpleProgram "foo" { programFindLocation = ... , programFindVersion ... } +-- +simpleProgram :: String -> Program +simpleProgram name = Program { + programName = name, + programFindLocation = \v -> findProgramLocation v name, + programFindVersion = \_ _ -> return Nothing, + programPostConf = \_ _ -> return [] + } + +-- | Make a simple 'ConfiguredProgram'. +-- +-- > simpleConfiguredProgram "foo" (FoundOnSystem path) +-- +simpleConfiguredProgram :: String -> ProgramLocation -> ConfiguredProgram +simpleConfiguredProgram name loc = ConfiguredProgram { + programId = name, + programVersion = Nothing, + programDefaultArgs = [], + programOverrideArgs = [], + programLocation = loc + } diff --git a/cabal/Cabal/Distribution/Simple/Register.hs b/cabal/Cabal/Distribution/Simple/Register.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Register.hs @@ -0,0 +1,404 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Register +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module deals with registering and unregistering packages. There are a +-- couple ways it can do this, one is to do it directly. Another is to generate +-- a script that can be run later to do it. The idea here being that the user +-- is shielded from the details of what command to use for package registration +-- for a particular compiler. In practice this aspect was not especially +-- 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 +-- latter is occasionally handy, and will become more important when we try to +-- build multi-package systems. +-- +-- This module does not delegate anything to the per-compiler modules but just +-- 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, + + initPackageDB, + registerPackage, + generateRegistrationInfo, + inplaceInstalledPackageInfo, + absoluteInstalledPackageInfo, + generalInstalledPackageInfo, + ) where + +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) + , 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 Distribution.Simple.Compiler + ( compilerVersion, Compiler, CompilerFlavor(..), compilerFlavor + , PackageDBStack, registrationPackageDB ) +import Distribution.Simple.Program + ( ProgramConfiguration, ConfiguredProgram + , runProgramInvocation, requireProgram, lookupProgram + , ghcPkgProgram, lhcPkgProgram ) +import Distribution.Simple.Program.Script + ( invocationAsSystemScript ) +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import Distribution.Simple.Setup + ( RegisterFlags(..), CopyDest(..) + , fromFlag, fromFlagOrDefault, flagToMaybe ) +import Distribution.PackageDescription + ( PackageDescription(..), Library(..), BuildInfo(..), hcOptions ) +import Distribution.Package + ( Package(..), packageName, InstalledPackageId(..) ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo, InstalledPackageInfo_(InstalledPackageInfo) + , showInstalledPackageInfo ) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Simple.Utils + ( writeUTF8File, writeFileAtomic, setFileExecutable + , die, notice, setupMessage ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Text + ( display ) +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 ) + +import Data.Maybe + ( isJust, fromMaybe, maybeToList ) +import Data.List + ( partition, nub ) +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 + +-- ----------------------------------------------------------------------------- +-- Registration + +register :: PackageDescription -> LocalBuildInfo + -> RegisterFlags -- ^Install in the user's database?; verbose + -> IO () +register pkg@PackageDescription { library = Just lib } + lbi@LocalBuildInfo { libraryConfig = Just clbi } regFlags + = do + + installedPkgInfo <- generateRegistrationInfo + verbosity pkg lib lbi clbi inplace distPref + + -- Three different modes: + case () of + _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo + | modeGenerateRegScript -> writeRegisterScript installedPkgInfo + | otherwise -> registerPackage verbosity + installedPkgInfo pkg lbi inplace packageDbs + + where + modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) + regFile = fromMaybe (display (packageId pkg) <.> "conf") + (fromFlag (regGenPkgConf regFlags)) + + modeGenerateRegScript = fromFlag (regGenScript regFlags) + + inplace = fromFlag (regInPlace regFlags) + -- FIXME: there's really no guarantee this will work. + -- registering into a totally different db stack can + -- fail if dependencies cannot be satisfied. + packageDbs = nub $ withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + distPref = fromFlag (regDistPref regFlags) + verbosity = fromFlag (regVerbosity regFlags) + + writeRegistrationFile installedPkgInfo = do + notice verbosity ("Creating package registration file: " ++ regFile) + writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo) + + 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" + +register _ _ regFlags = notice verbosity "No package to register" + where + verbosity = fromFlag (regVerbosity regFlags) + + +generateRegistrationInfo :: Verbosity + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Bool + -> FilePath + -> IO InstalledPackageInfo +generateRegistrationInfo verbosity pkg lib lbi clbi inplace distPref = do + --TODO: eliminate pwd! + pwd <- getCurrentDirectory + + --TODO: the method of setting the InstalledPackageId is compiler specific + -- this aspect should be delegated to a per-compiler helper. + let comp = compiler lbi + ipid <- + case compilerFlavor comp of + GHC | compilerVersion comp >= Version [6,11] [] -> do + s <- GHC.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 + + return installedPkgInfo{ IPI.installedPackageId = ipid } + + +-- | 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 + _ -> die "initPackageDB is not implemented for this compiler" + +registerPackage :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do + let msg = if inplace + then "In-place registering" + 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)" + _ -> die "Registering is not implemented for this compiler" + + +writeHcPkgRegisterScript :: Verbosity + -> InstalledPackageInfo + -> ConfiguredProgram + -> PackageDBStack + -> IO () +writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDbs = do + let invocation = HcPkg.reregisterInvocation hcPkg Verbosity.normal + packageDbs (Right installedPkgInfo) + regScript = invocationAsSystemScript buildOS invocation + + notice verbosity ("Creating package registration script: " ++ regScriptFileName) + writeUTF8File regScriptFileName regScript + setFileExecutable regScriptFileName + +regScriptFileName :: FilePath +regScriptFileName = case buildOS of + Windows -> "register.bat" + _ -> "register.sh" + + +-- ----------------------------------------------------------------------------- +-- Making the InstalledPackageInfo + +-- | Construct 'InstalledPackageInfo' for a library in a package, given a set +-- of installation directories. +-- +generalInstalledPackageInfo + :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to + -- absolute paths. + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> InstallDirs FilePath + -> InstalledPackageInfo +generalInstalledPackageInfo adjustRelIncDirs pkg lib clbi installDirs = + InstalledPackageInfo { + --TODO: do not open-code this conversion from PackageId to InstalledPackageId + IPI.installedPackageId = InstalledPackageId (display (packageId pkg)), + IPI.sourcePackageId = packageId pkg, + IPI.license = license pkg, + IPI.copyright = copyright pkg, + IPI.maintainer = maintainer pkg, + IPI.author = author pkg, + IPI.stability = stability pkg, + IPI.homepage = homepage pkg, + IPI.pkgUrl = pkgUrl pkg, + IPI.synopsis = synopsis pkg, + IPI.description = description pkg, + IPI.category = category pkg, + IPI.exposed = libExposed lib, + IPI.exposedModules = exposedModules lib, + IPI.hiddenModules = otherModules bi, + IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo, + IPI.importDirs = [ libdir installDirs | hasModules ], + IPI.libraryDirs = if hasLibrary + then libdir installDirs : extraLibDirs bi + else extraLibDirs bi, + IPI.hsLibraries = [ "HS" ++ display (packageId pkg) | hasLibrary ], + IPI.extraLibraries = extraLibs bi, + IPI.extraGHCiLibraries = [], + 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. + IPI.ldOptions = ldOptions bi, + IPI.frameworkDirs = [], + IPI.frameworks = frameworks bi, + IPI.haddockInterfaces = [haddockdir installDirs haddockName pkg], + IPI.haddockHTMLs = [htmldir installDirs] + } + where + bi = libBuildInfo lib + (absinc, relinc) = partition isAbsolute (includeDirs bi) + hasModules = not $ null (exposedModules lib) + && null (otherModules bi) + hasLibrary = hasModules || not (null (cSources bi)) + + +-- | Construct 'InstalledPackageInfo' for a library that is inplace in the +-- build tree. +-- +-- This function knows about the layout of inplace packages. +-- +inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree + -> FilePath -- ^ location of the dist tree + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo +inplaceInstalledPackageInfo inplaceDir distPref pkg lib lbi clbi = + generalInstalledPackageInfo adjustRelativeIncludeDirs pkg lib clbi + installDirs + where + adjustRelativeIncludeDirs = map (inplaceDir ) + installDirs = + (absoluteInstallDirs pkg lbi NoCopyDest) { + libdir = inplaceDir buildDir lbi, + datadir = inplaceDir, + datasubdir = distPref, + docdir = inplaceDocdir, + htmldir = inplaceHtmldir, + haddockdir = inplaceHtmldir + } + inplaceDocdir = inplaceDir distPref "doc" + inplaceHtmldir = inplaceDocdir "html" display (packageName pkg) + + +-- | Construct 'InstalledPackageInfo' for the final install location of a +-- library package. +-- +-- This function knows about the layout of installed packages. +-- +absoluteInstalledPackageInfo :: PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo +absoluteInstalledPackageInfo pkg lib lbi clbi = + generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib 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 = absoluteInstallDirs pkg lbi NoCopyDest + +-- ----------------------------------------------------------------------------- +-- Unregistration + +unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () +unregister pkg lbi regFlags = do + let pkgid = packageId pkg + genScript = fromFlag (regGenScript regFlags) + verbosity = fromFlag (regVerbosity regFlags) + packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) + (regPackageDB regFlags) + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + 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") + +unregScriptFileName :: FilePath +unregScriptFileName = case buildOS of + Windows -> "unregister.bat" + _ -> "unregister.sh" diff --git a/cabal/Cabal/Distribution/Simple/Setup.hs b/cabal/Cabal/Distribution/Simple/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Setup.hs @@ -0,0 +1,1680 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Setup +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is a big module, but not very complicated. The code is very regular +-- and repetitive. It defines the command line interface for all the Cabal +-- commands. For each command (like @configure@, @build@ etc) it defines a type +-- that holds all the flags, the default set of flags and a 'CommandUI' that +-- maps command line flags to and from the corresponding flags type. +-- +-- All the flags types are instances of 'Monoid', see +-- +-- for an explanation. +-- +-- The types defined here get used in the front end and especially in +-- @cabal-install@ which has to do quite a bit of manipulating sets of command +-- line flags. +-- +-- This is actually relatively nice, it works quite well. The main change it +-- needs is to unify it with the code for managing sets of fields that can be +-- 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. -} + +module Distribution.Simple.Setup ( + + GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, + ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, + CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, + InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, + HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, + HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, + BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, + buildVerbose, + CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, + RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, + unregisterCommand, + SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, + TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, + TestShowDetails(..), + BenchmarkFlags(..), emptyBenchmarkFlags, defaultBenchmarkFlags, benchmarkCommand, + CopyDest(..), + configureArgs, configureOptions, configureCCompiler, configureLinker, + buildOptions, installDirsOptions, + + defaultDistPref, + + Flag(..), + toFlag, + fromFlag, + fromFlagOrDefault, + flagToMaybe, + flagToList, + boolOpt, boolOpt', trueArg, falseArg, optionVerbosity ) where + +import Distribution.Compiler () +import Distribution.ReadE +import Distribution.Text + ( Text(..), display ) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Distribution.Package ( Dependency(..) ) +import Distribution.PackageDescription + ( FlagName(..), FlagAssignment ) +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import qualified Distribution.Simple.Command as Command +import Distribution.Simple.Compiler + ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..) + , OptimisationLevel(..), flagToOptimisationLevel ) +import Distribution.Simple.Utils + ( wrapLine, lowercase, intercalate ) +import Distribution.Simple.Program (Program(..), ProgramConfiguration, + requireProgram, + programInvocation, progInvokePath, progInvokeArgs, + knownPrograms, + addKnownProgram, emptyProgramConfiguration, + haddockProgram, ghcProgram, gccProgram, ldProgram) +import Distribution.Simple.InstallDirs + ( InstallDirs(..), CopyDest(..), + PathTemplate, toPathTemplate, fromPathTemplate ) +import Distribution.Verbosity + +import Data.List ( sort ) +import Data.Char ( isSpace, isAlpha ) +import Data.Monoid ( Monoid(..) ) + +-- FIXME Not sure where this should live +defaultDistPref :: FilePath +defaultDistPref = "dist" + +-- ------------------------------------------------------------ +-- * Flag type +-- ------------------------------------------------------------ + +-- | All flags are monoids, they come in two flavours: +-- +-- 1. list flags eg +-- +-- > --ghc-option=foo --ghc-option=bar +-- +-- gives us all the values ["foo", "bar"] +-- +-- 2. singular value flags, eg: +-- +-- > --enable-foo --disable-foo +-- +-- gives us Just False +-- So this Flag type is for the latter singular kind of flag. +-- 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) + +instance Functor Flag where + fmap f (Flag x) = Flag (f x) + fmap _ NoFlag = NoFlag + +instance Monoid (Flag a) where + mempty = NoFlag + _ `mappend` f@(Flag _) = f + f `mappend` NoFlag = f + +instance Bounded a => Bounded (Flag a) where + minBound = toFlag minBound + maxBound = toFlag maxBound + +instance Enum a => Enum (Flag a) where + fromEnum = fromEnum . fromFlag + toEnum = toFlag . toEnum + enumFrom (Flag a) = map toFlag . enumFrom $ a + enumFrom _ = [] + enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b + enumFromThen _ _ = [] + enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b + enumFromTo _ _ = [] + enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c + enumFromThenTo _ _ _ = [] + +toFlag :: a -> Flag a +toFlag = Flag + +fromFlag :: Flag a -> a +fromFlag (Flag x) = x +fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" + +fromFlagOrDefault :: a -> Flag a -> a +fromFlagOrDefault _ (Flag x) = x +fromFlagOrDefault def NoFlag = def + +flagToMaybe :: Flag a -> Maybe a +flagToMaybe (Flag x) = Just x +flagToMaybe NoFlag = Nothing + +flagToList :: Flag a -> [a] +flagToList (Flag x) = [x] +flagToList NoFlag = [] + +-- ------------------------------------------------------------ +-- * Global flags +-- ------------------------------------------------------------ + +-- In fact since individual flags types are monoids and these are just sets of +-- flags then they are also monoids pointwise. This turns out to be really +-- useful. The mempty is the set of empty flags and mappend allows us to +-- override specific flags. For example we can start with default flags and +-- override with the ones we get from a file or the command line, or both. + +-- | Flags that apply at the top level, not to any sub-command. +data GlobalFlags = GlobalFlags { + globalVersion :: Flag Bool, + globalNumericVersion :: Flag Bool + } + +defaultGlobalFlags :: GlobalFlags +defaultGlobalFlags = GlobalFlags { + globalVersion = Flag False, + globalNumericVersion = Flag False + } + +globalCommand :: CommandUI GlobalFlags +globalCommand = CommandUI { + commandName = "", + commandSynopsis = "", + commandUsage = \_ -> + "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" + ++ " " ++ pname ++ " COMMAND --help\n\n" + ++ "Typical steps for installing Cabal packages:\n" + ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" + | x <- ["configure", "build", "install"]], + commandDefaultFlags = defaultGlobalFlags, + commandOptions = \_ -> + [option ['V'] ["version"] + "Print version information" + globalVersion (\v flags -> flags { globalVersion = v }) + trueArg + ,option [] ["numeric-version"] + "Print just the version number" + globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) + trueArg + ] + } + +emptyGlobalFlags :: GlobalFlags +emptyGlobalFlags = mempty + +instance Monoid GlobalFlags where + mempty = GlobalFlags { + globalVersion = mempty, + globalNumericVersion = mempty + } + mappend a b = GlobalFlags { + globalVersion = combine globalVersion, + globalNumericVersion = combine globalNumericVersion + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Config flags +-- ------------------------------------------------------------ + +-- | Flags to @configure@ command +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. + -- when we change UserHooks next we should pass the initial + -- ProgramConfiguration directly and not via ConfigFlags + configPrograms :: ProgramConfiguration, -- ^All programs that cabal may run + + configProgramPaths :: [(String, FilePath)], -- ^user specifed programs paths + configProgramArgs :: [(String, [String])], -- ^user specifed programs args + configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the compiler, sugh as GHC or Hugs. + configHcPath :: Flag FilePath, -- ^given compiler location + configHcPkg :: Flag FilePath, -- ^given hc-pkg location + configVanillaLib :: Flag Bool, -- ^Enable vanilla library + configProfLib :: Flag Bool, -- ^Enable profiling in the library + configSharedLib :: Flag Bool, -- ^Build shared library + configDynExe :: Flag Bool, -- ^Enable dynamic linking of the executables. + configProfExe :: Flag Bool, -- ^Enable profiling in the executables. + configConfigureArgs :: [String], -- ^Extra arguments to @configure@ + configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. + configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix. + configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix. + configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation paths + configScratchDir :: Flag FilePath, + configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries + configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files + + configDistPref :: Flag FilePath, -- ^"dist" prefix + configVerbosity :: Flag Verbosity, -- ^verbosity level + configUserInstall :: Flag Bool, -- ^The --user\/--global flag + configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use + configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi + configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC + configStripExes :: Flag Bool, -- ^Enable executable stripping + configConstraints :: [Dependency], -- ^Additional constraints for + -- dependencies + configConfigurationsFlags :: FlagAssignment, + configTests :: Flag Bool, -- ^Enable test suite compilation + configBenchmarks :: Flag Bool, -- ^Enable benchmark compilation + configLibCoverage :: Flag Bool -- ^ Enable test suite program coverage + } + deriving (Read,Show) + +defaultConfigFlags :: ProgramConfiguration -> ConfigFlags +defaultConfigFlags progConf = emptyConfigFlags { + configPrograms = progConf, + configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, + configVanillaLib = Flag True, + configProfLib = Flag False, + configSharedLib = Flag False, + configDynExe = Flag False, + configProfExe = Flag False, + configOptimization = Flag NormalOptimisation, + configProgPrefix = Flag (toPathTemplate ""), + configProgSuffix = Flag (toPathTemplate ""), + configDistPref = Flag defaultDistPref, + configVerbosity = Flag normal, + configUserInstall = Flag False, --TODO: reverse this + configGHCiLib = Flag False, + configSplitObjs = Flag False, -- takes longer, so turn off by default + configStripExes = Flag True, + configTests = Flag False, + configBenchmarks = Flag False, + configLibCoverage = Flag False + } + +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 = + configureOptions showOrParseArgs + ++ programConfigurationPaths progConf showOrParseArgs + configProgramPaths (\v fs -> fs { configProgramPaths = v }) + ++ programConfigurationOptions progConf showOrParseArgs + configProgramArgs (\v fs -> fs { configProgramArgs = v }) + + +configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] +configureOptions showOrParseArgs = + [optionVerbosity configVerbosity (\v flags -> flags { configVerbosity = v }) + ,optionDistPref + configDistPref (\d flags -> flags { configDistPref = d }) + showOrParseArgs + + ,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")]) + + ,option "w" ["with-compiler"] + "give the path to a particular compiler" + configHcPath (\v flags -> flags { configHcPath = v }) + (reqArgFlag "PATH") + + ,option "" ["with-hc-pkg"] + "give the path to the package tool" + configHcPkg (\v flags -> flags { configHcPkg = v }) + (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"] + "prefix to be applied to installed executables" + configProgPrefix + (\v flags -> flags { configProgPrefix = v }) + (reqPathTemplateArgFlag "PREFIX") + + ,option "" ["program-suffix"] + "suffix to be applied to installed executables" + configProgSuffix (\v flags -> flags { configProgSuffix = v } ) + (reqPathTemplateArgFlag "SUFFIX") + + ,option "" ["library-vanilla"] + "Vanilla libraries" + configVanillaLib (\v flags -> flags { configVanillaLib = v }) + (boolOpt [] []) + + ,option "p" ["library-profiling"] + "Library profiling" + configProfLib (\v flags -> flags { configProfLib = v }) + (boolOpt "p" []) + + ,option "" ["shared"] + "Shared library" + configSharedLib (\v flags -> flags { configSharedLib = v }) + (boolOpt [] []) + + ,option "" ["executable-dynamic"] + "Executable dynamic linking" + configDynExe (\v flags -> flags { configDynExe = v }) + (boolOpt [] []) + + ,option "" ["executable-profiling"] + "Executable profiling" + configProfExe (\v flags -> flags { configProfExe = v }) + (boolOpt [] []) + + ,multiOption "optimization" + configOptimization (\v flags -> flags { configOptimization = v }) + [optArg' "n" (Flag . flagToOptimisationLevel) + (\f -> case f of + Flag NoOptimisation -> [] + Flag NormalOptimisation -> [Nothing] + Flag MaximumOptimisation -> [Just "2"] + _ -> []) + "O" ["enable-optimization","enable-optimisation"] + "Build with optimization (n is 0--2, default is 1)", + noArg (Flag NoOptimisation) [] + ["disable-optimization","disable-optimisation"] + "Build without optimization" + ] + + ,option "" ["library-for-ghci"] + "compile library for use with GHCi" + configGHCiLib (\v flags -> flags { configGHCiLib = v }) + (boolOpt [] []) + + ,option "" ["split-objs"] + "split library into smaller objects to reduce binary sizes (GHC 6.6+)" + configSplitObjs (\v flags -> flags { configSplitObjs = v }) + (boolOpt [] []) + + ,option "" ["executable-stripping"] + "strip executables upon installation to reduce binary sizes" + configStripExes (\v flags -> flags { configStripExes = v }) + (boolOpt [] []) + + ,option "" ["configure-option"] + "Extra option for configure" + configConfigureArgs (\v flags -> flags { configConfigureArgs = v }) + (reqArg' "OPT" (\x -> [x]) id) + + ,option "" ["user-install"] + "doing a per-user installation" + configUserInstall (\v flags -> flags { configUserInstall = v }) + (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'." + configPackageDBs (\v flags -> flags { configPackageDBs = v }) + (reqArg' "DB" readPackageDbList showPackageDbList) + + ,option "f" ["flags"] + "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." + configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v }) + (reqArg' "FLAGS" readFlagList showFlagList) + + ,option "" ["extra-include-dirs"] + "A list of directories to search for header files" + configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + + ,option "" ["extra-lib-dirs"] + "A list of directories to search for external libraries" + configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + ,option "" ["constraint"] + "A list of additional constraints on the dependencies." + configConstraints (\v flags -> flags { configConstraints = v}) + (reqArg "DEPENDENCY" + (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) + (map (\x -> display x))) + ,option "" ["tests"] + "dependency checking and compilation for test suites listed in the package description file." + configTests (\v flags -> flags { configTests = v }) + (boolOpt [] []) + ,option "" ["library-coverage"] + "build library and test suites with Haskell Program Coverage enabled. (GHC only)" + configLibCoverage (\v flags -> flags { configLibCoverage = v }) + (boolOpt [] []) + ,option "" ["benchmarks"] + "dependency checking and compilation for benchmarks listed in the package description file." + configBenchmarks (\v flags -> flags { configBenchmarks = v }) + (boolOpt [] []) + ] + where + readFlagList :: String -> FlagAssignment + readFlagList = map tagWithValue . words + where tagWithValue ('-':fname) = (FlagName (lowercase fname), False) + tagWithValue fname = (FlagName (lowercase fname), True) + + showFlagList :: FlagAssignment -> [String] + showFlagList fs = [ if not set then '-':fname else fname + | (FlagName fname, set) <- fs] + + readPackageDbList :: String -> [Maybe PackageDB] + readPackageDbList "clear" = [Nothing] + readPackageDbList "global" = [Just GlobalPackageDB] + readPackageDbList "user" = [Just UserPackageDB] + readPackageDbList other = [Just (SpecificPackageDB other)] + + showPackageDbList :: [Maybe PackageDB] -> [String] + showPackageDbList = map showPackageDb + where + showPackageDb Nothing = "clear" + showPackageDb (Just GlobalPackageDB) = "global" + showPackageDb (Just UserPackageDB) = "user" + showPackageDb (Just (SpecificPackageDB db)) = db + + liftInstallDirs = + liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v }) + + reqPathTemplateArgFlag title _sf _lf d get set = + reqArgFlag title _sf _lf d + (fmap fromPathTemplate . get) (set . fmap toPathTemplate) + +installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] +installDirsOptions = + [ option "" ["prefix"] + "bake this prefix in preparation of installation" + prefix (\v flags -> flags { prefix = v }) + installDirArg + + , option "" ["bindir"] + "installation directory for executables" + bindir (\v flags -> flags { bindir = v }) + installDirArg + + , option "" ["libdir"] + "installation directory for libraries" + libdir (\v flags -> flags { libdir = v }) + installDirArg + + , option "" ["libsubdir"] + "subdirectory of libdir in which libs are installed" + libsubdir (\v flags -> flags { libsubdir = v }) + installDirArg + + , option "" ["libexecdir"] + "installation directory for program executables" + libexecdir (\v flags -> flags { libexecdir = v }) + installDirArg + + , option "" ["datadir"] + "installation directory for read-only data" + datadir (\v flags -> flags { datadir = v }) + installDirArg + + , option "" ["datasubdir"] + "subdirectory of datadir in which data files are installed" + datasubdir (\v flags -> flags { datasubdir = v }) + installDirArg + + , option "" ["docdir"] + "installation directory for documentation" + docdir (\v flags -> flags { docdir = v }) + installDirArg + + , option "" ["htmldir"] + "installation directory for HTML documentation" + htmldir (\v flags -> flags { htmldir = v }) + installDirArg + + , option "" ["haddockdir"] + "installation directory for haddock interfaces" + haddockdir (\v flags -> flags { haddockdir = v }) + installDirArg + ] + where + installDirArg _sf _lf d get set = + reqArgFlag "DIR" _sf _lf d + (fmap fromPathTemplate . get) (set . fmap toPathTemplate) + +emptyConfigFlags :: ConfigFlags +emptyConfigFlags = mempty + +instance Monoid ConfigFlags where + mempty = ConfigFlags { + configPrograms = error "FIXME: remove configPrograms", + configProgramPaths = mempty, + configProgramArgs = mempty, + configHcFlavor = mempty, + configHcPath = mempty, + configHcPkg = mempty, + configVanillaLib = mempty, + configProfLib = mempty, + configSharedLib = mempty, + configDynExe = mempty, + configProfExe = mempty, + configConfigureArgs = mempty, + configOptimization = mempty, + configProgPrefix = mempty, + configProgSuffix = mempty, + configInstallDirs = mempty, + configScratchDir = mempty, + configDistPref = mempty, + configVerbosity = mempty, + configUserInstall = mempty, + configPackageDBs = mempty, + configGHCiLib = mempty, + configSplitObjs = mempty, + configStripExes = mempty, + configExtraLibDirs = mempty, + configConstraints = mempty, + configExtraIncludeDirs = mempty, + configConfigurationsFlags = mempty, + configTests = mempty, + configLibCoverage = mempty, + configBenchmarks = mempty + } + mappend a b = ConfigFlags { + configPrograms = configPrograms b, + configProgramPaths = combine configProgramPaths, + configProgramArgs = combine configProgramArgs, + configHcFlavor = combine configHcFlavor, + configHcPath = combine configHcPath, + configHcPkg = combine configHcPkg, + configVanillaLib = combine configVanillaLib, + configProfLib = combine configProfLib, + configSharedLib = combine configSharedLib, + configDynExe = combine configDynExe, + configProfExe = combine configProfExe, + configConfigureArgs = combine configConfigureArgs, + configOptimization = combine configOptimization, + configProgPrefix = combine configProgPrefix, + configProgSuffix = combine configProgSuffix, + configInstallDirs = combine configInstallDirs, + configScratchDir = combine configScratchDir, + configDistPref = combine configDistPref, + configVerbosity = combine configVerbosity, + configUserInstall = combine configUserInstall, + configPackageDBs = combine configPackageDBs, + configGHCiLib = combine configGHCiLib, + configSplitObjs = combine configSplitObjs, + configStripExes = combine configStripExes, + configExtraLibDirs = combine configExtraLibDirs, + configConstraints = combine configConstraints, + configExtraIncludeDirs = combine configExtraIncludeDirs, + configConfigurationsFlags = combine configConfigurationsFlags, + configTests = combine configTests, + configLibCoverage = combine configLibCoverage, + configBenchmarks = combine configBenchmarks + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Copy flags +-- ------------------------------------------------------------ + +-- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity) +data CopyFlags = CopyFlags { + copyDest :: Flag CopyDest, + copyDistPref :: Flag FilePath, + copyVerbosity :: Flag Verbosity + } + deriving Show + +defaultCopyFlags :: CopyFlags +defaultCopyFlags = CopyFlags { + copyDest = Flag NoCopyDest, + copyDistPref = Flag defaultDistPref, + 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" + ++ "Without the --destdir flag, configure determines location.\n" + options showOrParseArgs = + [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v }) + + ,optionDistPref + copyDistPref (\d flags -> flags { copyDistPref = d }) + showOrParseArgs + + ,option "" ["destdir"] + "directory to copy files to, prepended to installation directories" + copyDest (\v flags -> flags { copyDest = v }) + (reqArg "DIR" (succeedReadE (Flag . CopyTo)) + (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) + ] + +emptyCopyFlags :: CopyFlags +emptyCopyFlags = mempty + +instance Monoid CopyFlags where + mempty = CopyFlags { + copyDest = mempty, + copyDistPref = mempty, + copyVerbosity = mempty + } + mappend a b = CopyFlags { + copyDest = combine copyDest, + copyDistPref = combine copyDistPref, + copyVerbosity = combine copyVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Install flags +-- ------------------------------------------------------------ + +-- | Flags to @install@: (package db, verbosity) +data InstallFlags = InstallFlags { + installPackageDB :: Flag PackageDB, + installDistPref :: Flag FilePath, + installUseWrapper :: Flag Bool, + installInPlace :: Flag Bool, + installVerbosity :: Flag Verbosity + } + deriving Show + +defaultInstallFlags :: InstallFlags +defaultInstallFlags = InstallFlags { + installPackageDB = NoFlag, + installDistPref = Flag defaultDistPref, + 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" + ++ "specified in the configure step, use the copy command.\n" + options showOrParseArgs = + [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v }) + ,optionDistPref + installDistPref (\d flags -> flags { installDistPref = d }) + showOrParseArgs + + ,option "" ["inplace"] + "install the package in the install subdirectory of the dist prefix, so it can be used without being installed" + installInPlace (\v flags -> flags { installInPlace = v }) + trueArg + + ,option "" ["shell-wrappers"] + "using shell script wrappers around executables" + installUseWrapper (\v flags -> flags { installUseWrapper = v }) + (boolOpt [] []) + + ,option "" ["package-db"] "" + installPackageDB (\v flags -> flags { installPackageDB = v }) + (choiceOpt [ (Flag UserPackageDB, ([],["user"]), + "upon configuration register this package in the user's local package database") + , (Flag GlobalPackageDB, ([],["global"]), + "(default) upon configuration register this package in the system-wide package database")]) + ] + +emptyInstallFlags :: InstallFlags +emptyInstallFlags = mempty + +instance Monoid InstallFlags where + mempty = InstallFlags{ + installPackageDB = mempty, + installDistPref = mempty, + installUseWrapper = mempty, + installInPlace = mempty, + installVerbosity = mempty + } + mappend a b = InstallFlags{ + installPackageDB = combine installPackageDB, + installDistPref = combine installDistPref, + installUseWrapper = combine installUseWrapper, + installInPlace = combine installInPlace, + installVerbosity = combine installVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * SDist flags +-- ------------------------------------------------------------ + +-- | Flags to @sdist@: (snapshot, verbosity) +data SDistFlags = SDistFlags { + sDistSnapshot :: Flag Bool, + sDistDirectory :: Flag FilePath, + sDistDistPref :: Flag FilePath, + sDistVerbosity :: Flag Verbosity + } + deriving Show + +defaultSDistFlags :: SDistFlags +defaultSDistFlags = SDistFlags { + sDistSnapshot = Flag False, + sDistDirectory = mempty, + sDistDistPref = Flag defaultDistPref, + 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 = + [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v }) + ,optionDistPref + sDistDistPref (\d flags -> flags { sDistDistPref = d }) + showOrParseArgs + + ,option "" ["snapshot"] + "Produce a snapshot source distribution" + sDistSnapshot (\v flags -> flags { sDistSnapshot = v }) + trueArg + + ,option "" ["output-directory"] + "Generate a source distribution in the given directory" + sDistDirectory (\v flags -> flags { sDistDirectory = v }) + (reqArgFlag "DIR") + ] + +emptySDistFlags :: SDistFlags +emptySDistFlags = mempty + +instance Monoid SDistFlags where + mempty = SDistFlags { + sDistSnapshot = mempty, + sDistDirectory = mempty, + sDistDistPref = mempty, + sDistVerbosity = mempty + } + mappend a b = SDistFlags { + sDistSnapshot = combine sDistSnapshot, + sDistDirectory = combine sDistDirectory, + sDistDistPref = combine sDistDistPref, + sDistVerbosity = combine sDistVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Register flags +-- ------------------------------------------------------------ + +-- | Flags to @register@ and @unregister@: (user package, gen-script, +-- in-place, verbosity) +data RegisterFlags = RegisterFlags { + regPackageDB :: Flag PackageDB, + regGenScript :: Flag Bool, + regGenPkgConf :: Flag (Maybe FilePath), + regInPlace :: Flag Bool, + regDistPref :: Flag FilePath, + regVerbosity :: Flag Verbosity + } + deriving Show + +defaultRegisterFlags :: RegisterFlags +defaultRegisterFlags = RegisterFlags { + regPackageDB = NoFlag, + regGenScript = Flag False, + regGenPkgConf = NoFlag, + regInPlace = Flag False, + regDistPref = Flag defaultDistPref, + 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 = + [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) + ,optionDistPref + regDistPref (\d flags -> flags { regDistPref = d }) + showOrParseArgs + + ,option "" ["packageDB"] "" + regPackageDB (\v flags -> flags { regPackageDB = v }) + (choiceOpt [ (Flag UserPackageDB, ([],["user"]), + "upon registration, register this package in the user's local package database") + , (Flag GlobalPackageDB, ([],["global"]), + "(default)upon registration, register this package in the system-wide package database")]) + + ,option "" ["inplace"] + "register the package in the build location, so it can be used without being installed" + regInPlace (\v flags -> flags { regInPlace = v }) + trueArg + + ,option "" ["gen-script"] + "instead of registering, generate a script to register later" + regGenScript (\v flags -> flags { regGenScript = v }) + trueArg + + ,option "" ["gen-pkg-config"] + "instead of registering, generate a package registration file" + regGenPkgConf (\v flags -> flags { regGenPkgConf = v }) + (optArg' "PKG" Flag flagToList) + ] + +unregisterCommand :: CommandUI RegisterFlags +unregisterCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options + where + name = "unregister" + shortDesc = "Unregister this package with the compiler." + longDesc = Nothing + options showOrParseArgs = + [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) + ,optionDistPref + regDistPref (\d flags -> flags { regDistPref = d }) + showOrParseArgs + + ,option "" ["user"] "" + regPackageDB (\v flags -> flags { regPackageDB = v }) + (choiceOpt [ (Flag UserPackageDB, ([],["user"]), + "unregister this package in the user's local package database") + , (Flag GlobalPackageDB, ([],["global"]), + "(default) unregister this package in the system-wide package database")]) + + ,option "" ["gen-script"] + "Instead of performing the unregister command, generate a script to unregister later" + regGenScript (\v flags -> flags { regGenScript = v }) + trueArg + ] + +emptyRegisterFlags :: RegisterFlags +emptyRegisterFlags = mempty + +instance Monoid RegisterFlags where + mempty = RegisterFlags { + regPackageDB = mempty, + regGenScript = mempty, + regGenPkgConf = mempty, + regInPlace = mempty, + regDistPref = mempty, + regVerbosity = mempty + } + mappend a b = RegisterFlags { + regPackageDB = combine regPackageDB, + regGenScript = combine regGenScript, + regGenPkgConf = combine regGenPkgConf, + regInPlace = combine regInPlace, + regDistPref = combine regDistPref, + regVerbosity = combine regVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * HsColour flags +-- ------------------------------------------------------------ + +data HscolourFlags = HscolourFlags { + hscolourCSS :: Flag FilePath, + hscolourExecutables :: Flag Bool, + hscolourDistPref :: Flag FilePath, + hscolourVerbosity :: Flag Verbosity + } + deriving Show + +emptyHscolourFlags :: HscolourFlags +emptyHscolourFlags = mempty + +defaultHscolourFlags :: HscolourFlags +defaultHscolourFlags = HscolourFlags { + hscolourCSS = NoFlag, + hscolourExecutables = Flag False, + hscolourDistPref = Flag defaultDistPref, + hscolourVerbosity = Flag normal + } + +instance Monoid HscolourFlags where + mempty = HscolourFlags { + hscolourCSS = mempty, + hscolourExecutables = mempty, + hscolourDistPref = mempty, + hscolourVerbosity = mempty + } + mappend a b = HscolourFlags { + hscolourCSS = combine hscolourCSS, + hscolourExecutables = combine hscolourExecutables, + hscolourDistPref = combine hscolourDistPref, + hscolourVerbosity = combine hscolourVerbosity + } + 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 = + [optionVerbosity hscolourVerbosity (\v flags -> flags { hscolourVerbosity = v }) + ,optionDistPref + hscolourDistPref (\d flags -> flags { hscolourDistPref = d }) + showOrParseArgs + + ,option "" ["executables"] + "Run hscolour for Executables targets" + hscolourExecutables (\v flags -> flags { hscolourExecutables = v }) + trueArg + + ,option "" ["css"] + "Use a cascading style sheet" + hscolourCSS (\v flags -> flags { hscolourCSS = v }) + (reqArgFlag "PATH") + ] + +-- ------------------------------------------------------------ +-- * Haddock flags +-- ------------------------------------------------------------ + +data HaddockFlags = HaddockFlags { + haddockProgramPaths :: [(String, FilePath)], + haddockProgramArgs :: [(String, [String])], + haddockHoogle :: Flag Bool, + haddockHtml :: Flag Bool, + haddockHtmlLocation :: Flag String, + haddockExecutables :: Flag Bool, + haddockInternal :: Flag Bool, + haddockCss :: Flag FilePath, + haddockHscolour :: Flag Bool, + haddockHscolourCss :: Flag FilePath, + haddockContents :: Flag PathTemplate, + haddockDistPref :: Flag FilePath, + haddockVerbosity :: Flag Verbosity + } + deriving Show + +defaultHaddockFlags :: HaddockFlags +defaultHaddockFlags = HaddockFlags { + haddockProgramPaths = mempty, + haddockProgramArgs = [], + haddockHoogle = Flag False, + haddockHtml = Flag False, + haddockHtmlLocation = NoFlag, + haddockExecutables = Flag False, + haddockInternal = Flag False, + haddockCss = NoFlag, + haddockHscolour = Flag False, + haddockHscolourCss = NoFlag, + haddockContents = NoFlag, + haddockDistPref = Flag defaultDistPref, + haddockVerbosity = Flag normal + } + +haddockCommand :: CommandUI HaddockFlags +haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options + 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 + + ,option "" ["hoogle"] + "Generate a hoogle database" + haddockHoogle (\v flags -> flags { haddockHoogle = v }) + trueArg + + ,option "" ["html"] + "Generate HTML documentation (the default)" + haddockHtml (\v flags -> flags { haddockHtml = v }) + trueArg + + ,option "" ["html-location"] + "Location of HTML documentation for pre-requisite packages" + haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v }) + (reqArgFlag "URL") + + ,option "" ["executables"] + "Run haddock for Executables targets" + haddockExecutables (\v flags -> flags { haddockExecutables = 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 "" ["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 "" ["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}) + ++ programConfigurationOptions progConf ParseArgs + haddockProgramArgs (\v flags -> flags { haddockProgramArgs = v}) + progConf = addKnownProgram haddockProgram + $ addKnownProgram ghcProgram + $ emptyProgramConfiguration + +emptyHaddockFlags :: HaddockFlags +emptyHaddockFlags = mempty + +instance Monoid HaddockFlags where + mempty = HaddockFlags { + haddockProgramPaths = mempty, + haddockProgramArgs = mempty, + haddockHoogle = mempty, + haddockHtml = mempty, + haddockHtmlLocation = mempty, + haddockExecutables = mempty, + haddockInternal = mempty, + haddockCss = mempty, + haddockHscolour = mempty, + haddockHscolourCss = mempty, + haddockContents = mempty, + haddockDistPref = mempty, + haddockVerbosity = mempty + } + mappend a b = HaddockFlags { + haddockProgramPaths = combine haddockProgramPaths, + haddockProgramArgs = combine haddockProgramArgs, + haddockHoogle = combine haddockHoogle, + haddockHtml = combine haddockHoogle, + haddockHtmlLocation = combine haddockHtmlLocation, + haddockExecutables = combine haddockExecutables, + haddockInternal = combine haddockInternal, + haddockCss = combine haddockCss, + haddockHscolour = combine haddockHscolour, + haddockHscolourCss = combine haddockHscolourCss, + haddockContents = combine haddockContents, + haddockDistPref = combine haddockDistPref, + haddockVerbosity = combine haddockVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Clean flags +-- ------------------------------------------------------------ + +data CleanFlags = CleanFlags { + cleanSaveConf :: Flag Bool, + cleanDistPref :: Flag FilePath, + cleanVerbosity :: Flag Verbosity + } + deriving Show + +defaultCleanFlags :: CleanFlags +defaultCleanFlags = CleanFlags { + cleanSaveConf = Flag False, + cleanDistPref = Flag defaultDistPref, + 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 = + [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) + ,optionDistPref + cleanDistPref (\d flags -> flags { cleanDistPref = d }) + showOrParseArgs + + ,option "s" ["save-configure"] + "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." + cleanSaveConf (\v flags -> flags { cleanSaveConf = v }) + trueArg + ] + +emptyCleanFlags :: CleanFlags +emptyCleanFlags = mempty + +instance Monoid CleanFlags where + mempty = CleanFlags { + cleanSaveConf = mempty, + cleanDistPref = mempty, + cleanVerbosity = mempty + } + mappend a b = CleanFlags { + cleanSaveConf = combine cleanSaveConf, + cleanDistPref = combine cleanDistPref, + cleanVerbosity = combine cleanVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Build flags +-- ------------------------------------------------------------ + +data BuildFlags = BuildFlags { + buildProgramPaths :: [(String, FilePath)], + buildProgramArgs :: [(String, [String])], + buildDistPref :: Flag FilePath, + buildVerbosity :: Flag Verbosity + } + deriving Show + +{-# DEPRECATED buildVerbose "Use buildVerbosity instead" #-} +buildVerbose :: BuildFlags -> Verbosity +buildVerbose = fromFlagOrDefault normal . buildVerbosity + +defaultBuildFlags :: BuildFlags +defaultBuildFlags = BuildFlags { + buildProgramPaths = mempty, + buildProgramArgs = [], + buildDistPref = Flag defaultDistPref, + buildVerbosity = Flag normal + } + +buildCommand :: ProgramConfiguration -> CommandUI BuildFlags +buildCommand progConf = makeCommand name shortDesc longDesc + defaultBuildFlags (buildOptions progConf) + where + name = "build" + shortDesc = "Make this package ready for installation." + longDesc = Nothing + +buildOptions :: ProgramConfiguration -> ShowOrParseArgs + -> [OptionField BuildFlags] +buildOptions progConf showOrParseArgs = + optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v }) + : optionDistPref + buildDistPref (\d flags -> flags { buildDistPref = d }) + showOrParseArgs + + : programConfigurationPaths progConf showOrParseArgs + buildProgramPaths (\v flags -> flags { buildProgramPaths = v}) + + ++ programConfigurationOptions progConf showOrParseArgs + buildProgramArgs (\v flags -> flags { buildProgramArgs = v}) + +emptyBuildFlags :: BuildFlags +emptyBuildFlags = mempty + +instance Monoid BuildFlags where + mempty = BuildFlags { + buildProgramPaths = mempty, + buildProgramArgs = mempty, + buildVerbosity = mempty, + buildDistPref = mempty + } + mappend a b = BuildFlags { + buildProgramPaths = combine buildProgramPaths, + buildProgramArgs = combine buildProgramArgs, + buildVerbosity = combine buildVerbosity, + buildDistPref = combine buildDistPref + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Test flags +-- ------------------------------------------------------------ + +data TestShowDetails = Never | Failures | Always + deriving (Eq, Ord, Enum, Bounded, Show) + +knownTestShowDetails :: [TestShowDetails] +knownTestShowDetails = [minBound..maxBound] + +instance Text TestShowDetails where + disp = Disp.text . lowercase . show + + parse = maybe Parse.pfail return . classify =<< ident + where + ident = Parse.munch1 (\c -> isAlpha c || c == '_' || c == '-') + classify str = lookup (lowercase str) enumMap + enumMap :: [(String, TestShowDetails)] + enumMap = [ (display x, x) + | x <- knownTestShowDetails ] + +--TODO: do we need this instance? +instance Monoid TestShowDetails where + mempty = Never + mappend a b = if a < b then b else a + +data TestFlags = TestFlags { + testDistPref :: Flag FilePath, + testVerbosity :: Flag Verbosity, + testHumanLog :: Flag PathTemplate, + 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, + 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 = + [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) + , optionDistPref + testDistPref (\d flags -> flags { testDistPref = d }) + showOrParseArgs + , option [] ["log"] + ("Log all test suite results to file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)") + testHumanLog (\v flags -> flags { testHumanLog = v }) + (reqArg' "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate)) + , option [] ["machine-log"] + ("Produce a machine-readable log file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $result)") + testMachineLog (\v flags -> flags { testMachineLog = v }) + (reqArg' "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate)) + , 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.") + testShowDetails (\v flags -> flags { testShowDetails = v }) + (reqArg "FILTER" + (readP_to_E (\_ -> "--show-details flag expects one of " + ++ intercalate ", " + (map display knownTestShowDetails)) + (fmap toFlag parse)) + (flagToList . fmap display)) + , option [] ["keep-tix-files"] + "keep .tix files for HPC between test runs" + testKeepTix (\v flags -> flags { testKeepTix = v}) + trueArg + , option [] ["test-options"] + ("give extra options to test executables " + ++ "(name templates can use $pkgid, $compiler, " + ++ "$os, $arch, $test-suite)") + testOptions (\v flags -> flags { testOptions = v }) + (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) + (const [])) + , option [] ["test-option"] + ("give extra option to test executables " + ++ "(no need to quote options containing spaces, " + ++ "name template can use $pkgid, $compiler, " + ++ "$os, $arch, $test-suite)") + testOptions (\v flags -> flags { testOptions = v }) + (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) + (map fromPathTemplate)) + ] + +emptyTestFlags :: TestFlags +emptyTestFlags = mempty + +instance Monoid TestFlags where + mempty = TestFlags { + testDistPref = mempty, + testVerbosity = mempty, + testHumanLog = mempty, + testMachineLog = mempty, + testShowDetails = mempty, + testKeepTix = mempty, + testList = mempty, + testOptions = mempty + } + mappend a b = TestFlags { + testDistPref = combine testDistPref, + testVerbosity = combine testVerbosity, + testHumanLog = combine testHumanLog, + testMachineLog = combine testMachineLog, + testShowDetails = combine testShowDetails, + testKeepTix = combine testKeepTix, + testList = combine testList, + testOptions = combine testOptions + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Benchmark flags +-- ------------------------------------------------------------ + +data BenchmarkFlags = BenchmarkFlags { + benchmarkDistPref :: Flag FilePath, + benchmarkVerbosity :: Flag Verbosity, + benchmarkOptions :: [PathTemplate] + } + +defaultBenchmarkFlags :: BenchmarkFlags +defaultBenchmarkFlags = BenchmarkFlags { + benchmarkDistPref = Flag defaultDistPref, + 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 = + [ optionVerbosity benchmarkVerbosity (\v flags -> flags { benchmarkVerbosity = v }) + , optionDistPref + benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d }) + showOrParseArgs + , option [] ["benchmark-options"] + ("give extra options to benchmark executables " + ++ "(name templates can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)") + benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) + (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) + (const [])) + , option [] ["benchmark-option"] + ("give extra option to benchmark executables " + ++ "(no need to quote options containing spaces, " + ++ "name template can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)") + benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) + (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) + (map fromPathTemplate)) + ] + +emptyBenchmarkFlags :: BenchmarkFlags +emptyBenchmarkFlags = mempty + +instance Monoid BenchmarkFlags where + mempty = BenchmarkFlags { + benchmarkDistPref = mempty, + benchmarkVerbosity = mempty, + benchmarkOptions = mempty + } + mappend a b = BenchmarkFlags { + benchmarkDistPref = combine benchmarkDistPref, + benchmarkVerbosity = combine benchmarkVerbosity, + benchmarkOptions = combine benchmarkOptions + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Shared options utils +-- ------------------------------------------------------------ + +programFlagsDescription :: ProgramConfiguration -> String +programFlagsDescription progConf = + "The flags --with-PROG and --PROG-option(s) can be used with" + ++ " the following programs:" + ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort) + [ programName prog | (prog, _) <- knownPrograms progConf ] + ++ "\n" + +programConfigurationPaths + :: ProgramConfiguration + -> ShowOrParseArgs + -> (flags -> [(String, FilePath)]) + -> ([(String, FilePath)] -> (flags -> flags)) + -> [OptionField flags] +programConfigurationPaths progConf showOrParseArgs get set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [withProgramPath "PROG"] + ParseArgs -> map (withProgramPath . programName . fst) (knownPrograms progConf) + where + withProgramPath prog = + option "" ["with-" ++ prog] + ("give the path to " ++ prog) + get set + (reqArg' "PATH" (\path -> [(prog, path)]) + (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) + +programConfigurationOptions + :: ProgramConfiguration + -> ShowOrParseArgs + -> (flags -> [(String, [String])]) + -> ([(String, [String])] -> (flags -> flags)) + -> [OptionField flags] +programConfigurationOptions progConf showOrParseArgs get set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [programOptions "PROG", programOption "PROG"] + ParseArgs -> map (programOptions . programName . fst) (knownPrograms progConf) + ++ map (programOption . programName . fst) (knownPrograms progConf) + where + programOptions prog = + option "" [prog ++ "-options"] + ("give extra options to " ++ prog) + get set + (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) + + programOption prog = + option "" [prog ++ "-option"] + ("give an extra option to " ++ prog ++ + " (no need to quote options containing spaces)") + get set + (reqArg' "OPT" (\arg -> [(prog, [arg])]) + (\progArgs -> concat [ args | (prog', args) <- progArgs, prog==prog' ])) + + +-- ------------------------------------------------------------ +-- * GetOpt Utils +-- ------------------------------------------------------------ + +boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt = Command.boolOpt flagToMaybe Flag + +boolOpt' :: OptFlags -> OptFlags -> 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) + +reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> + (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b +reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList + +optionDistPref :: (flags -> Flag FilePath) + -> (Flag FilePath -> flags -> flags) + -> ShowOrParseArgs + -> OptionField flags +optionDistPref get set = \showOrParseArgs -> + option "" (distPrefFlagName showOrParseArgs) + ( "The directory where Cabal puts generated build files " + ++ "(default " ++ defaultDistPref ++ ")") + get set + (reqArgFlag "DIR") + where + distPrefFlagName ShowArgs = ["builddir"] + distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"] + +optionVerbosity :: (flags -> Flag Verbosity) + -> (Flag Verbosity -> flags -> flags) + -> OptionField flags +optionVerbosity get set = + option "v" ["verbose"] + "Control verbosity (n is 0--3, default verbosity level is 1)" + get set + (optArg "n" (fmap Flag flagToVerbosity) + (Flag verbose) -- default Value if no n is given + (fmap (Just . showForCabal) . flagToList)) + +-- ------------------------------------------------------------ +-- * Other Utils +-- ------------------------------------------------------------ + +-- | Arguments to pass to a @configure@ script, e.g. generated by +-- @autoconf@. +configureArgs :: Bool -> ConfigFlags -> [String] +configureArgs bcHack flags + = hc_flag + ++ optFlag "with-hc-pkg" configHcPkg + ++ optFlag' "prefix" prefix + ++ optFlag' "bindir" bindir + ++ optFlag' "libdir" libdir + ++ optFlag' "libexecdir" libexecdir + ++ optFlag' "datadir" datadir + ++ configConfigureArgs flags + where + hc_flag = case (configHcFlavor flags, configHcPath flags) of + (_, Flag hc_path) -> [hc_flag_name ++ hc_path] + (Flag hc, NoFlag) -> [hc_flag_name ++ display hc] + (NoFlag,NoFlag) -> [] + hc_flag_name + --TODO kill off thic bc hack when defaultUserHooks is removed. + | bcHack = "--with-hc=" + | otherwise = "--with-compiler=" + optFlag name config_field = case config_field flags of + Flag p -> ["--" ++ name ++ "=" ++ p] + NoFlag -> [] + optFlag' name config_field = optFlag name (fmap fromPathTemplate + . config_field + . configInstallDirs) + +configureCCompiler :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String]) +configureCCompiler verbosity lbi = configureProg verbosity lbi gccProgram + +configureLinker :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String]) +configureLinker verbosity lbi = configureProg verbosity lbi ldProgram + +configureProg :: Verbosity -> ProgramConfiguration -> Program -> IO (FilePath, [String]) +configureProg verbosity programConfig prog = do + (p, _) <- requireProgram verbosity prog programConfig + let pInv = programInvocation p [] + return (progInvokePath pInv, progInvokeArgs pInv) + +-- | Helper function to split a string into a list of arguments. +-- It's supposed to handle quoted things sensibly, eg: +-- +-- > splitArgs "--foo=\"C:\Program Files\Bar\" --baz" +-- > = ["--foo=C:\Program Files\Bar", "--baz"] +-- +splitArgs :: String -> [String] +splitArgs = space [] + where + space :: String -> String -> [String] + space w [] = word w [] + space w ( c :s) + | isSpace c = word w (space [] s) + space w ('"':s) = string w s + space w s = nonstring w s + + string :: String -> String -> [String] + string w [] = word w [] + string w ('"':s) = space w s + string w ( c :s) = string (c:w) s + + nonstring :: String -> String -> [String] + nonstring w [] = word w [] + nonstring w ('"':s) = string w s + nonstring w ( c :s) = space (c:w) s + + word [] s = s + word w s = reverse w : s + +-- The test cases kinda have to be rewritten from the ground up... :/ +--hunitTests :: [Test] +--hunitTests = +-- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)] +-- (flags, commands', unkFlags, ers) +-- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"] +-- in [TestLabel "very basic option parsing" $ TestList [ +-- "getOpt flags" ~: "failed" ~: +-- [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag, +-- WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag] +-- ~=? flags, +-- "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands', +-- "getOpt unknown opts" ~: "failed" ~: +-- ["--unknown1", "--unknown2"] ~=? unkFlags, +-- "getOpt errors" ~: "failed" ~: [] ~=? ers], +-- +-- TestLabel "test location of various compilers" $ TestList +-- ["configure parsing for prefix and compiler flag" ~: "failed" ~: +-- (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), [])) +-- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"]) +-- | (name, comp) <- m], +-- +-- TestLabel "find the package tool" $ TestList +-- ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~: +-- (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), [])) +-- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, +-- "--with-compiler=/foo/comp", "configure"]) +-- | (name, comp) <- m], +-- +-- TestLabel "simpler commands" $ TestList +-- [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag]) +-- | (flag, flagCmd) <- [("build", BuildCmd), +-- ("install", InstallCmd Nothing False), +-- ("sdist", SDistCmd), +-- ("register", RegisterCmd False)] +-- ] +-- ] + +{- Testing ideas: + * IO to look for hugs and hugs-pkg (which hugs, etc) + * quickCheck to test permutations of arguments + * what other options can we over-ride with a command-line flag? +-} diff --git a/cabal/Cabal/Distribution/Simple/SrcDist.hs b/cabal/Cabal/Distribution/Simple/SrcDist.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/SrcDist.hs @@ -0,0 +1,441 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.SrcDist +-- Copyright : Simon Marlow 2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This handles the @sdist@ command. The module exports an 'sdist' action but +-- also some of the phases that make it up so that other tools can use just the +-- bits they need. In particular the preparation of the tree of files to go +-- into the source tarball is separated from actually building the source +-- tarball. +-- +-- The 'createArchive' action uses the external @tar@ program and assumes that +-- 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. + +module Distribution.Simple.SrcDist ( + -- * The top level action + sdist, + + -- ** Parts of 'sdist' + printPackageProblems, + prepareTree, + createArchive, + + -- ** Snaphots + prepareSnapshotTree, + snapshotPackage, + snapshotVersion, + dateToSnapshotNumber, + ) where + +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) + , TestSuite(..), TestSuiteInterface(..), Benchmark(..) + , BenchmarkInterface(..) ) +import Distribution.PackageDescription.Check + ( PackageCheck(..), checkConfiguredPackage, checkPackageFiles ) +import Distribution.Package + ( PackageIdentifier(pkgVersion), Package(..), packageVersion ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Version + ( Version(versionBranch) ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File + , installOrdinaryFile, installOrdinaryFiles, setFileExecutable + , findFile, findFileWithExtension, matchFileGlob + , withTempDirectory, defaultPackageDesc + , die, warn, notice, setupMessage ) +import Distribution.Simple.Setup (SDistFlags(..), fromFlag, flagToMaybe) +import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessComponent) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), withComponentsLBI ) +import Distribution.Simple.BuildPaths ( autogenModuleName ) +import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram, + rawSystemProgram, tarProgram ) +import Distribution.Text + ( display ) + +import Control.Monad(when, unless) +import Data.Char (toLower) +import Data.List (partition, isPrefixOf) +import Data.Maybe (isNothing, catMaybes) +import System.Time (getClockTime, toCalendarTime, CalendarTime(..)) +import System.Directory + ( doesFileExist, Permissions(executable), getPermissions ) +import Distribution.Verbosity (Verbosity) +import System.FilePath + ( (), (<.>), takeDirectory, dropExtension, isAbsolute ) + +-- |Create a source distribution. +sdist :: PackageDescription -- ^information from the tarball + -> Maybe LocalBuildInfo -- ^Information from configure + -> SDistFlags -- ^verbosity & snapshot + -> (FilePath -> FilePath) -- ^build prefix (temp dir) + -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) + -> IO () +sdist pkg mb_lbi flags mkTmpDir pps = do + + -- do some QA + printPackageProblems verbosity pkg + + when (isNothing mb_lbi) $ + warn verbosity "Cannot run preprocessors. Run 'configure' command first." + + date <- toCalendarTime =<< getClockTime + let pkg' | snapshot = snapshotPackage date pkg + | otherwise = pkg + + case flagToMaybe (sDistDirectory flags) of + Just targetDir -> do + generateSourceDir targetDir pkg' + notice verbosity $ "Source directory created: " ++ targetDir + + Nothing -> do + createDirectoryIfMissingVerbose verbosity True tmpTargetDir + withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + let targetDir = tmpDir tarBallName pkg' + generateSourceDir targetDir pkg' + targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref + notice verbosity $ "Source tarball created: " ++ targzFile + + where + generateSourceDir targetDir pkg' = do + + setupMessage verbosity "Building source dist for" (packageId pkg') + prepareTree verbosity pkg' mb_lbi distPref targetDir pps + when snapshot $ + overwriteSnapshotPackageDesc verbosity pkg' targetDir + + verbosity = fromFlag (sDistVerbosity flags) + snapshot = fromFlag (sDistSnapshot flags) + + distPref = fromFlag $ sDistDistPref flags + targetPref = distPref + tmpTargetDir = mkTmpDir distPref + + +-- |Prepare a directory tree of source files. +prepareTree :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> Maybe LocalBuildInfo + -> FilePath -- ^dist dir + -> FilePath -- ^source tree to populate + -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) + -> IO () +prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do + createDirectoryIfMissingVerbose verbosity True targetDir + + -- maybe move the library files into place + withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } -> + prepareDir verbosity pkg_descr distPref targetDir pps modules libBi + + -- move the executables into place + withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do + prepareDir verbosity pkg_descr distPref targetDir pps [] exeBi + srcMainFile <- do + ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) (dropExtension mainPath) + case ppFile of + Nothing -> findFile (hsSourceDirs exeBi) mainPath + Just pp -> return pp + copyFileTo verbosity targetDir srcMainFile + + -- move the test suites into place + withTest $ \t -> do + let bi = testBuildInfo t + prep = prepareDir verbosity pkg_descr distPref targetDir pps + case testInterface t of + TestSuiteExeV10 _ mainPath -> do + prep [] bi + srcMainFile <- do + ppFile <- findFileWithExtension (ppSuffixes pps) + (hsSourceDirs bi) + (dropExtension mainPath) + case ppFile of + Nothing -> findFile (hsSourceDirs bi) mainPath + Just pp -> return pp + copyFileTo verbosity targetDir srcMainFile + TestSuiteLibV09 _ m -> do + prep [m] bi + TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " ++ show tp + + -- move the benchmarks into place + withBenchmark $ \bm -> do + let bi = benchmarkBuildInfo bm + prep = prepareDir verbosity pkg_descr distPref targetDir pps + case benchmarkInterface bm of + BenchmarkExeV10 _ mainPath -> do + prep [] bi + srcMainFile <- do + ppFile <- findFileWithExtension (ppSuffixes pps) + (hsSourceDirs bi) + (dropExtension mainPath) + case ppFile of + Nothing -> findFile (hsSourceDirs bi) mainPath + Just pp -> return pp + copyFileTo verbosity targetDir srcMainFile + BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: " ++ show tp + + flip mapM_ (dataFiles pkg_descr) $ \ filename -> do + files <- matchFileGlob (dataDir pkg_descr filename) + let dir = takeDirectory (dataDir pkg_descr filename) + createDirectoryIfMissingVerbose verbosity True (targetDir dir) + sequence_ [ installOrdinaryFile verbosity file (targetDir file) + | file <- files ] + + when (not (null (licenseFile pkg_descr))) $ + copyFileTo verbosity targetDir (licenseFile pkg_descr) + flip mapM_ (extraSrcFiles pkg_descr) $ \ fpath -> do + files <- matchFileGlob fpath + sequence_ + [ do copyFileTo verbosity targetDir file + -- preserve executable bit on extra-src-files like ./configure + perms <- getPermissions file + when (executable perms) --only checks user x bit + (setFileExecutable (targetDir file)) + | file <- files ] + + -- copy the install-include files + withLib $ \ l -> do + let lbi = libBuildInfo l + relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) + incs <- mapM (findInc relincdirs) (installIncludes lbi) + flip mapM_ incs $ \(_,fpath) -> + copyFileTo verbosity targetDir fpath + + -- 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 + let lbi' = lbi{ buildDir = targetDir buildDir lbi } + withComponentsLBI pkg_descr lbi' $ \c _ -> + preprocessComponent pkg_descr c lbi' True verbosity pps + _ -> return () + + -- setup isn't listed in the description file. + hsExists <- doesFileExist "Setup.hs" + lhsExists <- doesFileExist "Setup.lhs" + if hsExists then copyFileTo verbosity targetDir "Setup.hs" + else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs" + else writeUTF8File (targetDir "Setup.hs") $ unlines [ + "import Distribution.Simple", + "main = defaultMain"] + -- the description file itself + descFile <- defaultPackageDesc verbosity + installOrdinaryFile verbosity descFile (targetDir descFile) + + where + pkg_descr = mapAllBuildInfo filterAutogenModule pkg_descr0 + filterAutogenModule bi = bi { + otherModules = filter (/=autogenModule) (otherModules bi) + } + autogenModule = autogenModuleName pkg_descr0 + + findInc [] f = die ("can't find include file " ++ f) + findInc (d:ds) f = do + let path = (d f) + b <- doesFileExist path + if b then return (f,path) else findInc ds f + + -- We have to deal with all libs and executables, so we have local + -- versions of these functions that ignore the 'buildable' attribute: + withLib action = maybe (return ()) action (library pkg_descr) + withExe action = mapM_ action (executables pkg_descr) + withTest action = mapM_ action (testSuites pkg_descr) + withBenchmark action = mapM_ action (benchmarks pkg_descr) + +-- | Prepare a directory tree of source files for a snapshot version. +-- It is expected that the appropriate snapshot version has already been set +-- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. +-- +prepareSnapshotTree :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> Maybe LocalBuildInfo + -> FilePath -- ^dist dir + -> FilePath -- ^source tree to populate + -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) + -> IO () +prepareSnapshotTree verbosity pkg mb_lbi distPref targetDir pps = do + prepareTree verbosity pkg mb_lbi distPref targetDir pps + overwriteSnapshotPackageDesc verbosity pkg targetDir + +overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> FilePath -- ^source tree + -> IO () +overwriteSnapshotPackageDesc verbosity pkg targetDir = do + -- We could just writePackageDescription targetDescFile pkg_descr, + -- but that would lose comments and formatting. + descFile <- defaultPackageDesc verbosity + withUTF8FileContents descFile $ + writeUTF8File (targetDir descFile) + . unlines . map (replaceVersion (packageVersion pkg)) . lines + + where + replaceVersion :: Version -> String -> String + replaceVersion version line + | "version:" `isPrefixOf` map toLower line + = "version: " ++ display version + | otherwise = line + +-- | Modifies a 'PackageDescription' by appending a snapshot number +-- corresponding to the given date. +-- +snapshotPackage :: CalendarTime -> PackageDescription -> PackageDescription +snapshotPackage date pkg = + pkg { + package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) } + } + where pkgid = packageId pkg + +-- | Modifies a 'Version' by appending a snapshot number corresponding +-- to the given date. +-- +snapshotVersion :: CalendarTime -> Version -> Version +snapshotVersion date version = version { + versionBranch = versionBranch version + ++ [dateToSnapshotNumber date] + } + +-- | Given a date produce a corresponding integer representation. +-- For example given a date @18/03/2008@ produce the number @20080318@. +-- +dateToSnapshotNumber :: CalendarTime -> Int +dateToSnapshotNumber date = year * 10000 + + month * 100 + + day + where + year = ctYear date + month = fromEnum (ctMonth date) + 1 + day = ctDay date + +-- |Create an archive from a tree of source files, and clean up the tree. +createArchive :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from cabal file + -> Maybe LocalBuildInfo -- ^info from configure + -> FilePath -- ^source tree to archive + -> FilePath -- ^name of archive to create + -> IO FilePath + +createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do + let tarBallFilePath = targetPref tarBallName pkg_descr <.> "tar.gz" + + (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] + return tarBallFilePath + +-- |Move the sources into place based on buildInfo +prepareDir :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> FilePath -- ^dist dir + -> FilePath -- ^TargetPrefix + -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) + -> [ModuleName] -- ^Exposed modules + -> BuildInfo + -> IO () +prepareDir verbosity _pkg _distPref inPref pps modules bi + = do let searchDirs = hsSourceDirs bi + sources <- sequence + [ let file = ModuleName.toFilePath module_ + in findFileWithExtension suffixes searchDirs file + >>= maybe (notFound module_) return + | module_ <- modules ++ otherModules bi ] + bootFiles <- sequence + [ let file = ModuleName.toFilePath module_ + fileExts = ["hs-boot", "lhs-boot"] + in findFileWithExtension fileExts (hsSourceDirs bi) file + | module_ <- modules ++ otherModules bi ] + + let allSources = sources ++ catMaybes bootFiles ++ cSources bi + installOrdinaryFiles verbosity inPref (zip (repeat []) allSources) + + where suffixes = ppSuffixes pps ++ ["hs", "lhs"] + notFound m = die $ "Error: Could not find module: " ++ display m + ++ " with any suffix: " ++ show suffixes + +copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () +copyFileTo verbosity dir file = do + let targetFile = dir file + createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) + installOrdinaryFile verbosity file targetFile + +printPackageProblems :: Verbosity -> PackageDescription -> IO () +printPackageProblems verbosity pkg_descr = do + ioChecks <- checkPackageFiles pkg_descr "." + let pureChecks = checkConfiguredPackage pkg_descr + isDistError (PackageDistSuspicious _) = False + isDistError _ = True + (errors, warnings) = partition isDistError (pureChecks ++ ioChecks) + unless (null errors) $ + notice verbosity $ "Distribution quality errors:\n" + ++ unlines (map explanation errors) + unless (null warnings) $ + notice verbosity $ "Distribution quality warnings:\n" + ++ unlines (map explanation warnings) + unless (null errors) $ + notice verbosity + "Note: the public hackage server would reject this package." + +------------------------------------------------------------ + +-- | The name of the tarball without extension +-- +tarBallName :: PackageDescription -> String +tarBallName = display . packageId + +mapAllBuildInfo :: (BuildInfo -> BuildInfo) + -> (PackageDescription -> PackageDescription) +mapAllBuildInfo f pkg = pkg { + library = fmap mapLibBi (library pkg), + executables = fmap mapExeBi (executables pkg), + testSuites = fmap mapTestBi (testSuites pkg), + benchmarks = fmap mapBenchBi (benchmarks pkg) + } + where + mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) } + mapExeBi exe = exe { buildInfo = f (buildInfo exe) } + mapTestBi t = t { testBuildInfo = f (testBuildInfo t) } + mapBenchBi bm = bm { benchmarkBuildInfo = f (benchmarkBuildInfo bm) } diff --git a/cabal/Cabal/Distribution/Simple/Test.hs b/cabal/Cabal/Distribution/Simple/Test.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Test.hs @@ -0,0 +1,544 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Test +-- Copyright : Thomas Tuegel 2010 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into testing a built package. It performs the +-- \"@.\/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.InstallDirs + ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) + , substPathTemplate , toPathTemplate, PathTemplate ) +import qualified Distribution.Simple.LocalBuildInfo as LBI + ( LocalBuildInfo(..) ) +import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag ) +import Distribution.Simple.Utils ( die, notice ) +import Distribution.TestSuite + ( OptionDescr(..), Options, Progress(..), Result(..), TestInstance(..) + , Test(..) ) +import Distribution.Text +import Distribution.Verbosity ( normal, Verbosity ) +import Distribution.System ( buildPlatform, 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 ) +import System.Environment ( getEnvironment ) +import System.Exit ( ExitCode(..), exitFailure, exitWith ) +import System.FilePath ( (), (<.>) ) +import System.IO ( hClose, IOMode(..), openFile ) +import System.Process ( runProcess, waitForProcess ) + +-- | 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 = buildPlatform + , 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 = Just $ (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 runProcess + proc <- runProcess cmd opts Nothing shellEnv + (Just hIn) (Just hLog) (Just hLog) + waitForProcess proc + + -- 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 + + +-- |Perform the \"@.\/setup test@\" action. +test :: 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 + let verbosity = fromFlag $ testVerbosity flags + humanTemplate = fromFlag $ testHumanLog flags + machineTemplate = fromFlag $ testMachineLog flags + distPref = fromFlag $ testDistPref flags + testLogDir = distPref "test" + testNames = fromFlag $ testList flags + 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 + 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.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 + + _ -> 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 = "" + } + + when (not $ PD.hasTests pkg_descr) $ do + notice verbosity "Package has no test suites." + exitWith ExitSuccess + + when (PD.hasTests pkg_descr && null enabledTests) $ + die $ "No test suites enabled. Did you remember to configure with " + ++ "\'--enable-tests\'?" + + testsToRun <- case testNames of + [] -> return $ zip enabledTests $ repeat Nothing + names -> flip mapM names $ \tName -> + let testMap = zip enabledNames enabledTests + enabledNames = map PD.testName enabledTests + allNames = map PD.testName pkgTests + in case lookup tName testMap of + Just t -> return (t, Nothing) + _ | tName `elem` allNames -> + die $ "Package configured with test suite " + ++ tName ++ " disabled." + | otherwise -> die $ "no such test: " ++ tName + + createDirectoryIfMissing True testLogDir + + -- Delete ordinary files from test log directory. + getDirectoryContents testLogDir + >>= filterM doesFileExist . map (testLogDir ) + >>= mapM_ removeFile + + let totalSuites = length testsToRun + notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." + suites <- mapM doTest testsToRun + let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites } + packageLogFile = () testLogDir + $ packageLogPath machineTemplate pkg_descr lbi + allOk <- summarizePackage verbosity packageLog + writeFile packageLogFile $ show packageLog + + 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) + ++ [ (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) ++ + [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)] + +packageLogPath :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> FilePath +packageLogPath template pkg_descr lbi = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (compilerId $ LBI.compiler 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 + tests >>= stubRunTests >>= stubWriteLog f n + +-- | 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 + diff --git a/cabal/Cabal/Distribution/Simple/UHC.hs b/cabal/Cabal/Distribution/Simple/UHC.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/UHC.hs @@ -0,0 +1,300 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.UHC +-- Copyright : Andres Loeh 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains most of the UHC-specific code for configuring, building +-- and installing packages. +-- +-- Thanks to the authors of the other implementation-specific files, in +-- 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 + ) where + +import Control.Monad +import Data.List +import Distribution.Compat.ReadP +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler as C +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Text +import Distribution.Verbosity +import Distribution.Version +import Language.Haskell.Extension +import System.Directory +import System.FilePath + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (_uhcProg, uhcVersion, conf') <- + requireProgramVersion verbosity uhcProgram + (orLaterVersion (Version [1,0,2] [])) + (userMaybeSpecifyPath "uhc" hcPath conf) + + let comp = Compiler { + compilerId = CompilerId UHC uhcVersion, + compilerLanguages = uhcLanguages, + compilerExtensions = uhcLanguageExtensions + } + return (comp, conf') + +uhcLanguages :: [(Language, C.Flag)] +uhcLanguages = [(Haskell98, "")] + +-- | The flags for the supported extensions. +uhcLanguageExtensions :: [(Extension, C.Flag)] +uhcLanguageExtensions = + let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), + (DisableExtension f, disable)] + alwaysOn = ("", ""{- wrong -}) + in concatMap doFlag + [(CPP, ("--cpp", ""{- wrong -})), + (PolymorphicComponents, alwaysOn), + (ExistentialQuantification, alwaysOn), + (ForeignFunctionInterface, alwaysOn), + (UndecidableInstances, alwaysOn), + (MultiParamTypeClasses, alwaysOn), + (Rank2Types, alwaysOn), + (PatternSignatures, alwaysOn), + (EmptyDataDecls, alwaysOn), + (ImplicitPrelude, ("", "--no-prelude"{- wrong -})), + (TypeOperators, alwaysOn), + (OverlappingInstances, alwaysOn), + (FlexibleInstances, alwaysOn)] + +getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity comp packagedbs conf = do + let compilerid = compilerId comp + systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram conf ["--meta-pkgdir-system"] + userPkgDir <- getUserPackageDir + let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) + -- putStrLn $ "pkgdirs: " ++ show pkgDirs + -- call to "lines" necessary, because pkgdir contains an extra newline at the end + pkgs <- liftM (map addBuiltinVersions . concat) . + mapM (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d)) . + concatMap lines $ pkgDirs + -- putStrLn $ "pkgs: " ++ show pkgs + let iPkgs = + map mkInstalledPackageInfo $ + concatMap parsePackage $ + pkgs + -- putStrLn $ "installed pkgs: " ++ show iPkgs + return (fromList iPkgs) + +getUserPackageDir :: IO FilePath +getUserPackageDir = + do + homeDir <- getHomeDirectory + return $ homeDir ".cabal" "lib" -- TODO: determine in some other way + +packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] +packageDbPaths user system db = + case db of + GlobalPackageDB -> [ system ] + UserPackageDB -> [ user ] + SpecificPackageDB path -> [ path ] + +-- | Hack to add version numbers to UHC-builtin packages. This should sooner or +-- later be fixed on the UHC side. +addBuiltinVersions :: String -> String +{- +addBuiltinVersions "uhcbase" = "uhcbase-1.0" +addBuiltinVersions "base" = "base-3.0" +addBuiltinVersions "array" = "array-0.2" +-} +addBuiltinVersions xs = xs + +-- | Name of the installed package config file. +installedPkgConfig :: String +installedPkgConfig = "installed-pkg-config" + +-- | Check if a certain dir contains a valid package. Currently, we are +-- looking only for the presence of an installed package configuration. +-- TODO: Actually make use of the information provided in the file. +isPkgDir :: String -> String -> String -> IO Bool +isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . +isPkgDir c dir xs = do + let candidate = dir uhcPackageDir xs c + -- putStrLn $ "trying: " ++ candidate + doesFileExist (candidate installedPkgConfig) + +parsePackage :: String -> [PackageId] +parsePackage x = map fst (filter (\ (_,y) -> null y) (readP_to_S parse x)) + +-- | Create a trivial package info from a directory name. +mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo +mkInstalledPackageInfo p = emptyInstalledPackageInfo + { installedPackageId = InstalledPackageId (display p), + sourcePackageId = p } + + +-- ----------------------------------------------------------------------------- +-- Building + +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + + systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] + userPkgDir <- getUserPackageDir + let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) + let uhcArgs = -- set package name + ["--pkg-build=" ++ display (packageId pkg_descr)] + -- common flags lib/exe + ++ constructUHCCmdLine userPkgDir systemPkgDir + lbi (libBuildInfo lib) clbi + (buildDir lbi) verbosity + -- source files + -- suboptimal: UHC does not understand module names, so + -- we replace periods by path separators + ++ map (map (\ c -> if c == '.' then pathSeparator else c)) + (map display (libModules lib)) + + runUhcProg uhcArgs + + return () + +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi exe clbi = do + systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] + userPkgDir <- getUserPackageDir + let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) + let uhcArgs = -- common flags lib/exe + constructUHCCmdLine userPkgDir systemPkgDir + lbi (buildInfo exe) clbi + (buildDir lbi) verbosity + -- output file + ++ ["--output", buildDir lbi exeName exe] + -- main source module + ++ [modulePath exe] + runUhcProg uhcArgs + +constructUHCCmdLine :: FilePath -> FilePath + -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> Verbosity -> [String] +constructUHCCmdLine user system lbi bi clbi odir verbosity = + -- verbosity + (if verbosity >= deafening then ["-v4"] + else if verbosity >= normal then [] + else ["-v0"]) + ++ hcOptions UHC bi + -- flags for language extensions + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + -- packages + ++ ["--hide-all-packages"] + ++ uhcPackageDbOptions user system (withPackageDB lbi) + ++ ["--package=uhcbase"] + ++ ["--package=" ++ display (pkgName pkgid) | (_, pkgid) <- componentPackageDeps clbi ] + -- search paths + ++ ["-i" ++ odir] + ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ autogenModulesDir lbi] + -- output path + ++ ["--odir=" ++ odir] + -- optimization + ++ (case withOptimization lbi of + NoOptimisation -> ["-O0"] + NormalOptimisation -> ["-O1"] + MaximumOptimisation -> ["-O2"]) + +uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] +uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x) + (concatMap (packageDbPaths user system) db) + +-- ----------------------------------------------------------------------------- +-- Installation + +installLib :: Verbosity -> LocalBuildInfo + -> FilePath -> FilePath -> FilePath + -> PackageDescription -> Library -> IO () +installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library = do + -- putStrLn $ "dest: " ++ targetDir + -- putStrLn $ "built: " ++ builtDir + installDirectoryContents verbosity (builtDir display (packageId pkg)) targetDir + +-- currently hardcoded UHC code generator and variant to use +uhcTarget, uhcTargetVariant :: String +uhcTarget = "bc" +uhcTargetVariant = "plain" + +-- root directory for a package in UHC +uhcPackageDir :: String -> String -> FilePath +uhcPackageSubDir :: String -> FilePath +uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid +uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do + let installDirs = absoluteInstallDirs pkg lbi NoCopyDest + pkgdir | inplace = buildDir lbi uhcPackageDir (display pkgid) (display compilerid) + | otherwise = libdir installDirs uhcPackageSubDir (display compilerid) + createDirectoryIfMissingVerbose verbosity True pkgdir + writeUTF8File (pkgdir installedPkgConfig) + (showInstalledPackageInfo installedPkgInfo) + where + pkgid = packageId pkg + compilerid = compilerId (compiler lbi) diff --git a/cabal/Cabal/Distribution/Simple/UserHooks.hs b/cabal/Cabal/Distribution/Simple/UserHooks.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/UserHooks.hs @@ -0,0 +1,231 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.UserHooks +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines the API that @Setup.hs@ scripts can use to customise the way +-- the build works. This module just defines the 'UserHooks' type. The +-- predefined sets of hooks that implement the @Simple@, @Make@ and @Configure@ +-- build systems are defined in "Distribution.Simple". The 'UserHooks' is a big +-- record of functions. There are 3 for each action, a pre, post and the action +-- itself. There are few other miscellaneous hooks, ones to extend the set of +-- programs and preprocessors and one to override the function used to read the +-- @.cabal@ file. +-- +-- This hooks type is widely agreed to not be the right solution. Partly this +-- is because changes to it usually break custom @Setup.hs@ files and yet many +-- internal code changes do require changes to the hooks. For example we cannot +-- pass any extra parameters to most of the functions that implement the +-- 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, + ) where + +import Distribution.PackageDescription + (PackageDescription, GenericPackageDescription, + HookedBuildInfo, emptyHookedBuildInfo) +import Distribution.Simple.Program (Program) +import Distribution.Simple.Command (noExtraFlags) +import Distribution.Simple.PreProcess (PPSuffixHandler) +import Distribution.Simple.Setup + (ConfigFlags, BuildFlags, CleanFlags, CopyFlags, + InstallFlags, SDistFlags, RegisterFlags, HscolourFlags, + HaddockFlags, TestFlags, BenchmarkFlags) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) + +type Args = [String] + +-- | Hooks allow authors to add specific functionality before and after a +-- command is run, and also to specify additional preprocessors. +-- +-- * WARNING: The hooks interface is under rather constant flux as we try to +-- understand users needs. Setup files that depend on this interface may +-- break in future releases. +data UserHooks = UserHooks { + + -- | Used for @.\/setup test@ + runTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO (), + -- | Read the description file + readDesc :: IO (Maybe GenericPackageDescription), + -- | Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. + hookedPreProcessors :: [ PPSuffixHandler ], + -- | These programs are detected at configure time. Arguments for them are + -- added to the configure command. + hookedPrograms :: [Program], + + -- |Hook to run before configure command + preConf :: Args -> ConfigFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during configure. + confHook :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags -> IO LocalBuildInfo, + -- |Hook to run after configure command + postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |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. + buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (), + -- |Hook to run after build command. Second arg indicates verbosity level. + postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before clean command. Second arg indicates verbosity level. + preClean :: Args -> CleanFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during clean. + cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO (), + -- |Hook to run after clean command. Second arg indicates verbosity level. + postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO (), + + -- |Hook to run before copy command + preCopy :: Args -> CopyFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during copy. + copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (), + -- |Hook to run after copy command + postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before install command + preInst :: Args -> InstallFlags -> IO HookedBuildInfo, + + -- |Over-ride this hook to get different behavior during install. + instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (), + -- |Hook to run after install command. postInst should be run + -- on the target, not on the build machine. + postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before sdist command. Second arg indicates verbosity level. + preSDist :: Args -> SDistFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during sdist. + sDistHook :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO (), + -- |Hook to run after sdist command. Second arg indicates verbosity level. + postSDist :: Args -> SDistFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO (), + + -- |Hook to run before register command + preReg :: Args -> RegisterFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during registration. + regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), + -- |Hook to run after register command + postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before unregister command + preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during registration. + unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), + -- |Hook to run after unregister command + postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before hscolour command. Second arg indicates verbosity level. + preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during hscolour. + hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (), + -- |Hook to run after hscolour command. Second arg indicates verbosity level. + postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before haddock command. Second arg indicates verbosity level. + preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during haddock. + haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (), + -- |Hook to run after haddock command. Second arg indicates verbosity level. + postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |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 (), + -- |Hook to run after test command. + postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before bench command. + preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during bench. + benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO (), + -- |Hook to run after bench command. + postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO () + } + +{-# DEPRECATED runTests "Please use the new testing interface instead!" #-} + +-- |Empty 'UserHooks' which do nothing. +emptyUserHooks :: UserHooks +emptyUserHooks + = UserHooks { + runTests = ru, + readDesc = return Nothing, + hookedPreProcessors = [], + hookedPrograms = [], + preConf = rn, + confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")), + postConf = ru, + preBuild = rn, + buildHook = ru, + postBuild = ru, + preClean = rn, + cleanHook = ru, + postClean = ru, + preCopy = rn, + copyHook = ru, + postCopy = ru, + preInst = rn, + instHook = ru, + postInst = ru, + preSDist = rn, + sDistHook = ru, + postSDist = ru, + preReg = rn, + regHook = ru, + postReg = ru, + preUnreg = rn, + unregHook = ru, + postUnreg = ru, + preHscolour = rn, + hscolourHook = ru, + postHscolour = ru, + preHaddock = rn, + haddockHook = ru, + postHaddock = ru, + preTest = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without + -- noExtraFlags + testHook = ru, + postTest = ru, + preBench = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without + -- noExtraFlags + benchHook = \_ -> ru, + postBench = ru + } + where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo + ru _ _ _ _ = return () diff --git a/cabal/Cabal/Distribution/Simple/Utils.hs b/cabal/Cabal/Distribution/Simple/Utils.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Utils.hs @@ -0,0 +1,1140 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Utils +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- portions Copyright (c) 2007, Galois Inc. +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A large and somewhat miscellaneous collection of utility functions used +-- throughout the rest of the Cabal lib and in other tools that use the Cabal +-- lib like @cabal-install@. It has a very simple set of logging actions. It +-- 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, + + -- * logging and errors + die, + dieWithLocation, + topHandler, + warn, notice, setupMessage, info, debug, + chattyTry, + + -- * running programs + rawSystemExit, + rawSystemExitCode, + rawSystemExitWithEnv, + rawSystemStdout, + rawSystemStdInOut, + maybeExit, + xargs, + findProgramLocation, + findProgramVersion, + + -- * copying files + smartCopySources, + createDirectoryIfMissingVerbose, + copyFileVerbose, + copyDirectoryRecursiveVerbose, + copyFiles, + + -- * installing files + installOrdinaryFile, + installExecutableFile, + installOrdinaryFiles, + installDirectoryContents, + + -- * File permissions + setFileOrdinary, + setFileExecutable, + + -- * file names + currentDir, + + -- * finding files + findFile, + findFirstFile, + findFileWithExtension, + findFileWithExtension', + findModuleFile, + findModuleFiles, + getDirectoryContentsRecursive, + + -- * simple file globbing + matchFileGlob, + matchDirFileGlob, + parseFileGlob, + FileGlob(..), + + -- * temp files and dirs + withTempFile, + withTempDirectory, + + -- * .cabal and .buildinfo files + defaultPackageDesc, + findPackageDesc, + defaultHookedPackageDesc, + findHookedPackageDesc, + + -- * reading and writing files safely + withFileContents, + writeFileAtomic, + rewriteFile, + + -- * Unicode + fromUTF8, + toUTF8, + readUTF8File, + withUTF8FileContents, + writeUTF8File, + normaliseLineEndings, + + -- * generic utils + equating, + comparing, + isInfixOf, + intercalate, + lowercase, + wrapText, + wrapLine, + ) where + +import Control.Monad + ( when, unless, filterM ) +#ifdef __GLASGOW_HASKELL__ +import Control.Concurrent.MVar + ( newEmptyMVar, putMVar, takeMVar ) +#endif +import Data.List + ( nub, unfoldr, isPrefixOf, tails, intersperse ) +import Data.Char as Char + ( toLower, chr, ord ) +import Data.Bits + ( Bits((.|.), (.&.), shiftL, shiftR) ) +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 + +import System.Directory + ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile + , findExecutable ) +import System.Environment + ( getProgName ) +import System.Cmd + ( rawSystem ) +import System.Exit + ( exitWith, ExitCode(..) ) +import System.FilePath + ( normalise, (), (<.>), takeDirectory, splitFileName + , splitExtension, splitExtensions, splitDirectories ) +import System.Directory + ( createDirectory, renameFile, removeDirectoryRecursive ) +import System.IO + ( Handle, openFile, openBinaryFile, openBinaryTempFile + , IOMode(ReadMode), hSetBinaryMode + , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) +import System.IO.Error as IO.Error + ( isDoesNotExistError, isAlreadyExistsError + , ioeSetFileName, ioeGetFileName, ioeGetErrorString ) +#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)) +import System.IO.Error + ( ioeSetLocation, ioeGetLocation ) +#endif +import System.IO.Unsafe + ( unsafeInterleaveIO ) +import qualified Control.Exception as Exception + +import Distribution.Text + ( display, simpleParse ) +import Distribution.Package + ( PackageIdentifier ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Version + (Version(..)) + +import Control.Exception (evaluate) +import System.Process (runProcess) + +#ifdef __GLASGOW_HASKELL__ +import Control.Concurrent (forkIO) +import System.Process (runInteractiveProcess, waitForProcess) +#else +import System.Cmd (system) +import System.Directory (getTemporaryDirectory) +#endif + +import Distribution.Compat.CopyFile + ( copyFile, copyOrdinaryFile, copyExecutableFile + , setFileOrdinary, setFileExecutable, setDirOrdinary ) +import Distribution.Compat.TempFile + ( openTempFile, createTempDirectory ) +import Distribution.Compat.Exception + ( IOException, throwIOIO, tryIO, catchIO, catchExit ) +import Distribution.Verbosity + +#ifdef VERSION_base +import qualified Paths_Cabal (version) +#endif + +-- We only get our own version number when we're building with ourselves +cabalVersion :: Version +#if defined(VERSION_base) +cabalVersion = Paths_Cabal.version +#elif defined(CABAL_VERSION) +cabalVersion = Version [CABAL_VERSION] [] +#else +cabalVersion = Version [1,9999] [] --used when bootstrapping +#endif + +-- ---------------------------------------------------------------------------- +-- Exception and logging utils + +dieWithLocation :: FilePath -> Maybe Int -> String -> IO a +dieWithLocation filename lineno msg = + ioError . setLocation lineno + . flip ioeSetFileName (normalise filename) + $ userError msg + where +#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608) + setLocation _ err = err +#else + setLocation Nothing err = err + setLocation (Just n) err = ioeSetLocation err (show n) +#endif + +die :: String -> IO a +die msg = ioError (userError msg) + +topHandler :: IO a -> IO a +topHandler prog = catchIO prog handle + where + handle ioe = do + hFlush stdout + pname <- getProgName + hPutStr stderr (mesage pname) + exitWith (ExitFailure 1) + where + mesage pname = wrapText (pname ++ ": " ++ file ++ detail) + file = case ioeGetFileName ioe of + Nothing -> "" + Just path -> path ++ location ++ ": " +#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608) + location = "" +#else + location = case ioeGetLocation ioe of + l@(n:_) | n >= '0' && n <= '9' -> ':' : l + _ -> "" +#endif + detail = ioeGetErrorString ioe + +-- | Non fatal conditions that may be indicative of an error or problem. +-- +-- We display these at the 'normal' verbosity level. +-- +warn :: Verbosity -> String -> IO () +warn verbosity msg = + when (verbosity >= normal) $ do + hFlush stdout + hPutStr stderr (wrapText ("Warning: " ++ msg)) + +-- | Useful status messages. +-- +-- We display these at the 'normal' verbosity level. +-- +-- This is for the ordinary helpful status messages that users see. Just +-- enough information to know that things are working but not floods of detail. +-- +notice :: Verbosity -> String -> IO () +notice verbosity msg = + when (verbosity >= normal) $ + putStr (wrapText msg) + +setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () +setupMessage verbosity msg pkgid = + notice verbosity (msg ++ ' ': display pkgid ++ "...") + +-- | More detail on the operation of some action. +-- +-- We display these messages when the verbosity level is 'verbose' +-- +info :: Verbosity -> String -> IO () +info verbosity msg = + when (verbosity >= verbose) $ + putStr (wrapText msg) + +-- | Detailed internal debugging information +-- +-- We display these messages when the verbosity level is 'deafening' +-- +debug :: Verbosity -> String -> IO () +debug verbosity msg = + when (verbosity >= deafening) $ do + putStr (wrapText msg) + hFlush stdout + +-- | Perform an IO action, catching any IO exceptions and printing an error +-- if one occurs. +chattyTry :: String -- ^ a description of the action we were attempting + -> IO () -- ^ the action itself + -> IO () +chattyTry desc action = + catchIO action $ \exception -> + putStrLn $ "Error while " ++ desc ++ ": " ++ show exception + +-- ----------------------------------------------------------------------------- +-- Helper functions + +-- | Wraps text to the default line width. Existing newlines are preserved. +wrapText :: String -> String +wrapText = unlines + . concatMap (map unwords + . wrapLine 79 + . words) + . lines + +-- | Wraps a list of words to a list of lines of words of a particular width. +wrapLine :: Int -> [String] -> [[String]] +wrapLine width = wrap 0 [] + where wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w:ws) + | length w + 1 > width + = wrap (length w) [w] ws + wrap col line (w:ws) + | col + length w + 1 > width + = reverse line : wrap 0 [] (w:ws) + wrap col line (w:ws) + = let col' = col + length w + 1 + in wrap col' (w:line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +-- ----------------------------------------------------------------------------- +-- rawSystem variants +maybeExit :: IO ExitCode -> IO () +maybeExit cmd = do + res <- cmd + unless (res == ExitSuccess) $ exitWith res + +printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () +printRawCommandAndArgs verbosity path args + | verbosity >= deafening = print (path, args) + | verbosity >= verbose = putStrLn $ unwords (path : args) + | otherwise = return () + +printRawCommandAndArgsAndEnv :: Verbosity + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +printRawCommandAndArgsAndEnv verbosity path args env + | verbosity >= deafening = do putStrLn ("Environment: " ++ show env) + print (path, args) + | verbosity >= verbose = putStrLn $ unwords (path : args) + | otherwise = return () + +-- Exit with the same exitcode if the subcommand fails +rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () +rawSystemExit verbosity path args = do + printRawCommandAndArgs verbosity path args + hFlush stdout + exitcode <- rawSystem path args + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + exitWith exitcode + +rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode +rawSystemExitCode verbosity path args = do + printRawCommandAndArgs verbosity path args + hFlush stdout + exitcode <- rawSystem path args + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + return exitcode + +rawSystemExitWithEnv :: Verbosity + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +rawSystemExitWithEnv verbosity path args env = do + printRawCommandAndArgsAndEnv verbosity path args env + hFlush stdout + ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing + exitcode <- waitForProcess ph + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + exitWith exitcode + +-- | Run a command and return its output. +-- +-- The output is assumed to be text in the locale encoding. +-- +rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String +rawSystemStdout verbosity path args = do + (output, errors, exitCode) <- rawSystemStdInOut verbosity path args + Nothing False + when (exitCode /= ExitSuccess) $ + die errors + return output + +-- | Run a command and return its output, errors and exit status. Optionally +-- also supply some input. Also provides control over whether the binary/text +-- mode of the input and output. +-- +rawSystemStdInOut :: Verbosity + -> FilePath -> [String] + -> Maybe (String, Bool) -- ^ input text and binary mode + -> Bool -- ^ output in binary mode + -> IO (String, String, ExitCode) -- ^ output, errors, exit +rawSystemStdInOut verbosity path args input outputBinary = do + printRawCommandAndArgs verbosity path args + +#ifdef __GLASGOW_HASKELL__ + Exception.bracket + (runInteractiveProcess path args Nothing Nothing) + (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) + $ \(inh,outh,errh,pid) -> do + + -- output mode depends on what the caller wants + hSetBinaryMode outh outputBinary + -- but the errors are always assumed to be text (in the current locale) + hSetBinaryMode errh False + + -- fork off a couple threads to pull on the stderr and stdout + -- so if the process writes to stderr we do not block. + + err <- hGetContents errh + out <- hGetContents outh + + mv <- newEmptyMVar + let force str = (evaluate (length str) >> return ()) + `Exception.finally` putMVar mv () + --TODO: handle exceptions like text decoding. + _ <- forkIO $ force out + _ <- forkIO $ force err + + -- push all the input, if any + case input of + Nothing -> return () + Just (inputStr, inputBinary) -> do + -- input mode depends on what the caller wants + hSetBinaryMode inh inputBinary + hPutStr inh inputStr + hClose inh + --TODO: this probably fails if the process refuses to consume + -- or if it closes stdin (eg if it exits) + + -- wait for both to finish, in either order + takeMVar mv + takeMVar mv + + -- wait for the program to terminate + exitcode <- waitForProcess pid + unless (exitcode == ExitSuccess) $ + debug verbosity $ path ++ " returned " ++ show exitcode + ++ if null err then "" else + " with error message:\n" ++ err + + return (out, err, exitcode) +#else + tmpDir <- getTemporaryDirectory + withTempFile tmpDir ".cmd.stdout" $ \outName outHandle -> + withTempFile tmpDir ".cmd.stdin" $ \inName inHandle -> do + hClose outHandle + + case input of + Nothing -> return () + Just (inputStr, inputBinary) -> do + hSetBinaryMode inHandle inputBinary + hPutStr inHandle inputStr + hClose inHandle + + let quote name = "'" ++ name ++ "'" + cmd = unwords (map quote (path:args)) + ++ " <" ++ quote inName + ++ " >" ++ quote outName + exitcode <- system cmd + + unless (exitcode == ExitSuccess) $ + debug verbosity $ path ++ " returned " ++ show exitcode + + Exception.bracket (openFile outName ReadMode) hClose $ \hnd -> do + hSetBinaryMode hnd outputBinary + output <- hGetContents hnd + length output `seq` return (output, "", exitcode) +#endif + + +-- | Look for a program on the path. +findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath) +findProgramLocation verbosity prog = do + debug verbosity $ "searching for " ++ prog ++ " in path." + res <- findExecutable prog + case res of + Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") + Just path -> debug verbosity ("found " ++ prog ++ " at "++ path) + return res + + +-- | Look for a program and try to find it's version number. It can accept +-- either an absolute path or the name of a program binary, in which case we +-- will look for the program on the path. +-- +findProgramVersion :: String -- ^ version args + -> (String -> String) -- ^ function to select version + -- number from program output + -> Verbosity + -> FilePath -- ^ location + -> IO (Maybe Version) +findProgramVersion versionArg selectVersion verbosity path = do + str <- rawSystemStdout verbosity path [versionArg] + `catchIO` (\_ -> return "") + `catchExit` (\_ -> return "") + let version :: Maybe Version + version = simpleParse (selectVersion str) + case version of + Nothing -> warn verbosity $ "cannot determine version of " ++ path + ++ " :\n" ++ show str + Just v -> debug verbosity $ path ++ " is version " ++ display v + return version + + +-- | 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. +-- +-- Use it with either of the rawSystem variants above. For example: +-- +-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs +-- +xargs :: Int -> ([String] -> IO ()) + -> [String] -> [String] -> IO () +xargs maxSize rawSystemFun fixedArgs bigArgs = + let fixedArgSize = sum (map length fixedArgs) + length fixedArgs + chunkSize = maxSize - fixedArgSize + in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) + + where chunks len = unfoldr $ \s -> + if null s then Nothing + else Just (chunk [] len s) + + chunk acc _ [] = (reverse acc,[]) + chunk acc len (s:ss) + | len' < len = chunk (s:acc) (len-len'-1) ss + | otherwise = (reverse acc, s:ss) + where len' = length s + +-- ------------------------------------------------------------ +-- * File Utilities +-- ------------------------------------------------------------ + +---------------- +-- Finding files + +-- | Find a file by looking in a search path. The file path must match exactly. +-- +findFile :: [FilePath] -- ^search locations + -> FilePath -- ^File Name + -> IO FilePath +findFile searchPath fileName = + findFirstFile id + [ path fileName + | path <- nub searchPath] + >>= maybe (die $ fileName ++ " doesn't exist") return + +-- | Find a file by looking in a search path with one of a list of possible +-- file extensions. The file base name should be given and it will be tried +-- with each of the extensions in each element of the search path. +-- +findFileWithExtension :: [String] + -> [FilePath] + -> FilePath + -> IO (Maybe FilePath) +findFileWithExtension extensions searchPath baseName = + findFirstFile 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. +-- +findFileWithExtension' :: [String] + -> [FilePath] + -> FilePath + -> IO (Maybe (FilePath, FilePath)) +findFileWithExtension' extensions searchPath baseName = + findFirstFile (uncurry ()) + [ (path, baseName <.> ext) + | path <- nub searchPath + , ext <- nub extensions ] + +findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) +findFirstFile file = findFirst + where findFirst [] = return Nothing + findFirst (x:xs) = do exists <- doesFileExist (file x) + if exists + then return (Just x) + else findFirst xs + +-- | Finds the files corresponding to a list of Haskell module names. +-- +-- As 'findModuleFile' but for a list of module names. +-- +findModuleFiles :: [FilePath] -- ^ build prefix (location of objects) + -> [String] -- ^ search suffixes + -> [ModuleName] -- ^ modules + -> IO [(FilePath, FilePath)] +findModuleFiles searchPath extensions moduleNames = + mapM (findModuleFile searchPath extensions) moduleNames + +-- | Find the file corresponding to a Haskell module name. +-- +-- This is similar to 'findFileWithExtension'' but specialised to a module +-- name. The function fails if the file corresponding to the module is missing. +-- +findModuleFile :: [FilePath] -- ^ build prefix (location of objects) + -> [String] -- ^ search suffixes + -> ModuleName -- ^ module + -> IO (FilePath, FilePath) +findModuleFile searchPath extensions moduleName = + maybe notFound return + =<< findFileWithExtension' extensions searchPath + (ModuleName.toFilePath moduleName) + where + notFound = die $ "Error: Could not find module: " ++ display moduleName + ++ " with any suffix: " ++ show extensions + ++ " in the search path: " ++ show searchPath + +-- | List all the files in a directory and all subdirectories. +-- +-- The order places files in sub-directories after all the files in their +-- parent directories. The list is generated lazily so is not well defined if +-- the source directory structure changes before the list is used. +-- +getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive topdir = recurseDirectories [""] + where + recurseDirectories :: [FilePath] -> IO [FilePath] + recurseDirectories [] = return [] + recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) + files' <- recurseDirectories (dirs' ++ dirs) + return (files ++ files') + + where + collect files dirs' [] = return (reverse files, reverse dirs') + collect files dirs' (entry:entries) | ignore entry + = collect files dirs' entries + collect files dirs' (entry:entries) = do + let dirEntry = dir entry + isDirectory <- doesDirectoryExist (topdir dirEntry) + if isDirectory + then collect files (dirEntry:dirs') entries + else collect (dirEntry:files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + +---------------- +-- File globbing + +data FileGlob + -- | No glob at all, just an ordinary file + = NoGlob FilePath + + -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to + -- @FileGlob \"foo\/bar\" \".baz\"@ + | FileGlob FilePath String + +parseFileGlob :: FilePath -> Maybe FileGlob +parseFileGlob filepath = case splitExtensions filepath of + (filepath', ext) -> case splitFileName filepath' of + (dir, "*") | '*' `elem` dir + || '*' `elem` ext + || null ext -> Nothing + | null dir -> Just (FileGlob "." ext) + | otherwise -> Just (FileGlob dir ext) + _ | '*' `elem` filepath -> Nothing + | otherwise -> Just (NoGlob filepath) + +matchFileGlob :: FilePath -> IO [FilePath] +matchFileGlob = matchDirFileGlob "." + +matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath] +matchDirFileGlob dir filepath = case parseFileGlob filepath of + Nothing -> die $ "invalid file glob '" ++ filepath + ++ "'. Wildcards '*' are only allowed in place of the file" + ++ " name, not in the directory name or file extension." + ++ " If a wildcard is used it must be with an file extension." + Just (NoGlob filepath') -> return [filepath'] + Just (FileGlob dir' ext) -> do + files <- getDirectoryContents (dir dir') + case [ dir' file + | file <- files + , let (name, ext') = splitExtensions file + , not (null name) && ext' == ext ] of + [] -> die $ "filepath wildcard '" ++ filepath + ++ "' does not match any files." + matches -> return matches + +---------------------------------------- +-- Copying and installing files and dirs + +-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. +-- +createDirectoryIfMissingVerbose :: Verbosity + -> Bool -- ^ Create its parents too? + -> FilePath + -> IO () +createDirectoryIfMissingVerbose verbosity create_parents path0 + | create_parents = createDirs (parents path0) + | otherwise = createDirs (take 1 (parents path0)) + where + parents = reverse . scanl1 () . splitDirectories . normalise + + createDirs [] = return () + createDirs (dir:[]) = createDir dir throwIOIO + createDirs (dir:dirs) = + createDir dir $ \_ -> do + createDirs dirs + createDir dir throwIOIO + + createDir :: FilePath -> (IOException -> IO ()) -> IO () + createDir dir notExistHandler = do + r <- tryIO $ createDirectoryVerbose verbosity dir + case (r :: Either IOException ()) of + Right () -> return () + Left e + | isDoesNotExistError e -> notExistHandler e + -- 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 + -- 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. + | isAlreadyExistsError e -> (do + isDir <- doesDirectoryExist dir + if isDir then return () + else throwIOIO e + ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) + | otherwise -> throwIOIO e + +createDirectoryVerbose :: Verbosity -> FilePath -> IO () +createDirectoryVerbose verbosity dir = do + info verbosity $ "creating " ++ dir + createDirectory dir + setDirOrdinary dir + +-- | Copies a file without copying file permissions. The target file is created +-- with default permissions. Any existing target file is replaced. +-- +-- At higher verbosity levels it logs an info message. +-- +copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyFileVerbose verbosity src dest = do + info verbosity ("copy " ++ src ++ " to " ++ dest) + copyFile src dest + +-- | Install an ordinary file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" +-- while on Windows it uses the default permissions for the target directory. +-- +installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () +installOrdinaryFile verbosity src dest = do + info verbosity ("Installing " ++ src ++ " to " ++ dest) + copyOrdinaryFile src dest + +-- | Install an executable file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" +-- while on Windows it uses the default permissions for the target directory. +-- +installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () +installExecutableFile verbosity src dest = do + info verbosity ("Installing executable " ++ src ++ " to " ++ dest) + copyExecutableFile src dest + +-- | Copies a bunch of files to a target directory, preserving the directory +-- structure in the target location. The target directories are created if they +-- do not exist. +-- +-- The files are identified by a pair of base directory and a path relative to +-- that base. It is only the relative part that is preserved in the +-- destination. +-- +-- For example: +-- +-- > copyFiles normal "dist/src" +-- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] +-- +-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and +-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". +-- +-- This operation is not atomic. Any IO failure during the copy (including any +-- missing source files) leaves the target in an unknown state so it is best to +-- use it with a freshly created directory so that it can be simply deleted if +-- anything goes wrong. +-- +copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +copyFiles verbosity targetDir srcFiles = do + + -- Create parent directories for everything + let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles + mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs + + -- Copy all the files + sequence_ [ let src = srcBase srcFile + dest = targetDir srcFile + in copyFileVerbose verbosity src dest + | (srcBase, srcFile) <- srcFiles ] + +-- | This is like 'copyFiles' but uses 'installOrdinaryFile'. +-- +installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +installOrdinaryFiles verbosity targetDir srcFiles = do + + -- Create parent directories for everything + let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles + mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs + + -- Copy all the files + sequence_ [ let src = srcBase srcFile + dest = targetDir srcFile + in installOrdinaryFile verbosity src dest + | (srcBase, srcFile) <- srcFiles ] + +-- | This installs all the files in a directory to a target location, +-- preserving the directory layout. All the files are assumed to be ordinary +-- rather than executable files. +-- +installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () +installDirectoryContents verbosity srcDir destDir = do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] + +--------------------------------- +-- Deprecated file copy functions + +{-# DEPRECATED smartCopySources + "Use findModuleFiles and copyFiles or installOrdinaryFiles" #-} +smartCopySources :: Verbosity -> [FilePath] -> FilePath + -> [ModuleName] -> [String] -> IO () +smartCopySources verbosity searchPath targetDir moduleNames extensions = + findModuleFiles searchPath extensions moduleNames + >>= copyFiles verbosity targetDir + +{-# DEPRECATED copyDirectoryRecursiveVerbose + "You probably want installDirectoryContents instead" #-} +copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyDirectoryRecursiveVerbose verbosity srcDir destDir = do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] + +--------------------------- +-- Temporary files and dirs + +-- | Use a temporary filename that doesn't already exist. +-- +withTempFile :: FilePath -- ^ Temp dir to create the file in + -> String -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> IO a) -> IO a +withTempFile tmpDir template action = + Exception.bracket + (openTempFile tmpDir template) + (\(name, handle) -> hClose handle >> removeFile name) + (uncurry action) + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +-- +withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a +withTempDirectory _verbosity targetDir template = + Exception.bracket + (createTempDirectory targetDir template) + (removeDirectoryRecursive) + +----------------------------------- +-- Safely reading and writing files + +-- | Gets the contents of a file, but guarantee that it gets closed. +-- +-- The file is read lazily but if it is not fully consumed by the action then +-- the remaining input is truncated and the file is closed. +-- +withFileContents :: FilePath -> (String -> IO a) -> IO a +withFileContents name action = + Exception.bracket (openFile name ReadMode) hClose + (\hnd -> hGetContents hnd >>= action) + +-- | Writes a file atomically. +-- +-- The file is either written sucessfully 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. +-- This case will give an IO exception but the atomic property is not affected. +-- +writeFileAtomic :: FilePath -> BS.ByteString -> IO () +writeFileAtomic targetPath content = do + let (targetDir, targetFile) = splitFileName targetPath + Exception.bracketOnError + (openBinaryTempFile targetDir $ targetFile <.> "tmp") + (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) + (\(tmpPath, handle) -> do + BS.hPut handle content + hClose handle + renameFile tmpPath targetPath) + +-- | Write a file but only if it would have new content. If we would be writing +-- the same as the existing content then leave the file as is so that we do not +-- update the file's modification time. +-- +rewriteFile :: FilePath -> String -> IO () +rewriteFile path newContent = + flip catchIO mightNotExist $ do + existingContent <- readFile path + _ <- evaluate (length existingContent) + unless (existingContent == newContent) $ + writeFileAtomic path (BS.Char8.pack newContent) + where + mightNotExist e | isDoesNotExistError e = writeFileAtomic path + (BS.Char8.pack newContent) + | otherwise = ioError e + +-- | The path name that represents the current directory. +-- In Unix, it's @\".\"@, but this is system-specific. +-- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) +currentDir :: FilePath +currentDir = "." + +-- ------------------------------------------------------------ +-- * Finding the description file +-- ------------------------------------------------------------ + +-- |Package description file (/pkgname/@.cabal@) +defaultPackageDesc :: Verbosity -> IO FilePath +defaultPackageDesc _verbosity = findPackageDesc currentDir + +-- |Find a package description file in the given directory. Looks for +-- @.cabal@ files. +findPackageDesc :: FilePath -- ^Where to look + -> IO FilePath -- ^.cabal +findPackageDesc dir + = do files <- getDirectoryContents dir + -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal + -- file we filter to exclude dirs and null base file names: + cabalFiles <- filterM doesFileExist + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == ".cabal" ] + case cabalFiles of + [] -> noDesc + [cabalFile] -> return cabalFile + multiple -> multiDesc multiple + + where + noDesc :: IO a + noDesc = die $ "No cabal file found.\n" + ++ "Please create a package description file .cabal" + + multiDesc :: [String] -> IO a + multiDesc l = die $ "Multiple cabal files found.\n" + ++ "Please use only one of: " + ++ intercalate ", " l + +-- |Optional auxiliary package information file (/pkgname/@.buildinfo@) +defaultHookedPackageDesc :: IO (Maybe FilePath) +defaultHookedPackageDesc = findHookedPackageDesc currentDir + +-- |Find auxiliary package information in the given directory. +-- Looks for @.buildinfo@ files. +findHookedPackageDesc + :: FilePath -- ^Directory to search + -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present +findHookedPackageDesc dir = do + files <- getDirectoryContents dir + buildInfoFiles <- filterM doesFileExist + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == buildInfoExt ] + case buildInfoFiles of + [] -> return Nothing + [f] -> return (Just f) + _ -> die ("Multiple files with extension " ++ buildInfoExt) + +buildInfoExt :: String +buildInfoExt = ".buildinfo" + +-- ------------------------------------------------------------ +-- * Unicode stuff +-- ------------------------------------------------------------ + +-- This is a modification of the UTF8 code from gtk2hs and the +-- utf8-string package. + +fromUTF8 :: String -> String +fromUTF8 [] = [] +fromUTF8 (c:cs) + | c <= '\x7F' = c : fromUTF8 cs + | c <= '\xBF' = replacementChar : fromUTF8 cs + | c <= '\xDF' = twoBytes c cs + | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF) + | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7) + | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3) + | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1) + | otherwise = replacementChar : fromUTF8 cs + where + twoBytes c0 (c1:cs') + | ord c1 .&. 0xC0 == 0x80 + = let d = ((ord c0 .&. 0x1F) `shiftL` 6) + .|. (ord c1 .&. 0x3F) + in if d >= 0x80 + then chr d : fromUTF8 cs' + else replacementChar : fromUTF8 cs' + twoBytes _ cs' = replacementChar : fromUTF8 cs' + + moreBytes :: Int -> Int -> [Char] -> Int -> [Char] + moreBytes 1 overlong cs' acc + | overlong <= acc && acc <= 0x10FFFF + && (acc < 0xD800 || 0xDFFF < acc) + && (acc < 0xFFFE || 0xFFFF < acc) + = chr acc : fromUTF8 cs' + + | otherwise + = replacementChar : fromUTF8 cs' + + moreBytes byteCount overlong (cn:cs') acc + | ord cn .&. 0xC0 == 0x80 + = moreBytes (byteCount-1) overlong cs' + ((acc `shiftL` 6) .|. ord cn .&. 0x3F) + + moreBytes _ _ cs' _ + = replacementChar : fromUTF8 cs' + + replacementChar = '\xfffd' + +toUTF8 :: String -> String +toUTF8 [] = [] +toUTF8 (c:cs) + | c <= '\x07F' = c + : toUTF8 cs + | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6)) + : chr (0x80 .|. (w .&. 0x3F)) + : toUTF8 cs + | c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12)) + : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) + : chr (0x80 .|. (w .&. 0x3F)) + : toUTF8 cs + | otherwise = chr (0xf0 .|. (w `shiftR` 18)) + : chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F)) + : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) + : chr (0x80 .|. (w .&. 0x3F)) + : toUTF8 cs + where w = ord c + +-- | Ignore a Unicode byte order mark (BOM) at the beginning of the input +-- +ignoreBOM :: String -> String +ignoreBOM ('\xFEFF':string) = string +ignoreBOM string = string + +-- | Reads a UTF8 encoded text file as a Unicode String +-- +-- Reads lazily using ordinary 'readFile'. +-- +readUTF8File :: FilePath -> IO String +readUTF8File f = fmap (ignoreBOM . fromUTF8) + . hGetContents =<< openBinaryFile f ReadMode + +-- | Reads a UTF8 encoded text file as a Unicode String +-- +-- Same behaviour as 'withFileContents'. +-- +withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a +withUTF8FileContents name action = + Exception.bracket + (openBinaryFile name ReadMode) + hClose + (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8) + +-- | Writes a Unicode String as a UTF8 encoded text file. +-- +-- Uses 'writeFileAtomic', so provides the same guarantees. +-- +writeUTF8File :: FilePath -> String -> IO () +writeUTF8File path = writeFileAtomic path . BS.Char8.pack . toUTF8 + +-- | Fix different systems silly line ending conventions +normaliseLineEndings :: String -> String +normaliseLineEndings [] = [] +normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows +normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old osx +normaliseLineEndings ( c :s) = c : normaliseLineEndings s + +-- ------------------------------------------------------------ +-- * Common utils +-- ------------------------------------------------------------ + +equating :: Eq a => (b -> a) -> b -> b -> Bool +equating p x y = p x == p y + +comparing :: Ord a => (b -> a) -> b -> b -> Ordering +comparing p x y = p x `compare` p y + +isInfixOf :: String -> String -> Bool +isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) + +intercalate :: [a] -> [[a]] -> [a] +intercalate sep = concat . intersperse sep + +lowercase :: String -> String +lowercase = map Char.toLower diff --git a/cabal/Cabal/Distribution/System.hs b/cabal/Cabal/Distribution/System.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/System.hs @@ -0,0 +1,179 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.System +-- Copyright : Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Cabal often needs to do slightly different things on specific platforms. You +-- probably know about the 'System.Info.os' however using that is very +-- inconvenient because it is a string and different Haskell implementations +-- do not agree on using the same strings for the same platforms! (In +-- particular see the controversy over \"windows\" vs \"ming32\"). So to make it +-- more consistent and easy to use we have an 'OS' enumeration. +-- +module Distribution.System ( + -- * Operating System + OS(..), + buildOS, + + -- * Machine Architecture + Arch(..), + buildArch, + + -- * Platform is a pair of arch and OS + Platform(..), + buildPlatform, + ) where + +import qualified System.Info (os, arch) +import qualified Data.Char as Char (toLower, isAlphaNum) + +import Distribution.Text (Text(..), display) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>)) + +-- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. +-- +-- 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 +-- 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. +-- +-- 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 +-- which enables us to warn about such deprecated aliases. +-- +data ClassificationStrictness = Permissive | Compat | Strict + +-- ------------------------------------------------------------ +-- * Operating System +-- ------------------------------------------------------------ + +data OS = Linux | Windows | OSX -- teir 1 desktop OSs + | FreeBSD | OpenBSD | NetBSD -- other free unix OSs + | Solaris | AIX | HPUX | IRIX -- ageing Unix OSs + | HaLVM -- bare metal / VMs / hypervisors + | OtherOS String + deriving (Eq, Ord, Show, Read) + +--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? + +knownOSs :: [OS] +knownOSs = [Linux, Windows, OSX + ,FreeBSD, OpenBSD, NetBSD + ,Solaris, AIX, HPUX, IRIX + ,HaLVM] + +osAliases :: ClassificationStrictness -> OS -> [String] +osAliases Permissive Windows = ["mingw32", "cygwin32"] +osAliases Compat Windows = ["mingw32", "win32"] +osAliases _ OSX = ["darwin"] +osAliases Permissive FreeBSD = ["kfreebsdgnu"] +osAliases Permissive Solaris = ["solaris2"] +osAliases _ _ = [] + +instance Text OS where + disp (OtherOS name) = Disp.text name + disp other = Disp.text (lowercase (show other)) + + parse = fmap (classifyOS Compat) ident + +classifyOS :: ClassificationStrictness -> String -> OS +classifyOS strictness s = + case lookup (lowercase s) osMap of + Just os -> os + Nothing -> OtherOS s + where + osMap = [ (name, os) + | os <- knownOSs + , name <- display os : osAliases strictness os ] + +buildOS :: OS +buildOS = classifyOS Permissive System.Info.os + +-- ------------------------------------------------------------ +-- * Machine Architecture +-- ------------------------------------------------------------ + +data Arch = I386 | X86_64 | PPC | PPC64 | Sparc + | Arm | Mips | SH + | IA64 | S390 + | Alpha | Hppa | Rs6000 + | M68k | Vax + | OtherArch String + deriving (Eq, Ord, Show, Read) + +knownArches :: [Arch] +knownArches = [I386, X86_64, PPC, PPC64, Sparc + ,Arm, Mips, SH + ,IA64, S390 + ,Alpha, Hppa, Rs6000 + ,M68k, Vax] + +archAliases :: ClassificationStrictness -> Arch -> [String] +archAliases Strict _ = [] +archAliases Compat _ = [] +archAliases _ PPC = ["powerpc"] +archAliases _ PPC64 = ["powerpc64"] +archAliases _ Sparc = ["sparc64", "sun4"] +archAliases _ Mips = ["mipsel", "mipseb"] +archAliases _ Arm = ["armeb", "armel"] +archAliases _ _ = [] + +instance Text Arch where + disp (OtherArch name) = Disp.text name + disp other = Disp.text (lowercase (show other)) + + parse = fmap (classifyArch Strict) ident + +classifyArch :: ClassificationStrictness -> String -> Arch +classifyArch strictness s = + case lookup (lowercase s) archMap of + Just arch -> arch + Nothing -> OtherArch s + where + archMap = [ (name, arch) + | arch <- knownArches + , name <- display arch : archAliases strictness arch ] + +buildArch :: Arch +buildArch = classifyArch Permissive System.Info.arch + +-- ------------------------------------------------------------ +-- * Platform +-- ------------------------------------------------------------ + +data Platform = Platform Arch OS + deriving (Eq, Ord, Show, Read) + +instance Text Platform where + disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os + parse = do + arch <- parse + _ <- Parse.char '-' + os <- parse + return (Platform arch os) + +buildPlatform :: Platform +buildPlatform = Platform buildArch buildOS + +-- Utils: + +ident :: Parse.ReadP r String +ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') + --TODO: probably should disallow starting with a number + +lowercase :: String -> String +lowercase = map Char.toLower diff --git a/cabal/Cabal/Distribution/TestSuite.hs b/cabal/Cabal/Distribution/TestSuite.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/TestSuite.hs @@ -0,0 +1,125 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.TestSuite +-- Copyright : Thomas Tuegel 2010 +-- +-- 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(..) + , OptionDescr(..) + , OptionType(..) + , Test(..) + , Options + , Progress(..) + , Result(..) + , testGroup + ) where + +data TestInstance = TestInstance + { run :: IO Progress -- ^ Perform the test. + , name :: String -- ^ A name for the test, unique within a + -- test suite. + , tags :: [String] -- ^ Users can select groups of tests by + -- their tags. + , options :: [OptionDescr] -- ^ Descriptions of the options recognized + -- by this test. + , setOption :: String -> String -> Either String TestInstance + -- ^ Try to set the named option to the given value. Returns an error + -- message if the option is not supported or the value could not be + -- correctly parsed; otherwise, a 'TestInstance' with the option set to + -- the given value is returned. + } + +data OptionDescr = OptionDescr + { optionName :: String + , optionDescription :: String -- ^ A human-readable description of the + -- option to guide the user setting it. + , optionType :: OptionType + , optionDefault :: Maybe String + } + deriving (Eq, Read, Show) + +data OptionType + = OptionFile + { optionFileMustExist :: Bool + , optionFileIsDir :: Bool + , optionFileExtensions :: [String] + } + | OptionString + { optionStringMultiline :: Bool + } + | OptionNumber + { optionNumberIsInt :: Bool + , optionNumberBounds :: (Maybe String, Maybe String) + } + | OptionBool + | OptionEnum [String] + | OptionSet [String] + | OptionRngSeed + deriving (Eq, Read, Show) + +data Test + = Test TestInstance + | Group + { groupName :: String + , concurrently :: Bool + -- ^ If true, then children of this group may be run in parallel. + -- Note that this setting is not inherited by children. In + -- particular, consider a group F with "concurrently = False" that + -- has some children, including a group T with "concurrently = + -- True". The children of group T may be run concurrently with each + -- other, as long as none are run at the same time as any of the + -- direct children of group F. + , groupTests :: [Test] + } + | ExtraOptions [OptionDescr] Test + +type Options = [(String, String)] + +data Progress = Finished Result + | Progress String (IO Progress) + +data Result = Pass + | Fail String + | Error String + deriving (Eq, Read, Show) + +-- | Create a named group of tests, which are assumed to be safe to run in +-- parallel. +testGroup :: String -> [Test] -> Test +testGroup n ts = Group { groupName = n, concurrently = True, groupTests = ts } diff --git a/cabal/Cabal/Distribution/Text.hs b/cabal/Cabal/Distribution/Text.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Text.hs @@ -0,0 +1,68 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Text +-- Copyright : Duncan Coutts 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines a 'Text' class which is a bit like the 'Read' and 'Show' +-- classes. The difference is that is uses a modern pretty printer and parser +-- system and the format is not expected to be Haskell concrete syntax but +-- rather the external human readable representation used by Cabal. +-- +module Distribution.Text ( + Text(..), + display, + simpleParse, + ) where + +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp + +import Data.Version (Version(Version)) +import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace) + +class Text a where + disp :: a -> Disp.Doc + parse :: Parse.ReadP r a + +display :: Text a => a -> String +display = Disp.renderStyle style . disp + where style = Disp.Style { + Disp.mode = Disp.PageMode, + Disp.lineLength = 79, + Disp.ribbonsPerLine = 1.0 + } + +simpleParse :: Text a => String -> Maybe a +simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str + , all Char.isSpace s ] of + [] -> Nothing + (p:_) -> Just p + +-- ----------------------------------------------------------------------------- +-- Instances for types from the base package + +instance Text Bool where + disp = Disp.text . show + parse = Parse.choice [ (Parse.string "True" Parse.+++ + Parse.string "true") >> return True + , (Parse.string "False" Parse.+++ + Parse.string "false") >> return False ] + +instance Text Version where + disp (Version branch _tags) -- Death to version tags!! + = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch)) + + 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? + where + digits = do + first <- Parse.satisfy Char.isDigit + if first == '0' + then return 0 + else do rest <- Parse.munch Char.isDigit + return (read (first : rest)) diff --git a/cabal/Cabal/Distribution/Verbosity.hs b/cabal/Cabal/Distribution/Verbosity.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Verbosity.hs @@ -0,0 +1,113 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Verbosity +-- Copyright : Ian Lynagh 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A simple 'Verbosity' type with associated utilities. There are 4 standard +-- verbosity levels from 'silent', 'normal', 'verbose' up to 'deafening'. This +-- is used for deciding what logging messages to print. + +-- 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. -} + +module Distribution.Verbosity ( + -- * Verbosity + Verbosity, + silent, normal, verbose, deafening, + moreVerbose, lessVerbose, + intToVerbosity, flagToVerbosity, + showForCabal, showForGHC + ) where + +import Data.List (elemIndex) +import Distribution.ReadE + +data Verbosity = Silent | Normal | Verbose | Deafening + deriving (Show, Read, Eq, Ord, Enum, Bounded) + +-- We shouldn't print /anything/ unless an error occurs in silent mode +silent :: Verbosity +silent = Silent + +-- Print stuff we want to see by default +normal :: Verbosity +normal = Normal + +-- Be more verbose about what's going on +verbose :: Verbosity +verbose = Verbose + +-- Not only are we verbose ourselves (perhaps even noisier than when +-- being "verbose"), but we tell everything we run to be verbose too +deafening :: Verbosity +deafening = Deafening + +moreVerbose :: Verbosity -> Verbosity +moreVerbose Silent = Silent --silent should stay silent +moreVerbose Normal = Verbose +moreVerbose Verbose = Deafening +moreVerbose Deafening = Deafening + +lessVerbose :: Verbosity -> Verbosity +lessVerbose Deafening = Deafening +lessVerbose Verbose = Normal +lessVerbose Normal = Silent +lessVerbose Silent = Silent + +intToVerbosity :: Int -> Maybe Verbosity +intToVerbosity 0 = Just Silent +intToVerbosity 1 = Just Normal +intToVerbosity 2 = Just Verbose +intToVerbosity 3 = Just Deafening +intToVerbosity _ = Nothing + +flagToVerbosity :: ReadE Verbosity +flagToVerbosity = ReadE $ \s -> + case reads s of + [(i, "")] -> + case intToVerbosity i of + Just v -> Right v + Nothing -> Left ("Bad verbosity: " ++ show i ++ + ". Valid values are 0..3") + _ -> Left ("Can't parse verbosity " ++ s) + +showForCabal, showForGHC :: Verbosity -> String + +showForCabal v = maybe (error "unknown verbosity") show $ + elemIndex v [silent,normal,verbose,deafening] +showForGHC v = maybe (error "unknown verbosity") show $ + elemIndex v [silent,normal,__,verbose,deafening] + where __ = silent -- this will be always ignored by elemIndex diff --git a/cabal/Cabal/Distribution/Version.hs b/cabal/Cabal/Distribution/Version.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Version.hs @@ -0,0 +1,744 @@ +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Version +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Exports the 'Version' type along with a parser and pretty printer. A version +-- 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(..), + + -- * Version ranges + VersionRange(..), + + -- ** Constructing + anyVersion, noVersion, + thisVersion, notThisVersion, + laterVersion, earlierVersion, + orLaterVersion, orEarlierVersion, + unionVersionRanges, intersectVersionRanges, + withinVersion, + betweenVersionsInclusive, + + -- ** Inspection + withinRange, + isAnyVersion, + isNoVersion, + isSpecificVersion, + simplifyVersionRange, + foldVersionRange, + foldVersionRange', + + -- * Version intervals view + asVersionIntervals, + VersionInterval, + LowerBound(..), + UpperBound(..), + Bound(..), + + -- ** 'VersionIntervals' abstract type + -- | The 'VersionIntervals' type and the accompanying functions are exposed + -- primarily for completeness and testing purposes. In practice + -- 'asVersionIntervals' is the main function to use to + -- view a 'VersionRange' as a bunch of 'VersionInterval's. + -- + VersionIntervals, + toVersionIntervals, + fromVersionIntervals, + withinIntervals, + versionIntervals, + mkVersionIntervals, + unionVersionIntervals, + intersectVersionIntervals, + + ) where + +import Data.Typeable ( Typeable ) +import Data.Version ( Version(..) ) + +import Distribution.Text ( Text(..) ) +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Compat.ReadP ((+++)) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>), (<+>)) +import qualified Data.Char as Char (isDigit) +import Control.Exception (assert) + +-- ----------------------------------------------------------------------------- +-- Version ranges + +-- Todo: maybe move this to Distribution.Package.Version? +-- (package-specific versioning scheme). + +data VersionRange + = AnyVersion + | ThisVersion Version -- = version + | LaterVersion Version -- > version (NB. not >=) + | EarlierVersion Version -- < version + | WildcardVersion Version -- == ver.* (same as >= ver && < ver+1) + | UnionVersionRanges VersionRange VersionRange + | IntersectVersionRanges VersionRange VersionRange + | VersionRangeParens VersionRange -- just '(exp)' parentheses syntax + deriving (Show,Read,Eq,Typeable) + +{-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED LaterVersion "use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED EarlierVersion "use 'earlierVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED WildcardVersion "use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED UnionVersionRanges "use 'unionVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED IntersectVersionRanges "use 'intersectVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} + +-- | The version range @-any@. That is, a version range containing all +-- versions. +-- +-- > withinRange v anyVersion = True +-- +anyVersion :: VersionRange +anyVersion = AnyVersion + +-- | The empty version range, that is a version range containing no versions. +-- +-- This can be constructed using any unsatisfiable version range expression, +-- for example @> 1 && < 1@. +-- +-- > withinRange v anyVersion = False +-- +noVersion :: VersionRange +noVersion = IntersectVersionRanges (LaterVersion v) (EarlierVersion v) + where v = Version [1] [] + +-- | The version range @== v@ +-- +-- > withinRange v' (thisVersion v) = v' == v +-- +thisVersion :: Version -> VersionRange +thisVersion = ThisVersion + +-- | The version range @< v || > v@ +-- +-- > withinRange v' (notThisVersion v) = v' /= v +-- +notThisVersion :: Version -> VersionRange +notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) + +-- | The version range @> v@ +-- +-- > withinRange v' (laterVersion v) = v' > v +-- +laterVersion :: Version -> VersionRange +laterVersion = LaterVersion + +-- | The version range @>= v@ +-- +-- > withinRange v' (orLaterVersion v) = v' >= v +-- +orLaterVersion :: Version -> VersionRange +orLaterVersion v = UnionVersionRanges (ThisVersion v) (LaterVersion v) + +-- | The version range @< v@ +-- +-- > withinRange v' (earlierVersion v) = v' < v +-- +earlierVersion :: Version -> VersionRange +earlierVersion = EarlierVersion + +-- | The version range @<= v@ +-- +-- > withinRange v' (orEarlierVersion v) = v' <= v +-- +orEarlierVersion :: Version -> VersionRange +orEarlierVersion v = UnionVersionRanges (ThisVersion v) (EarlierVersion v) + +-- | The version range @vr1 || vr2@ +-- +-- > withinRange v' (unionVersionRanges vr1 vr2) +-- > = withinRange v' vr1 || withinRange v' vr2 +-- +unionVersionRanges :: VersionRange -> VersionRange -> VersionRange +unionVersionRanges = UnionVersionRanges + +-- | The version range @vr1 && vr2@ +-- +-- > withinRange v' (intersectVersionRanges vr1 vr2) +-- > = withinRange v' vr1 && withinRange v' vr2 +-- +intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange +intersectVersionRanges = IntersectVersionRanges + +-- | The version range @== v.*@. +-- +-- For example, for version @1.2@, the version range @== 1.2.*@ is the same as +-- @>= 1.2 && < 1.3@ +-- +-- > withinRange v' (laterVersion v) = v' >= v && v' < upper v +-- > where +-- > upper (Version lower t) = Version (init lower ++ [last lower + 1]) t +-- +withinVersion :: Version -> VersionRange +withinVersion = WildcardVersion + +-- | The version range @>= v1 && <= v2@. +-- +-- In practice this is not very useful because we normally use inclusive lower +-- bounds and exclusive upper bounds. +-- +-- > withinRange v' (laterVersion v) = v' > v +-- +betweenVersionsInclusive :: Version -> Version -> VersionRange +betweenVersionsInclusive v1 v2 = + IntersectVersionRanges (orLaterVersion v1) (orEarlierVersion v2) + +{-# DEPRECATED betweenVersionsInclusive + "In practice this is not very useful because we normally use inclusive lower bounds and exclusive upper bounds" + #-} + +-- | Fold over the basic syntactic structure of a 'VersionRange'. +-- +-- This provides a syntacic view of the expression defining the version range. +-- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented +-- in terms of the other basic syntax. +-- +-- For a semantic view use 'asVersionIntervals'. +-- +foldVersionRange :: a -- ^ @\"-any\"@ version + -> (Version -> a) -- ^ @\"== v\"@ + -> (Version -> a) -- ^ @\"> v\"@ + -> (Version -> a) -- ^ @\"< v\"@ + -> (a -> a -> a) -- ^ @\"_ || _\"@ union + -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection + -> VersionRange -> a +foldVersionRange anyv this later earlier union intersect = fold + where + fold AnyVersion = anyv + fold (ThisVersion v) = this v + fold (LaterVersion v) = later v + fold (EarlierVersion v) = earlier v + fold (WildcardVersion v) = fold (wildcard v) + fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) + fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) + fold (VersionRangeParens v) = fold v + + wildcard v = intersectVersionRanges + (orLaterVersion v) + (earlierVersion (wildcardUpperBound v)) + +-- | An extended variant of 'foldVersionRange' that also provides a view of +-- in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented +-- explicitly rather than in terms of the other basic syntax. +-- +foldVersionRange' :: a -- ^ @\"-any\"@ version + -> (Version -> a) -- ^ @\"== v\"@ + -> (Version -> a) -- ^ @\"> v\"@ + -> (Version -> a) -- ^ @\"< v\"@ + -> (Version -> a) -- ^ @\">= v\"@ + -> (Version -> a) -- ^ @\"<= v\"@ + -> (Version -> Version -> a) -- ^ @\"== v.*\"@ wildcard. The + -- function is passed the + -- inclusive lower bound and the + -- exclusive upper bounds of the + -- range defined by the wildcard. + -> (a -> a -> a) -- ^ @\"_ || _\"@ union + -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection + -> (a -> a) -- ^ @\"(_)\"@ parentheses + -> VersionRange -> a +foldVersionRange' anyv this later earlier orLater orEarlier + wildcard union intersect parens = fold + where + fold AnyVersion = anyv + fold (ThisVersion v) = this v + fold (LaterVersion v) = later v + fold (EarlierVersion v) = earlier v + + fold (UnionVersionRanges (ThisVersion v) + (LaterVersion v')) | v==v' = orLater v + fold (UnionVersionRanges (LaterVersion v) + (ThisVersion v')) | v==v' = orLater v + fold (UnionVersionRanges (ThisVersion v) + (EarlierVersion v')) | v==v' = orEarlier v + fold (UnionVersionRanges (EarlierVersion v) + (ThisVersion v')) | v==v' = orEarlier v + + fold (WildcardVersion v) = wildcard v (wildcardUpperBound v) + fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) + fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) + fold (VersionRangeParens v) = parens (fold v) + + +-- | Does this version fall within the given range? +-- +-- This is the evaluation function for the 'VersionRange' type. +-- +withinRange :: Version -> VersionRange -> Bool +withinRange v = foldVersionRange + True + (\v' -> versionBranch v == versionBranch v') + (\v' -> versionBranch v > versionBranch v') + (\v' -> versionBranch v < versionBranch v') + (||) + (&&) + +-- | View a 'VersionRange' as a union of intervals. +-- +-- This provides a canonical view of the semantics of a 'VersionRange' as +-- opposed to the syntax of the expression used to define it. For the syntactic +-- view use 'foldVersionRange'. +-- +-- Each interval is non-empty. The sequence is in increasing order and no +-- intervals overlap or touch. Therefore only the first and last can be +-- unbounded. The sequence can be empty if the range is empty +-- (e.g. a range expression like @< 1 && > 2@). +-- +-- Other checks are trivial to implement using this view. For example: +-- +-- > isNoVersion vr | [] <- asVersionIntervals vr = True +-- > | otherwise = False +-- +-- > isSpecificVersion vr +-- > | [(LowerBound v InclusiveBound +-- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr +-- > , v == v' = Just v +-- > | otherwise = Nothing +-- +asVersionIntervals :: VersionRange -> [VersionInterval] +asVersionIntervals = versionIntervals . toVersionIntervals + +-- | Does this 'VersionRange' place any restriction on the 'Version' or is it +-- in fact equivalent to 'AnyVersion'. +-- +-- Note this is a semantic check, not simply a syntactic check. So for example +-- the following is @True@ (for all @v@). +-- +-- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v) +-- +isAnyVersion :: VersionRange -> Bool +isAnyVersion vr = case asVersionIntervals vr of + [(LowerBound v InclusiveBound, NoUpperBound)] | isVersion0 v -> True + _ -> False + +-- | This is the converse of 'isAnyVersion'. It check if the version range is +-- empty, if there is no possible version that satisfies the version range. +-- +-- For example this is @True@ (for all @v@): +-- +-- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v) +-- +isNoVersion :: VersionRange -> Bool +isNoVersion vr = case asVersionIntervals vr of + [] -> True + _ -> False + +-- | Is this version range in fact just a specific version? +-- +-- For example the version range @\">= 3 && <= 3\"@ contains only the version +-- @3@. +-- +isSpecificVersion :: VersionRange -> Maybe Version +isSpecificVersion vr = case asVersionIntervals vr of + [(LowerBound v InclusiveBound + ,UpperBound v' InclusiveBound)] + | v == v' -> Just v + _ -> Nothing + +-- | Simplify a 'VersionRange' expression. For non-empty version ranges +-- this produces a canonical form. Empty or inconsistent version ranges +-- are left as-is because that provides more information. +-- +-- If you need a canonical form use +-- @fromVersionIntervals . toVersionIntervals@ +-- +-- It satisfies the following properties: +-- +-- > withinRange v (simplifyVersionRange r) = withinRange v r +-- +-- > withinRange v r = withinRange v r' +-- > ==> simplifyVersionRange r = simplifyVersionRange r' +-- > || isNoVersion r +-- > || isNoVersion r' +-- +simplifyVersionRange :: VersionRange -> VersionRange +simplifyVersionRange vr + -- If the version range is inconsistent then we just return the + -- original since that has more information than ">1 && < 1", which + -- is the canonical inconsistent version range. + | null (versionIntervals vi) = vr + | otherwise = fromVersionIntervals vi + where + vi = toVersionIntervals vr + +---------------------------- +-- Wildcard range utilities +-- + +wildcardUpperBound :: Version -> Version +wildcardUpperBound (Version lowerBound ts) = (Version upperBound ts) + where + upperBound = init lowerBound ++ [last lowerBound + 1] + +isWildcardRange :: Version -> Version -> Bool +isWildcardRange (Version branch1 _) (Version branch2 _) = check branch1 branch2 + where check (n:[]) (m:[]) | n+1 == m = True + check (n:ns) (m:ms) | n == m = check ns ms + check _ _ = False + +------------------ +-- Intervals view +-- + +-- | A complementary representation of a 'VersionRange'. Instead of a boolean +-- version predicate it uses an increasing sequence of non-overlapping, +-- non-empty intervals. +-- +-- The key point is that this representation gives a canonical representation +-- for the semantics of 'VersionRange's. This makes it easier to check things +-- like whether a version range is empty, covers all versions, or requires a +-- certain minimum or maximum version. It also makes it easy to check equality +-- or containment. It also makes it easier to identify \'simple\' version +-- predicates for translation into foreign packaging systems that do not +-- support complex version range expressions. +-- +newtype VersionIntervals = VersionIntervals [VersionInterval] + deriving (Eq, Show) + +-- | Inspect the list of version intervals. +-- +versionIntervals :: VersionIntervals -> [VersionInterval] +versionIntervals (VersionIntervals is) = is + +type VersionInterval = (LowerBound, UpperBound) +data LowerBound = LowerBound Version !Bound deriving (Eq, Show) +data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show) +data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) + +minLowerBound :: LowerBound +minLowerBound = LowerBound (Version [0] []) InclusiveBound + +isVersion0 :: Version -> Bool +isVersion0 (Version [0] _) = True +isVersion0 _ = False + +instance Ord LowerBound where + LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of + LT -> True + EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound) + GT -> False + +instance Ord UpperBound where + _ <= NoUpperBound = True + NoUpperBound <= UpperBound _ _ = False + UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of + LT -> True + EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound) + GT -> False + +invariant :: VersionIntervals -> Bool +invariant (VersionIntervals intervals) = all validInterval intervals + && all doesNotTouch' adjacentIntervals + where + doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool + doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' + + adjacentIntervals :: [(VersionInterval, VersionInterval)] + adjacentIntervals + | null intervals = [] + | otherwise = zip intervals (tail intervals) + +checkInvariant :: VersionIntervals -> VersionIntervals +checkInvariant is = assert (invariant is) is + +-- | 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 +-- satisfied the function returns @Nothing@. +-- +mkVersionIntervals :: [VersionInterval] -> Maybe VersionIntervals +mkVersionIntervals intervals + | invariant (VersionIntervals intervals) = Just (VersionIntervals intervals) + | otherwise = Nothing + +validVersion :: Version -> Bool +validVersion (Version [] _) = False +validVersion (Version vs _) = all (>=0) vs + +validInterval :: (LowerBound, UpperBound) -> Bool +validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i + where + validLower (LowerBound v _) = validVersion v + validUpper NoUpperBound = True + validUpper (UpperBound v _) = validVersion v + +-- Check an interval is non-empty +-- +nonEmpty :: VersionInterval -> Bool +nonEmpty (_, NoUpperBound ) = True +nonEmpty (LowerBound l lb, UpperBound u ub) = + (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) + +-- Check an upper bound does not intersect, or even touch a lower bound: +-- +-- ---| or ---) but not ---] or ---) or ---] +-- |--- (--- (--- [--- [--- +-- +doesNotTouch :: UpperBound -> LowerBound -> Bool +doesNotTouch NoUpperBound _ = False +doesNotTouch (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) + +-- | Check an upper bound does not intersect a lower bound: +-- +-- ---| or ---) or ---] or ---) but not ---] +-- |--- (--- (--- [--- [--- +-- +doesNotIntersect :: UpperBound -> LowerBound -> Bool +doesNotIntersect NoUpperBound _ = False +doesNotIntersect (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) + +-- | Test if a version falls within the version intervals. +-- +-- It exists mostly for completeness and testing. It satisfies the following +-- properties: +-- +-- > withinIntervals v (toVersionIntervals vr) = withinRange v vr +-- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs) +-- +withinIntervals :: Version -> VersionIntervals -> Bool +withinIntervals v (VersionIntervals intervals) = any withinInterval intervals + where + withinInterval (lowerBound, upperBound) = withinLower lowerBound + && withinUpper upperBound + withinLower (LowerBound v' ExclusiveBound) = v' < v + withinLower (LowerBound v' InclusiveBound) = v' <= v + + withinUpper NoUpperBound = True + withinUpper (UpperBound v' ExclusiveBound) = v' > v + withinUpper (UpperBound v' InclusiveBound) = v' >= v + +-- | Convert a 'VersionRange' to a sequence of version intervals. +-- +toVersionIntervals :: VersionRange -> VersionIntervals +toVersionIntervals = foldVersionRange + ( chkIvl (minLowerBound, NoUpperBound)) + (\v -> chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)) + (\v -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound)) + (\v -> if isVersion0 v then VersionIntervals [] else + chkIvl (minLowerBound, UpperBound v ExclusiveBound)) + unionVersionIntervals + intersectVersionIntervals + where + chkIvl interval = checkInvariant (VersionIntervals [interval]) + +-- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression +-- representing the version intervals. +-- +fromVersionIntervals :: VersionIntervals -> VersionRange +fromVersionIntervals (VersionIntervals []) = noVersion +fromVersionIntervals (VersionIntervals intervals) = + foldr1 UnionVersionRanges [ interval l u | (l, u) <- intervals ] + + where + interval (LowerBound v InclusiveBound) + (UpperBound v' InclusiveBound) | v == v' + = ThisVersion v + interval (LowerBound v InclusiveBound) + (UpperBound v' ExclusiveBound) | isWildcardRange v v' + = WildcardVersion v + interval l u = lowerBound l `intersectVersionRanges'` upperBound u + + lowerBound (LowerBound v InclusiveBound) + | isVersion0 v = AnyVersion + | otherwise = orLaterVersion v + lowerBound (LowerBound v ExclusiveBound) = LaterVersion v + + upperBound NoUpperBound = AnyVersion + upperBound (UpperBound v InclusiveBound) = orEarlierVersion v + upperBound (UpperBound v ExclusiveBound) = EarlierVersion v + + intersectVersionRanges' vr AnyVersion = vr + intersectVersionRanges' AnyVersion vr = vr + intersectVersionRanges' vr vr' = IntersectVersionRanges vr vr' + +unionVersionIntervals :: VersionIntervals -> VersionIntervals + -> VersionIntervals +unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = + checkInvariant (VersionIntervals (union is0 is'0)) + where + union is [] = is + union [] is' = is' + union (i:is) (i':is') = case unionInterval i i' of + Left Nothing -> i : union is (i' :is') + Left (Just i'') -> union is (i'':is') + Right Nothing -> i' : union (i :is) is' + Right (Just i'') -> union (i'':is) is' + +unionInterval :: VersionInterval -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +unionInterval (lower , upper ) (lower', upper') + + -- Non-intersecting intervals with the left interval ending first + | upper `doesNotTouch` lower' = Left Nothing + + -- Non-intersecting intervals with the right interval first + | upper' `doesNotTouch` lower = Right Nothing + + -- Complete or partial overlap, with the left interval ending first + | upper <= upper' = lowerBound `seq` + Left (Just (lowerBound, upper')) + + -- Complete or partial overlap, with the left interval ending first + | otherwise = lowerBound `seq` + Right (Just (lowerBound, upper)) + where + lowerBound = min lower lower' + +intersectVersionIntervals :: VersionIntervals -> VersionIntervals + -> VersionIntervals +intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = + checkInvariant (VersionIntervals (intersect is0 is'0)) + where + intersect _ [] = [] + intersect [] _ = [] + intersect (i:is) (i':is') = case intersectInterval i i' of + Left Nothing -> intersect is (i':is') + Left (Just i'') -> i'' : intersect is (i':is') + Right Nothing -> intersect (i:is) is' + Right (Just i'') -> i'' : intersect (i:is) is' + +intersectInterval :: VersionInterval -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +intersectInterval (lower , upper ) (lower', upper') + + -- Non-intersecting intervals with the left interval ending first + | upper `doesNotIntersect` lower' = Left Nothing + + -- Non-intersecting intervals with the right interval first + | upper' `doesNotIntersect` lower = Right Nothing + + -- Complete or partial overlap, with the left interval ending first + | upper <= upper' = lowerBound `seq` + Left (Just (lowerBound, upper)) + + -- Complete or partial overlap, with the right interval ending first + | otherwise = lowerBound `seq` + Right (Just (lowerBound, upper')) + where + lowerBound = max lower lower' + +------------------------------- +-- Parsing and pretty printing +-- + +instance Text VersionRange where + disp = fst + . foldVersionRange' -- precedence: + ( Disp.text "-any" , 0 :: Int) + (\v -> (Disp.text "==" <> disp v , 0)) + (\v -> (Disp.char '>' <> disp v , 0)) + (\v -> (Disp.char '<' <> disp v , 0)) + (\v -> (Disp.text ">=" <> disp v , 0)) + (\v -> (Disp.text "<=" <> disp v , 0)) + (\v _ -> (Disp.text "==" <> dispWild v , 0)) + (\(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)) + + where dispWild (Version b _) = + Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) + <> Disp.text ".*" + punct p p' | p < p' = Disp.parens + | otherwise = id + + parse = expr + where + expr = do Parse.skipSpaces + t <- term + Parse.skipSpaces + (do _ <- Parse.string "||" + Parse.skipSpaces + e <- expr + return (UnionVersionRanges t e) + +++ + return t) + term = do f <- factor + Parse.skipSpaces + (do _ <- Parse.string "&&" + Parse.skipSpaces + t <- term + return (IntersectVersionRanges f t) + +++ + return f) + factor = Parse.choice $ parens expr + : parseAnyVersion + : parseWildcardRange + : map parseRangeOp rangeOps + parseAnyVersion = Parse.string "-any" >> return AnyVersion + + parseWildcardRange = do + _ <- Parse.string "==" + Parse.skipSpaces + branch <- Parse.sepBy1 digits (Parse.char '.') + _ <- Parse.char '.' + _ <- Parse.char '*' + return (WildcardVersion (Version branch [])) + + parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces) + (Parse.char ')' >> Parse.skipSpaces) + (do a <- p + Parse.skipSpaces + return (VersionRangeParens a)) + + digits = do + first <- Parse.satisfy Char.isDigit + if first == '0' + then return 0 + else do rest <- Parse.munch Char.isDigit + return (read (first : rest)) + + parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse + rangeOps = [ ("<", EarlierVersion), + ("<=", orEarlierVersion), + (">", LaterVersion), + (">=", orLaterVersion), + ("==", ThisVersion) ] diff --git a/cabal/Cabal/LICENSE b/cabal/Cabal/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/Cabal/LICENSE @@ -0,0 +1,33 @@ +Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren, + Bjorn Bringert, Krasimir Angelov, + Malcolm Wallace, Ross Patterson, Ian Lynagh, + Duncan Coutts, Thomas Schilling +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. diff --git a/cabal/Cabal/Language/Haskell/Extension.hs b/cabal/Cabal/Language/Haskell/Extension.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Language/Haskell/Extension.hs @@ -0,0 +1,540 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.Extension +-- Copyright : Isaac Jones 2003-2004 +-- +-- 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, + + Extension(..), + KnownExtension(..), + knownExtensions, + deprecatedExtensions + ) where + +import Distribution.Text (Text(..)) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import qualified Data.Char as Char (isAlphaNum) +import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) + +-- ------------------------------------------------------------ +-- * Language +-- ------------------------------------------------------------ + +-- | This represents a Haskell language dialect. +-- +-- Language 'Extension's are interpreted relative to one of these base +-- languages. +-- +data Language = + + -- | The Haskell 98 language as defined by the Haskell 98 report. + -- + Haskell98 + + -- | The Haskell 2010 language as defined by the Haskell 2010 report. + -- + | Haskell2010 + + -- | An unknown language, identified by its name. + | UnknownLanguage String + deriving (Show, Read, Eq) + +knownLanguages :: [Language] +knownLanguages = [Haskell98, Haskell2010] + +instance Text Language where + disp (UnknownLanguage other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + lang <- Parse.munch1 Char.isAlphaNum + return (classifyLanguage lang) + +classifyLanguage :: String -> Language +classifyLanguage = \str -> case lookup str langTable of + Just lang -> lang + Nothing -> UnknownLanguage str + where + langTable = [ (show lang, lang) + | lang <- knownLanguages ] + +-- ------------------------------------------------------------ +-- * Extension +-- ------------------------------------------------------------ + +-- 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) +-- +-- | This represents language extensions beyond a base 'Language' definition +-- (such as 'Haskell98') that are supported by some implementations, usually +-- in some special mode. +-- +-- Where applicable, references are given to an implementation's +-- official documentation, e.g. \"GHC § 7.2.1\" for an extension +-- documented in section 7.2.1 of the GHC User's Guide. + +data Extension = + -- | Enable a known extension + EnableExtension KnownExtension + + -- | Disable a known extension + | DisableExtension KnownExtension + + -- | An unknown extension, identified by the name of its @LANGUAGE@ + -- pragma. + | UnknownExtension String + + deriving (Show, Read, Eq) + +data KnownExtension = + + -- | [GHC § 7.6.3.4] Allow overlapping class instances, + -- provided there is a unique most specific instance for each use. + OverlappingInstances + + -- | [GHC § 7.6.3.3] Ignore structural rules guaranteeing the + -- termination of class instance resolution. Termination is + -- guaranteed by a fixed-depth recursion stack, and compilation + -- may fail if this depth is exceeded. + | UndecidableInstances + + -- | [GHC § 7.6.3.4] Implies 'OverlappingInstances'. Allow the + -- implementation to choose an instance even when it is possible + -- that further instantiation of types will lead to a more specific + -- instance being applicable. + | IncoherentInstances + + -- | [GHC § 7.3.8] Allows recursive bindings in @do@ blocks, + -- using the @rec@ keyword. + | DoRec + + -- | [GHC § 7.3.8.2] Deprecated in GHC. Allows recursive bindings + -- using @mdo@, a variant of @do@. @DoRec@ provides a different, + -- preferred syntax. + | RecursiveDo + + -- | [GHC § 7.3.9] Provide syntax for writing list + -- comprehensions which iterate over several lists together, like + -- the 'zipWith' family of functions. + | ParallelListComp + + -- | [GHC § 7.6.1.1] Allow multiple parameters in a type class. + | MultiParamTypeClasses + + -- | [GHC § 7.17] Enable the dreaded monomorphism restriction. + | MonomorphismRestriction + + -- | [GHC § 7.6.2] Allow a specification attached to a + -- multi-parameter type class which indicates that some parameters + -- are entirely determined by others. The implementation will check + -- that this property holds for the declared instances, and will use + -- this property to reduce ambiguity in instance resolution. + | FunctionalDependencies + + -- | [GHC § 7.8.5] Like 'RankNTypes' but does not allow a + -- higher-rank type to itself appear on the left of a function + -- arrow. + | Rank2Types + + -- | [GHC § 7.8.5] Allow a universally-quantified type to occur on + -- the left of a function arrow. + | RankNTypes + + -- | [GHC § 7.8.5] Allow data constructors to have polymorphic + -- arguments. Unlike 'RankNTypes', does not allow this for ordinary + -- functions. + | PolymorphicComponents + + -- | [GHC § 7.4.4] Allow existentially-quantified data constructors. + | ExistentialQuantification + + -- | [GHC § 7.8.7] Cause a type variable in a signature, which has an + -- explicit @forall@ quantifier, to scope over the definition of the + -- accompanying value declaration. + | ScopedTypeVariables + + -- | Deprecated, use 'ScopedTypeVariables' instead. + | PatternSignatures + + -- | [GHC § 7.8.3] Enable implicit function parameters with dynamic + -- scope. + | ImplicitParams + + -- | [GHC § 7.8.2] Relax some restrictions on the form of the context + -- of a type signature. + | FlexibleContexts + + -- | [GHC § 7.6.3.2] Relax some restrictions on the form of the + -- context of an instance declaration. + | FlexibleInstances + + -- | [GHC § 7.4.1] Allow data type declarations with no constructors. + | EmptyDataDecls + + -- | [GHC § 4.10.3] Run the C preprocessor on Haskell source code. + | CPP + + -- | [GHC § 7.8.4] Allow an explicit kind signature giving the kind of + -- types over which a type variable ranges. + | KindSignatures + + -- | [GHC § 7.11] Enable a form of pattern which forces evaluation + -- before an attempted match, and a form of strict @let@/@where@ + -- binding. + | BangPatterns + + -- | [GHC § 7.6.3.1] Allow type synonyms in instance heads. + | TypeSynonymInstances + + -- | [GHC § 7.9] Enable Template Haskell, a system for compile-time + -- metaprogramming. + | TemplateHaskell + + -- | [GHC § 8] Enable the Foreign Function Interface. In GHC, + -- implements the standard Haskell 98 Foreign Function Interface + -- Addendum, plus some GHC-specific extensions. + | ForeignFunctionInterface + + -- | [GHC § 7.10] Enable arrow notation. + | Arrows + + -- | [GHC § 7.16] Enable generic type classes, with default instances + -- defined in terms of the algebraic structure of a type. + | Generics + + -- | [GHC § 7.3.11] Enable the implicit importing of the module + -- @Prelude@. When disabled, when desugaring certain built-in syntax + -- into ordinary identifiers, use whatever is in scope rather than the + -- @Prelude@ -- version. + | ImplicitPrelude + + -- | [GHC § 7.3.15] Enable syntax for implicitly binding local names + -- corresponding to the field names of a record. Puns bind specific + -- names, unlike 'RecordWildCards'. + | NamedFieldPuns + + -- | [GHC § 7.3.5] Enable a form of guard which matches a pattern and + -- binds variables. + | PatternGuards + + -- | [GHC § 7.5.4] Allow a type declared with @newtype@ to use + -- @deriving@ for any class with an instance for the underlying type. + | GeneralizedNewtypeDeriving + + -- | [Hugs § 7.1] Enable the \"Trex\" extensible records system. + | ExtensibleRecords + + -- | [Hugs § 7.2] Enable type synonyms which are transparent in + -- some definitions and opaque elsewhere, as a way of implementing + -- abstract datatypes. + | RestrictedTypeSynonyms + + -- | [Hugs § 7.3] Enable an alternate syntax for string literals, + -- with string templating. + | HereDocuments + + -- | [GHC § 7.3.2] Allow the character @#@ as a postfix modifier on + -- identifiers. Also enables literal syntax for unboxed values. + | MagicHash + + -- | [GHC § 7.7] Allow data types and type synonyms which are + -- indexed by types, i.e. ad-hoc polymorphism for types. + | TypeFamilies + + -- | [GHC § 7.5.2] Allow a standalone declaration which invokes the + -- type class @deriving@ mechanism. + | StandaloneDeriving + + -- | [GHC § 7.3.1] Allow certain Unicode characters to stand for + -- certain ASCII character sequences, e.g. keywords and punctuation. + | UnicodeSyntax + + -- | [GHC § 8.1.1] Allow the use of unboxed types as foreign types, + -- e.g. in @foreign import@ and @foreign export@. + | UnliftedFFITypes + + -- | [GHC § 7.4.3] Defer validity checking of types until after + -- expanding type synonyms, relaxing the constraints on how synonyms + -- may be used. + | LiberalTypeSynonyms + + -- | [GHC § 7.4.2] Allow the name of a type constructor, type class, + -- or type variable to be an infix operator. + | TypeOperators + +--PArr -- not ready yet, and will probably be renamed to ParallelArrays + + -- | [GHC § 7.3.16] Enable syntax for implicitly binding local names + -- corresponding to the field names of a record. A wildcard binds + -- all unmentioned names, unlike 'NamedFieldPuns'. + | RecordWildCards + + -- | Deprecated, use 'NamedFieldPuns' instead. + | RecordPuns + + -- | [GHC § 7.3.14] Allow a record field name to be disambiguated + -- by the type of the record it's in. + | DisambiguateRecordFields + + -- | [GHC § 7.6.4] Enable overloading of string literals using a + -- type class, much like integer literals. + | OverloadedStrings + + -- | [GHC § 7.4.6] Enable generalized algebraic data types, in + -- which type variables may be instantiated on a per-constructor + -- basis. Implies GADTSyntax. + | GADTs + + -- | Enable GADT syntax for declaring ordinary algebraic datatypes. + | GADTSyntax + + -- | [GHC § 7.17.2] Make pattern bindings monomorphic. + | MonoPatBinds + + -- | [GHC § 7.8.8] Relax the requirements on mutually-recursive + -- polymorphic functions. + | RelaxedPolyRec + + -- | [GHC § 2.4.5] Allow default instantiation of polymorphic + -- types in more situations. + | ExtendedDefaultRules + + -- | [GHC § 7.2.2] Enable unboxed tuples. + | UnboxedTuples + + -- | [GHC § 7.5.3] Enable @deriving@ for classes + -- @Data.Typeable.Typeable@ and @Data.Generics.Data@. + | DeriveDataTypeable + + -- | [GHC § 7.6.1.3] Allow a class method's type to place + -- additional constraints on a class type variable. + | ConstrainedClassMethods + + -- | [GHC § 7.3.18] Allow imports to be qualified by the package + -- name the module is intended to be imported from, e.g. + -- + -- > import "network" Network.Socket + | PackageImports + + -- | [GHC § 7.8.6] Deprecated in GHC 6.12 and will be removed in + -- GHC 7. Allow a type variable to be instantiated at a + -- polymorphic type. + | ImpredicativeTypes + + -- | [GHC § 7.3.3] Change the syntax for qualified infix + -- operators. + | NewQualifiedOperators + + -- | [GHC § 7.3.12] Relax the interpretation of left operator + -- sections to allow unary postfix operators. + | PostfixOperators + + -- | [GHC § 7.9.5] Enable quasi-quotation, a mechanism for defining + -- new concrete syntax for expressions and patterns. + | QuasiQuotes + + -- | [GHC § 7.3.10] Enable generalized list comprehensions, + -- supporting operations such as sorting and grouping. + | TransformListComp + + -- | [GHC § 7.3.6] Enable view patterns, which match a value by + -- applying a function and matching on the result. + | ViewPatterns + + -- | Allow concrete XML syntax to be used in expressions and patterns, + -- as per the Haskell Server Pages extension language: + -- . The ideas behind it are + -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\" + -- by Niklas Broberg, from Haskell Workshop '05. + | XmlSyntax + + -- | Allow regular pattern matching over lists, as discussed in the + -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre + -- and Josef Svenningsson, from ICFP '04. + | RegularPatterns + + -- | Enables the use of tuple sections, e.g. @(, True)@ desugars into + -- @\x -> (x, True)@. + | TupleSections + + -- | Allows GHC primops, written in C--, to be imported into a Haskell + -- file. + | GHCForeignImportPrim + + -- | Support for patterns of the form @n + k@, where @k@ is an + -- integer literal. + | NPlusKPatterns + + -- | Improve the layout rule when @if@ expressions are used in a @do@ + -- block. + | DoAndIfThenElse + + -- | Makes much of the Haskell sugar be desugared into calls to the + -- function with a particular name that is in scope. + | RebindableSyntax + + -- | Make @forall@ a keyword in types, which can be used to give the + -- generalisation explicitly. + | ExplicitForAll + + -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in + -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. + | DatatypeContexts + + -- | Local (@let@ and @where@) bindings are monomorphic. + | MonoLocalBinds + + -- | Enable @deriving@ for the @Data.Functor.Functor@ class. + | DeriveFunctor + + -- | Enable @deriving@ for the @Data.Traversable.Traversable@ class. + | DeriveTraversable + + -- | Enable @deriving@ for the @Data.Foldable.Foldable@ class. + | DeriveFoldable + + -- | Enable non-decreasing indentation for 'do' blocks. + | NondecreasingIndentation + + -- | [GHC § 7.20.3] Allow imports to be qualified with a safe + -- keyword that requires the imported module be trusted as according + -- to the Safe Haskell definition of trust. + -- + -- > import safe Network.Socket + | SafeImports + + -- | [GHC § 7.20] Compile a module in the Safe, Safe Haskell + -- mode -- a restricted form of the Haskell language to ensure + -- type safety. + | Safe + + -- | [GHC § 7.20] Compile a module in the Trustworthy, Safe + -- Haskell mode -- no restrictions apply but the module is marked + -- as trusted as long as the package the module resides in is + -- trusted. + | Trustworthy + + -- | [GHC § 7.40] Allow type class/implicit parameter/equality + -- constraints to be used as types with the special kind Constraint. + -- Also generalise the (ctxt => ty) syntax so that any type of kind + -- Constraint can occur before the arrow. + | ConstraintKinds + + deriving (Show, Read, Eq, Enum, Bounded) + +{-# DEPRECATED knownExtensions + "KnownExtension is an instance of Enum and Bounded, use those instead." #-} +knownExtensions :: [KnownExtension] +knownExtensions = [minBound..maxBound] + +-- | Extensions that have been deprecated, possibly paired with another +-- extension that replaces it. +-- +deprecatedExtensions :: [(Extension, Maybe Extension)] +deprecatedExtensions = + [ (EnableExtension RecordPuns, Just (EnableExtension NamedFieldPuns)) + , (EnableExtension PatternSignatures, Just (EnableExtension ScopedTypeVariables)) + ] +-- 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 +-- 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. + +instance Text Extension where + disp (UnknownExtension other) = Disp.text other + disp (EnableExtension ke) = Disp.text (show ke) + disp (DisableExtension ke) = Disp.text ("No" ++ show ke) + + parse = do + extension <- Parse.munch1 Char.isAlphaNum + return (classifyExtension extension) + +instance Text KnownExtension where + disp ke = Disp.text (show ke) + + parse = do + extension <- Parse.munch1 Char.isAlphaNum + case classifyKnownExtension extension of + Just ke -> + return ke + Nothing -> + fail ("Can't parse " ++ show extension ++ " as KnownExtension") + +classifyExtension :: String -> Extension +classifyExtension string + = case classifyKnownExtension string of + Just ext -> EnableExtension ext + Nothing -> + case string of + 'N':'o':string' -> + case classifyKnownExtension string' of + Just ext -> DisableExtension ext + Nothing -> UnknownExtension string + _ -> UnknownExtension string + +-- | 'read' for 'KnownExtension's is really really slow so for the Text +-- instance +-- what we do is make a simple table indexed off the first letter in the +-- extension name. The extension names actually cover the range @'A'-'Z'@ +-- pretty densely and the biggest bucket is 7 so it's not too bad. We just do +-- a linear search within each bucket. +-- +-- This gives an order of magnitude improvement in parsing speed, and it'll +-- also allow us to do case insensitive matches in future if we prefer. +-- +classifyKnownExtension :: String -> Maybe KnownExtension +classifyKnownExtension "" = Nothing +classifyKnownExtension string@(c : _) + | inRange (bounds knownExtensionTable) c + = lookup string (knownExtensionTable ! c) + | otherwise = Nothing + +knownExtensionTable :: Array Char [(String, KnownExtension)] +knownExtensionTable = + accumArray (flip (:)) [] ('A', 'Z') + [ (head str, (str, extension)) + | extension <- [toEnum 0 ..] + , let str = show extension ] + diff --git a/cabal/Cabal/Makefile b/cabal/Cabal/Makefile new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Makefile @@ -0,0 +1,130 @@ + +VERSION=1.14.0 + +#KIND=devel +KIND=rc +#KIND=cabal-latest + +PREFIX=/usr/local +HC=ghc +GHCFLAGS=-Wall + +all: build + +# build the library itself + +SOURCES=Distribution/*.hs Distribution/Simple/*.hs Distribution/PackageDescription/*.hs Distribution/Simple/GHC/*.hs Distribution/Simple/Build/*.hs Distribution/Compat/*.hs Distribution/Simple/Program/*.hs +CONFIG_STAMP=dist/setup-config +BUILD_STAMP=dist/build/libHSCabal-$(VERSION).a +HADDOCK_STAMP=dist/doc/html/Cabal/index.html +USERGUIDE_STAMP=dist/doc/users-guide/index.html +SDIST_STAMP=dist/Cabal-$(VERSION).tar.gz +DISTLOC=dist/release +DIST_STAMP=$(DISTLOC)/Cabal-$(VERSION).tar.gz + +COMMA=, + +setup: $(SOURCES) Setup.hs + -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) + +build: $(BUILD_STAMP) +$(BUILD_STAMP): $(CONFIG_STAMP) $(SOURCES) + ./setup build + +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) +$(HADDOCK_STAMP) : $(CONFIG_STAMP) $(BUILD_STAMP) + ./setup haddock + +PANDOC=pandoc +PANDOC_OPTIONS= \ + --standalone \ + --smart \ + --css=$(PANDOC_HTML_CSS) +PANDOC_HTML_OUTDIR=dist/doc/users-guide +PANDOC_HTML_CSS=Cabal.css + +users-guide: $(USERGUIDE_STAMP) doc/*.markdown +$(USERGUIDE_STAMP): doc/*.markdown + mkdir -p $(PANDOC_HTML_OUTDIR) + for file in $^; do $(PANDOC) $(PANDOC_OPTIONS) --from=markdown --to=html --output $(PANDOC_HTML_OUTDIR)/$$(basename $${file} .markdown).html $${file}; done + cp doc/$(PANDOC_HTML_CSS) $(PANDOC_HTML_OUTDIR) + +docs: haddock users-guide + +clean: + rm -rf dist/ + rm -f setup + +# testing... + +moduleTest: tests/ModuleTest.hs tests/PackageDescriptionTests.hs + mkdir -p dist/test + $(HC) --make -Wall -DDEBUG -odir dist/test -hidir dist/test \ + -itests tests/ModuleTest.hs -o moduleTest + +#tests: moduleTest clean +# cd tests/A && $(MAKE) clean +# cd tests/HUnit-1.0 && $(MAKE) clean +# cd tests/A && $(MAKE) +# cd tests/HUnit-1.0 && $(MAKE) + +#check: +# rm -f moduleTest +# $(MAKE) moduleTest +# ./moduleTest + +# distribution... + +$(SDIST_STAMP) : $(BUILD_STAMP) + ./setup sdist + +dist: $(DIST_STAMP) +$(DIST_STAMP) : $(HADDOCK_STAMP) $(USERGUIDE_STAMP) $(SDIST_STAMP) + rm -rf $(DISTLOC) + mkdir $(DISTLOC) + tar -xzf $(SDIST_STAMP) -C $(DISTLOC)/ + mkdir $(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)/ + tar -C $(DISTLOC) -c Cabal-$(VERSION) -zf $(DISTLOC)/Cabal-$(VERSION).tar.gz + mv $(DISTLOC)/Cabal-$(VERSION)/doc $(DISTLOC)/ + mv $(DISTLOC)/Cabal-$(VERSION)/changelog $(DISTLOC)/ + rm -r $(DISTLOC)/Cabal-$(VERSION)/ + @echo "Cabal tarball built: $(DIST_STAMP)" + @echo "Release fileset prepared: $(DISTLOC)/" + +release: $(DIST_STAMP) + scp -r $(DISTLOC) haskell.org:/srv/web/haskell.org/cabal/release/cabal-$(VERSION) + ssh haskell.org 'cd /srv/web/haskell.org/cabal/release && rm -f $(KIND) && ln -s cabal-$(VERSION) $(KIND)' + +# tags... + +TAGSSRCDIRS = Distribution Language +tags TAGS: $(SOURCES) + find $(TAGSSRCDIRS) -name \*.\*hs | xargs hasktags diff --git a/cabal/Cabal/README b/cabal/Cabal/README new file mode 100644 --- /dev/null +++ b/cabal/Cabal/README @@ -0,0 +1,179 @@ +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 administer 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]: http://hackage.haskell.org/trac/hackage/ + + +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 diff --git a/cabal/Cabal/Setup.hs b/cabal/Cabal/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Setup.hs @@ -0,0 +1,10 @@ +import Distribution.Simple +main :: IO () +main = defaultMain + +-- Although this looks like the Simple build type, it is in fact vital that +-- we use this Setup.hs because it'll get compiled against the local copy +-- of the Cabal lib, thus enabling Cabal to bootstrap itself without relying +-- on any previous installation. This also means we can use any new features +-- immediately because we never have to worry about building Cabal with an +-- older version of itself. diff --git a/cabal/Cabal/changelog b/cabal/Cabal/changelog new file mode 100644 --- /dev/null +++ b/cabal/Cabal/changelog @@ -0,0 +1,385 @@ +-*-change-log-*- + +1.11.x (current development version) + +1.10.0.x (next stable release version) + +1.10.2.0 Duncan Coutts June 2011 + * Include test suites in cabal sdist + * Fix for conditionals in test suite stanzas in .cabal files + * Fix permissions of directories created during install + * Fix for global builds when $HOME env var is not set + +1.10.1.0 Duncan Coutts February 2011 + * Improved error messages when test suites are not enabled + * Template parameters allowed in test --test-option(s) flag + * Improved documentation of the test feature + * Relaxed QA check on cabal-version when using test-suite sections + * haddock command now allows both --hoogle and --html at the same time + * Find ghc-version-specific instances of the hsc2hs program + * Preserve file executable permissions in sdist tarballs + * Pass gcc location and flags to ./configure scripts + * Get default gcc flags from ghc + +1.10.0.0 Duncan Coutts November 2010 + * New cabal test feature + * Initial support for UHC + * New default-language and other-languages fields (e.g. Haskell98/2010) + * New default-extensions and other-extensions fields + * Deprecated extensions field (for packages using cabal-version >=1.10) + * Cabal-version field must now only be of the form ">= x.y" + * Removed deprecated --copy-prefix= feature + * Auto-reconfigure when .cabal file changes + * Workaround for haddock overwriting .hi and .o files when using TH + * Extra cpp flags used with hsc2hs and c2hs (-D${os}_BUILD_OS etc) + * New cpp define VERSION_ gives string version of dependencies + * User guide source now in markdown format for easier editing + * Improved checks and error messages for C libraries and headers + * Removed BSD4 from the list of suggested licenses + * Updated list of known language extensions + * Fix for include paths to allow C code to import FFI stub.h files + * Fix for intra-package dependencies on OSX + * Stricter checks on various bits of .cabal file syntax + * Minor fixes for c2hs + +1.8.0.6 Duncan Coutts June 2010 + * Fix 'register --global/--user' + +1.8.0.4 Duncan Coutts March 2010 + * Set dylib-install-name for dynalic libs on OSX + * Stricter configure check that compiler supports a package's extensions + * More configure-time warnings + * Hugs can compile Cabal lib again + * Default datadir now follows prefix on Windows + * Support for finding installed packages for hugs + * Cabal version macros now have proper parenthesis + * Reverted change to filter out deps of non-buildable components + * Fix for registering implace when using a specific package db + * Fix mismatch between $os and $arch path template variables + * Fix for finding ar.exe on Windows, always pick ghc's version + * Fix for intra-package dependencies with ghc-6.12 + +1.8.0.2 Duncan Coutts December 2009 + * Support for GHC-6.12 + * New unique installed package IDs which use a package hash + * Allow executables to depend on the lib within the same package + * Dependencies for each component apply only to that component + (previously applied to all the other components too) + * Added new known license MIT and versioned GPL and LGPL + * More liberal package version range syntax + * Package registration files are now UTF8 + * Support for LHC and JHC-0.7.2 + * Deprecated RecordPuns extension in favour of NamedFieldPuns + * Deprecated PatternSignatures extension in favor of ScopedTypeVariables + * New VersionRange semantic view as a sequence of intervals + * Improved package quality checks + * Minor simplification in a couple Setup.hs hooks + * Beginnings of a unit level testsuite using QuickCheck + * Various bug fixes + * Various internal cleanups + +1.6.0.2 Duncan Coutts February 2009 + * New configure-time check for C headers and libraries + * Added language extensions present in ghc-6.10 + * Added support for NamedFieldPuns extension in ghc-6.8 + * Fix in configure step for ghc-6.6 on Windows + * Fix warnings in Path_pkgname.hs module on Windows + * Fix for exotic flags in ld-options field + * Fix for using pkg-config in a package with a lib and an executable + * Fix for building haddock docs for exes that use the Paths module + * Fix for installing header files in subdirectories + * Fix for the case of building profiling libs but not ordinary libs + * Fix read-only attribute of installed files on Windows + * Ignore ghc -threaded flag when profiling in ghc-6.8 and older + +1.6.0.1 Duncan Coutts October 2008 + * Export a compat function to help alex and happy + +1.6.0.0 Duncan Coutts October 2008 + * Support for ghc-6.10 + * Source control repositories can now be specified in .cabal files + * Bug report URLs can be now specified in .cabal files + * Wildcards now allowed in data-files and extra-source-files fields + * New syntactic sugar for dependencies "build-depends: foo ==1.2.*" + * New cabal_macros.h provides macros to test versions of dependencies + * Relocatable bindists now possible on unix via env vars + * New 'exposed' field allows packages to be not exposed by default + * Install dir flags can now use $os and $arch variables + * New --builddir flag allows multiple builds from a single sources dir + * cc-options now only apply to .c files, not for -fvia-C + * cc-options are not longer propagated to dependent packages + * The cpp/cc/ld-options fields no longer use ',' as a separator + * hsc2hs is now called using gcc instead of using ghc as gcc + * New api for manipulating sets and graphs of packages + * Internal api improvements and code cleanups + * Minor improvements to the user guide + * Miscellaneous minor bug fixes + +1.4.0.2 Duncan Coutts August 2008 + * Fix executable stripping default + * Fix striping exes on OSX that export dynamic symbols (like ghc) + * Correct the order of arguments given by --prog-options= + * Fix corner case with overlapping user and global packages + * Fix for modules that use pre-processing and .hs-boot files + * Clarify some points in the user guide and readme text + * Fix verbosity flags passed to sub-command like haddock + * Fix sdist --snapshot + * Allow meta-packages that contain no modules or C code + * Make the generated Paths module -Wall clean on Windows + +1.4.0.1 Duncan Coutts June 2008 + * Fix a bug which caused '.' to always be in the sources search path + * Haddock-2.2 and later do now support the --hoogle flag + +1.4.0.0 Duncan Coutts June 2008 + * Rewritten command line handling support + * Command line completion with bash + * Better support for Haddock 2 + * Improved support for nhc98 + * Removed support for ghc-6.2 + * Haddock markup in .lhs files now supported + * Default colour scheme for highlighted source code + * Default prefix for --user installs is now $HOME/.cabal + * All .cabal files are treaded as UTF-8 and must be valid + * Many checks added for common mistakes + * New --package-db= option for specific package databases + * Many internal changes to support cabal-install + * Stricter parsing for version strings, eg dissalows "1.05" + * Improved user guide introduction + * Programatica support removed + * New options --program-prefix/suffix allows eg versioned programs + * Support packages that use .hs-boot files + * Fix sdist for Main modules that require preprocessing + * New configure -O flag with optimisation level 0--2 + * Provide access to "x-" extension fields through the Cabal api + * Added check for broken installed packages + * Added warning about using inconsistent versions of dependencies + * Strip binary executable files by default with an option to disable + * New options to add site-specific include and library search paths + * Lift the restriction that libraries must have exposed-modules + * Many bugs fixed. + * Many internal structural improvements and code cleanups + +1.2.4.0 Duncan Coutts June 2008 + * Released with GHC 6.8.3 + * Backported several fixes and minor improvements from Cabal-1.4 + * Use a default colour scheme for sources with hscolour >=1.9 + * Support --hyperlink-source for Haddock >= 2.0 + * Fix for running in a non-writable directory + * Add OSX -framework arguments when linking executables + * Updates to the user guide + * Allow build-tools names to include + and _ + * Export autoconfUserHooks and simpleUserHooks + * Export ccLdOptionsBuildInfo for Setup.hs scripts + * Export unionBuildInfo and make BuildInfo an instance of Monoid + * Fix to allow the 'main-is' module to use a pre-processor + +1.2.3.0 Duncan Coutts Nov 2007 + * Released with GHC 6.8.2 + * Includes full list of GHC language extensions + * Fix infamous "dist/conftest.c" bug + * Fix configure --interfacedir= + * Find ld.exe on Windows correctly + * Export PreProcessor constructor and mkSimplePreProcessor + * Fix minor bug in unlit code + * Fix some markup in the haddock docs + +1.2.2.0 Duncan Coutts Nov 2007 + * Released with GHC 6.8.1 + * Support haddock-2.0 + * Support building DSOs with GHC + * Require reconfiguring if the .cabal file has changed + * Fix os(windows) configuration test + * Fix building documentation + * Fix building packages on Solaris + * Other minor bug fixes + +1.2.1 Duncan Coutts Oct 2007 + * To be included in GHC 6.8.1 + * New field "cpp-options" used when preprocessing Haskell modules + * Fixes for hsc2hs when using ghc + * C source code gets compiled with -O2 by default + * OS aliases, to allow os(windows) rather than requiring os(mingw32) + * Fix cleaning of 'stub' files + * Fix cabal-setup, command line ui that replaces "runhaskell Setup.hs" + * Build docs even when dependent packages docs are missing + * Allow the --html-dir to be specified at configure time + * Fix building with ghc-6.2 + * Other minor bug fixes and build fixes + +1.2.0 Duncan Coutts Sept 2007 + * To be included in GHC 6.8.x + * New configurations feature + * Can make haddock docs link to hilighted sources (with hscolour) + * New flag to allow linking to haddock docs on the web + * Supports pkg-config + * New field "build-tools" for tool dependencies + * Improved c2hs support + * Preprocessor output no longer clutters source dirs + * Seperate "includes" and "install-includes" fields + * Makefile command to generate makefiles for building libs with GHC + * New --docdir configure flag + * Generic --with-prog --prog-args configure flags + * Better default installation paths on Windows + * Install paths can be specified relative to each other + * License files now installed + * Initial support for NHC (incomplete) + * Consistent treatment of verbosity + * Reduced verbosity of configure step by default + * Improved helpfulness of output messages + * Help output now clearer and fits in 80 columns + * New setup register --gen-pkg-config flag for distros + * Major internal refactoring, hooks api has changed + * Dozens of bug fixes + +1.1.6.2 Duncan Coutts May 2007 + * Released with GHC 6.6.1 + * Handle windows text file encoding for .cabal files + * Fix compiling a executable for profiling that uses Template Haskell + * Other minor bug fixes and user guide clarifications + +1.1.6.1 Duncan Coutts Oct 2006 + * fix unlit code + * fix escaping in register.sh + +1.1.6 Duncan Coutts Oct 2006 + * Released with GHC 6.6 + * Added support for hoogle + * Allow profiling and normal builds of libs to be chosen indepentantly + * Default installation directories on Win32 changed + * Register haddock docs with ghc-pkg + * Get haddock to make hyperlinks to dependent package docs + * Added BangPatterns language extension + * Various bug fixes + +1.1.4 Duncan Coutts May 2006 + * Released with GHC 6.4.2 + * Better support for packages that need to install header files + * cabal-setup added, but not installed by default yet + * Implemented "setup register --inplace" + * Have packages exposed by default with ghc-6.2 + * It is no longer necessary to run 'configure' before 'clean' or 'sdist' + * Added support for ghc's -split-objs + * Initial support for JHC + * Ignore extension fields in .cabal files (fields begining with "x-") + * Some changes to command hooks API to improve consistency + * Hugs support improvements + * Added GeneralisedNewtypeDeriving language extension + * Added cabal-version field + * Support hidden modules with haddock + * Internal code refactoring + * More bug fixes + +1.1.3 Isaac Jones Sept 2005 + * WARNING: Interfaces not documented in the user's guide may + change in future releases. + * Move building of GHCi .o libs to the build phase rather than + register phase. (from Duncan Coutts) + * Use .tar.gz for source package extension + * Uses GHC instead of cpphs if the latter is not available + * Added experimental "command hooks" which completely override the + default behavior of a command. + * Some bugfixes + +1.1.1 Isaac Jones July 2005 + * WARNING: Interfaces not documented in the user's guide may + change in future releases. + * Handles recursive modules for GHC 6.2 and GHC 6.4. + * Added "setup test" command (Used with UserHook) + * implemented handling of _stub.{c,h,o} files + * Added support for profiling + * Changed install prefix of libraries (pref/pkgname-version + to prefix/pkgname-version/compname-version) + * Added pattern guards as a language extension + * Moved some functionality to Language.Haskell.Extension + * Register / unregister .bat files for windows + * Exposed more of the API + * Added support for the hide-all-packages flag in GHC > 6.4 + * Several bug fixes + +1.0 Isaac Jones March 11 2005 + * Released with GHC 6.4, Hugs March 2005, and nhc98 1.18 + * Some sanity checking + +0.5 Isaac Jones Wed Feb 19 2005 + * WARNING: this is a pre-release and the interfaces are still + likely to change until we reach a 1.0 release. + * Hooks interfaces changed + * Added preprocessors to user hooks + * No more executable-modules or hidden-modules. Use + "other-modules" instead. + * Certain fields moved into BuildInfo, much refactoring + * extra-libs -> extra-libraries + * Added --gen-script to configure and unconfigure. + * modules-ghc (etc) now ghc-modules (etc) + * added new fields including "synopsis" + * Lots of bug fixes + * spaces can sometimes be used instead of commas + * A user manual has appeared (Thanks, ross!) + * for ghc 6.4, configures versionsed depends properly + * more features to ./setup haddock + +0.4 Isaac Jones Sun Jan 16 2005 + + * Much thanks to all the awesome fptools hackers who have been + working hard to build the Haskell Cabal! + + * Interface Changes: + + ** WARNING: this is a pre-release and the interfaces are still + likely to change until we reach a 1.0 release. + + ** Instead of Package.description, you should name your + description files .cabal. In particular, we suggest + that you name it .cabal, but this is not enforced + (yet). Multiple .cabal files in the same directory is an error, + at least for now. + + ** ./setup install --install-prefix is gone. Use ./setup copy + --copy-prefix instead. + + ** The "Modules" field is gone. Use "hidden-modules", + "exposed-modules", and "executable-modules". + + ** Build-depends is now a package-only field, and can't go into + executable stanzas. Build-depends is a package-to-package + relationship. + + ** Some new fields. Use the Source. + + * New Features + + ** Cabal is now included as a package in the CVS version of + fptools. That means it'll be released as "-package Cabal" in + future versions of the compilers, and if you are a bleeding-edge + user, you can grab it from the CVS repository with the compilers. + + ** Hugs compatibility and NHC98 compatibility should both be + improved. + + ** Hooks Interface / Autoconf compatibility: Most of the hooks + interface is hidden for now, because it's not finalized. I have + exposed only "defaultMainWithHooks" and "defaultUserHooks". This + allows you to use a ./configure script to preprocess + "foo.buildinfo", which gets merged with "foo.cabal". In future + releases, we'll expose UserHooks, but we're definitely going to + change the interface to those. The interface to the two functions + I've exposed should stay the same, though. + + ** ./setup haddock is a baby feature which pre-processes the + source code with hscpp and runs haddock on it. This is brand new + and hardly tested, so you get to knock it around and see what you + think. + + ** Some commands now actually implement verbosity. + + ** The preprocessors have been tested a bit more, and seem to work + OK. Please give feedback if you use these. + +0.3 Isaac Jones Sun Jan 16 2005 + * Unstable snapshot release + * From now on, stable releases are even. + +0.2 Isaac Jones + + * Adds more HUGS support and preprocessor support. diff --git a/cabal/Cabal/doc/Cabal.css b/cabal/Cabal/doc/Cabal.css new file mode 100644 --- /dev/null +++ b/cabal/Cabal/doc/Cabal.css @@ -0,0 +1,39 @@ +div { + font-family: sans-serif; + color: black; + background: white +} + +h1, h2, h3, h4, h5, h6, p.title { color: #005A9C } + +h1 { font: 170% sans-serif } +h2 { font: 140% sans-serif } +h3 { font: 120% sans-serif } +h4 { font: bold 100% sans-serif } +h5 { font: italic 100% sans-serif } +h6 { font: small-caps 100% sans-serif } + +pre { + font-family: monospace; + border-width: 1px; + border-style: solid; + padding: 0.3em +} + +pre.screen { color: #006400 } +pre.programlisting { color: maroon } + +div.example { + margin: 1ex 0em; + border: solid #412e25 1px; + padding: 0ex 0.4em +} + +div.example, div.example-contents { + background-color: #fffcf5 +} + +a:link { color: #0000C8 } +a:hover { background: #FFFFA8 } +a:active { color: #D00000 } +a:visited { color: #680098 } diff --git a/cabal/Cabal/doc/developing-packages.markdown b/cabal/Cabal/doc/developing-packages.markdown new file mode 100644 --- /dev/null +++ b/cabal/Cabal/doc/developing-packages.markdown @@ -0,0 +1,1537 @@ +% Cabal User Guide + +# Developing packages # + +The Cabal package is the unit of distribution. When installed, its +purpose is to make available: + + * One or more Haskell programs. + + * At most one library, exposing a number of Haskell modules. + +However having both a library and executables in a package does not work +very well; if the executables depend on the library, they must +explicitly list all the modules they directly or indirectly import from +that library. Fortunately, starting with Cabal 1.8.0.4, executables can +also declare the package that they are in as a dependency, and Cabal +will treat them as if they were in another package that dependended on +the library. + +Internally, the package may consist of much more than a bunch of Haskell +modules: it may also have C source code and header files, source code +meant for preprocessing, documentation, test cases, auxiliary tools etc. + +A package is identified by a globally-unique _package name_, which +consists of one or more alphanumeric words separated by hyphens. To +avoid ambiguity, each of these words should contain at least one letter. +Chaos will result if two distinct packages with the same name are +installed on the same system. A particular version of the package is +distinguished by a _version number_, consisting of a sequence of one or +more integers separated by dots. These can be combined to form a single +text string called the _package ID_, using a hyphen to separate the name +from the version, e.g. "`HUnit-1.1`". + +Note: Packages are not part of the Haskell language; they simply +populate the hierarchical space of module names. In GHC 6.6 and later a +program may contain multiple modules with the same name if they come +from separate packages; in all other current Haskell systems packages +may not overlap in the modules they provide, including hidden modules. + +## Creating a package ## + +Suppose you have a directory hierarchy containing the source files that +make up your package. You will need to add two more files to the root +directory of the package: + +_package_`.cabal` + +: a Unicode UTF-8 text file containing a package description. + For details of the syntax of this file, see the [section on package + descriptions](#package-descriptions). + +`Setup.hs` + +: a single-module Haskell program to perform various setup tasks (with + the interface described in the section on [building and installing + packages](#building-and-installing-a-package)). This module should + import only modules that will be present in all Haskell + implementations, including modules of the Cabal library. In most + cases it will be trivial, calling on the Cabal library to do most of + the work. + +Once you have these, you can create a source bundle of this directory +for distribution. Building of the package is discussed in the section on +[building and installing packages](#building-and-installing-a-package). + +One of the purposes of Cabal is to make it easier to build a package +with different Haskell implementations. So it provides abstractions of +features present in different Haskell implementations and wherever +possible it is best to take advantage of these to increase portability. +Where necessary however it is possible to use specific features of +specific implementations. For example one of the pieces of information a +package author can put in the package's `.cabal` file is what language +extensions the code uses. This is far preferable to specifying flags for +a specific compiler as it allows Cabal to pick the right flags for the +Haskell implementation that the user picks. It also allows Cabal to +figure out if the language extension is even supported by the Haskell +implementation that the user picks. Where compiler-specific options are +needed however, there is an "escape hatch" available. The developer can +specify implementation-specific options and more generally there is a +configuration mechanism to customise many aspects of how a package is +built depending on the Haskell implementation, the Operating system, +computer architecture and user-specified configuration flags. + +~~~~~~~~~~~~~~~~ +name: Foo +version: 1.0 + +library + build-depends: base + exposed-modules: Foo + extensions: ForeignFunctionInterface + ghc-options: -Wall + nhc98-options: -K4m + if os(windows) + build-depends: Win32 +~~~~~~~~~~~~~~~~ + +#### Example: A package containing a simple library #### + +The HUnit package contains a file `HUnit.cabal` containing: + +~~~~~~~~~~~~~~~~ +name: HUnit +version: 1.1.1 +synopsis: A unit testing framework for Haskell +homepage: http://hunit.sourceforge.net/ +category: Testing +author: Dean Herington +license: BSD3 +license-file: LICENSE +cabal-version: >= 1.10 +build-type: Simple + +library + build-depends: base >= 2 && < 4 + exposed-modules: Test.HUnit.Base, Test.HUnit.Lang, + Test.HUnit.Terminal, Test.HUnit.Text, Test.HUnit + default-extensions: CPP +~~~~~~~~~~~~~~~~ + +and the following `Setup.hs`: + +~~~~~~~~~~~~~~~~ +import Distribution.Simple +main = defaultMain +~~~~~~~~~~~~~~~~ + +#### Example: A package containing executable programs #### + +~~~~~~~~~~~~~~~~ +name: TestPackage +version: 0.0 +synopsis: Small package with two programs +author: Angela Author +license: BSD3 +build-type: Simple +cabal-version: >= 1.2 + +executable program1 + build-depends: HUnit + main-is: Main.hs + hs-source-dirs: prog1 + +executable program2 + main-is: Main.hs + build-depends: HUnit + hs-source-dirs: prog2 + other-modules: Utils +~~~~~~~~~~~~~~~~ + +with `Setup.hs` the same as above. + +#### Example: A package containing a library and executable programs #### + +~~~~~~~~~~~~~~~~ +name: TestPackage +version: 0.0 +synopsis: Package with library and two programs +license: BSD3 +author: Angela Author +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: HUnit + exposed-modules: A, B, C + +executable program1 + main-is: Main.hs + hs-source-dirs: prog1 + other-modules: A, B + +executable program2 + main-is: Main.hs + hs-source-dirs: prog2 + other-modules: A, C, Utils +~~~~~~~~~~~~~~~~ + +with `Setup.hs` the same as above. Note that any library modules +required (directly or indirectly) by an executable must be listed again. + +The trivial setup script used in these examples uses the _simple build +infrastructure_ provided by the Cabal library (see +[Distribution.Simple][dist-simple]). The simplicity lies in its +interface rather that its implementation. It automatically handles +preprocessing with standard preprocessors, and builds packages for all +the Haskell implementations (except nhc98, for now). + +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). + +## Package descriptions ## + +The package description file must have a name ending in "`.cabal`". It +must be a Unicode text file encoded using valid UTF-8. There must be +exactly one such file in the directory. The first part of the name is +usually the package name, and some of the tools that operate on Cabal +packages require this. + +In the package description file, lines whose first non-whitespace characters +are "`--`" are treated as comments and ignored. + +This file should contain of a number global property descriptions and +several sections. + +* The [global properties](#package-properties) describe the package as a + whole, such as name, license, author, etc. + +* Optionally, a number of _configuration flags_ can be declared. These + can be used to enable or disable certain features of a package. (see + the section on [configurations](#configurations)). + +* The (optional) library section specifies the [library + properties](#library) and relevant [build + information](#build-information). + +* Following is an arbitrary number of executable sections + which describe an [executable program](#executable) and relevant + [build information](#build-information). + +Each section consists of a number of property descriptions +in the form of field/value pairs, with a syntax roughly like mail +message headers. + +* Case is not significant in field names, but is significant in field + values. + +* To continue a field value, indent the next line relative to the field + name. + +* Field names may be indented, but all field values in the same section + must use the same indentation. + +* Tabs are *not* allowed as indentation characters due to a missing + standard interpretation of tab width. + +* To get a blank line in a field value, use an indented "`.`" + +The syntax of the value depends on the field. Field types include: + +_token_, _filename_, _directory_ +: Either a sequence of one or more non-space non-comma characters, or + a quoted string in Haskell 98 lexical syntax. Unless otherwise + stated, relative filenames and directories are interpreted from the + package root directory. + +_freeform_, _URL_, _address_ +: An arbitrary, uninterpreted string. + +_identifier_ +: A letter followed by zero or more alphanumerics or underscores. + +_compiler_ +: A compiler flavor (one of: `GHC`, `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`. + +### Modules and preprocessors ### + +Haskell module names listed in the `exposed-modules` and `other-modules` +fields may correspond to Haskell source files, i.e. with names ending in +"`.hs`" or "`.lhs`", or to inputs for various Haskell preprocessors. The +simple build infrastructure understands the extensions: + +* `.gc` ([greencard][]) +* `.chs` ([c2hs][]) +* `.hsc` (`hsc2hs`) +* `.y` and `.ly` ([happy][]) +* `.x` ([alex][]) +* `.cpphs` ([cpphs][]) + +When building, Cabal will automatically run the appropriate preprocessor +and compile the Haskell module it produces. + +Some fields take lists of values, which are optionally separated by commas, except for the +`build-depends` field, where the commas are mandatory. + +Some fields are marked as required. All others are optional, and unless +otherwise specified have empty default values. + +### Package properties ### + +These fields may occur in the first top-level properties section and +describe the package as a whole: + +`name:` _package-name_ (required) +: The unique name of the [package](#packages), without the version + number. + +`version:` _numbers_ (required) +: The package version number, usually consisting of a sequence of + natural numbers separated by dots. + +`cabal-version:` _>= x.y_ +: The version of the Cabal specification that this package description uses. + The Cabal specification does slowly evolve, intoducing new features and + occasionally changing the meaning of existing features. By specifying + which version of the spec you are using it enables programs which process + the package description to know what syntax to expect and what each part + means. + + For historical reasons this is always expressed using _>=_ version range + syntax. No other kinds of version range make sense, in particular upper + bounds do not make sense. In future this field will specify just a version + number, rather than a version range. + + The version number you specify will affect both compatability and + behaviour. Most tools (including the Cabal libray and cabal program) + understand a range of versions of the Cabal specification. Older tools + will of course only work with older versions of the Cabal specification. + Most of the time, tools that are too old will recognise this fact and + produce a suitable error message. + + As for behaviour, new versions of the Cabal spec can change the meaning + of existing syntax. This means if you want to take advantage of the new + meaning or behaviour then you must specify the newer Cabal version. + Tools are expected to use the meaning and behaviour appropriate to the + version given in the package description. + + In particular, the syntax of package descriptions changed significantly + with Cabal version 1.2 and the `cabal-version` field is now required. + Files written in the old syntax are still recognized, so if you require + compatability with very old Cabal versions then you may write your package + description file using the old syntax. Please consult the user's guide of + an older Cabal version for a description of that syntax. + +`build-type:` _identifier_ +: The type of build used by this package. Build types are the + constructors of the [BuildType][] type, defaulting to `Custom`. If + this field is given a value other than `Custom`, some tools such as + `cabal-install` will be able to build the package without using the + setup script. So if you are just using the default `Setup.hs` then + set the build type as `Simple`. + +`license:` _identifier_ (default: `AllRightsReserved`) +: The type of license under which this package is distributed. + License names are the constants of the [License][dist-license] type. + +`license-file:` _filename_ +: The name of a file containing the precise license for this package. + It will be installed with the package. + +`copyright:` _freeform_ +: The content of a copyright notice, typically the name of the holder + of the copyright on the package and the year(s) from which copyright + is claimed. For example: `Copyright: (c) 2006-2007 Joe Bloggs` + +`author:` _freeform_ +: The original author of the package. + + Remember that `.cabal` files are Unicode, using the UTF-8 encoding. + +`maintainer:` _address_ +: The current maintainer or maintainers of the package. This is an e-mail address to which users should send bug + reports, feature requests and patches. + +`stability:` _freeform_ +: The stability level of the package, e.g. `alpha`, `experimental`, `provisional`, + `stable`. + +`homepage:` _URL_ +: The package homepage. + +`bug-reports:` _URL_ +: The URL where users should direct bug reports. This would normally be either: + + * A `mailto:` URL, eg for a person or a mailing list. + + * An `http:` (or `https:`) URL for an online bug tracking system. + + For example Cabal itself uses a web-based bug tracking system + + ~~~~~~~~~~~~~~~~ + bug-reports: http://hackage.haskell.org/trac/hackage/ + ~~~~~~~~~~~~~~~~ + +`package-url:` _URL_ +: The location of a source bundle for the package. The distribution + should be a Cabal package. + +`synopsis:` _freeform_ +: A very short description of the package, for use in a table of + packages. This is your headline, so keep it short (one line) but as + informative as possible. Save space by not including the package + name or saying it's written in Haskell. + +`description:` _freeform_ +: Description of the package. This may be several paragraphs, and + should be aimed at a Haskell programmer who has never heard of your + package before. + + For library packages, this field is used as prologue text by [`setup + haddock`](#setup-haddock), and thus may contain the same markup as + [haddock][] documentation comments. + +`category:` _freeform_ +: A classification category for future use by the package catalogue [Hackage]. These + categories have not yet been specified, but the upper levels of the + module hierarchy make a good start. + +`tested-with:` _compiler list_ +: A list of compilers and versions against which the package has been + tested (or at least built). + +`data-files:` _filename list_ +: A list of files to be installed for run-time use by the package. + This is useful for packages that use a large amount of static data, + such as tables of values or code templates. Cabal provides a way to + [find these files at + run-time](#accessing-data-files-from-package-code). + + A limited form of `*` wildcards in file names, for example + `data-files: images/*.png` matches all the `.png` files in the + `images` directory. + + The limitation is that `*` wildcards are only allowed in place of + the file name, not in the directory name or file extension. In + particular, wildcards do not include directories contents + recursively. Furthermore, if a wildcard is used it must be used with + an extension, so `data-files: data/*` is not allowed. When matching + a wildcard plus extension, a file's full extension must match + exactly, so `*.gz` matches `foo.gz` but not `foo.tar.gz`. A wildcard + that does not match any files is an error. + + The reason for providing only a very limited form of wildcard is to + concisely express the common case of a large number of related files + of the same file type without making it too easy to accidentally + include unwanted files. + +`data-dir:` _directory_ +: The directory where Cabal looks for data files to install, relative + to the source directory. By default, Cabal will look in the source + directory itself. + +`extra-source-files:` _filename list_ +: A list of additional files to be included in source distributions + built with [`setup sdist`](#setup-sdist). As with `data-files` it + can use a limited form of `*` wildcards in file names. + +`extra-tmp-files:` _filename list_ +: A list of additional files or directories to be removed by [`setup + clean`](#setup-clean). These would typically be additional files + created by additional hooks, such as the scheme described in the + section on [system-dependent parameters](#system-dependent-parameters). + +### Library ### + +The library section should contain the following fields: + +`exposed-modules:` _identifier list_ (required if this package contains a library) +: A list of modules added by this package. + +`exposed:` _boolean_ (default: `True`) +: Some Haskell compilers (notably GHC) support the notion of packages + being "exposed" or "hidden" which means the modules they provide can + be easily imported without always having to specify which package + they come from. However this only works effectively if the modules + provided by all exposed packages do not overlap (otherwise a module + import would be ambiguous). + + Almost all new libraries use hierarchical module names that do not + clash, so it is very uncommon to have to use this field. However it + may be necessary to set `exposed: False` for some old libraries that + use a flat module namespace or where it is known that the exposed + modules would clash with other common modules. + +The library section may also contain build information fields (see the +section on [build information](#build-information)). + + +### Executables ### + +Executable sections (if present) describe executable programs contained +in the package and must have an argument after the section label, which +defines the name of the executable. This is a freeform argument but may +not contain spaces. + +The executable may be described using the following fields, as well as +build information fields (see the section on [build +information](#build-information)). + +`main-is:` _filename_ (required) +: The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the + `.hs` filename that must be listed, even if that file is generated + using a preprocessor. The source file must be relative to one of the + directories listed in `hs-source-dirs`. + +### Test suites ### + +Test suite sections (if present) describe package test suites and must have an +argument after the section label, which defines the name of the test suite. +This is a freeform argument, but may not contain spaces. It should be unique +among the names of the package's other test suites, the package's executables, +and the package itself. Using test suite sections requires at least Cabal +version 1.9.2. + +The test suite may be described using the following fields, as well as build +information fields (see the section on [build +information](#build-information)). + +`type:` _interface_ (required) +: The interface type and version of the test suite. Cabal supports two test + suite interfaces, called `exitcode-stdio-1.0` and `detailed-1.0`. 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` +interface. The `exitcode-stdio-1.0` type requires the `main-is` field. + +`main-is:` _filename_ (required: `exitcode-stdio-1.0`, disallowed: `detailed-1.0`) +: The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the + `.hs` filename that must be listed, even if that file is generated + using a preprocessor. The source file must be relative to one of the + directories listed in `hs-source-dirs`. This field is analogous to the + `main-is` field of an executable section. + +Test suites using the `detailed-1.0` 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 +test suite's results case by case, producing detailed human- and +machine-readable log files. The `detailed-1.0` interface requires the +`test-module` field. + +`test-module:` _identifier_ (required: `detailed-1.0`, 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. + +foo.cabal: + +~~~~~~~~~~~~~~~~ +Name: foo +Version: 1.0 +License: BSD3 +Cabal-Version: >= 1.9.2 +Build-Type: Simple + +Test-Suite test-foo + type: exitcode-stdio-1.0 + main-is: test-foo.hs + build-depends: base +~~~~~~~~~~~~~~~~ + +test-foo.hs: + +~~~~~~~~~~~~~~~~ +module Main where + +import System.Exit (exitFailure) + +main = do + putStrLn "This test always fails!" + exitFailure +~~~~~~~~~~~~~~~~ + +#### Example: Package using `detailed-1.0` 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. + +bar.cabal: + +~~~~~~~~~~~~~~~~ +Name: bar +Version: 1.0 +License: BSD3 +Cabal-Version: >= 1.9.2 +Build-Type: Simple + +Test-Suite test-bar + type: detailed-1.0 + test-module: Bar + build-depends: base, Cabal >= 1.9.2 +~~~~~~~~~~~~~~~~ + +Bar.hs: + +~~~~~~~~~~~~~~~~ +module Bar ( tests ) where + +import Distribution.TestSuite + +tests :: IO [Test] +tests = return [ Test succeeds, Test fails ] + where + succeeds = TestInstance + { run = return $ Finished Pass + , name = "succeeds" + , tags = [] + , options = [] + , setOption = \_ _ -> Right succeeds + } + fails = TestInstance + { run = return $ Finished $ Fail "Always fails!" + , name = "fails" + , tags = [] + , options = [] + , setOption = \_ _ -> Right fails + } +~~~~~~~~~~~~~~~~ + +#### Running test suites #### + +You can have Cabal run your test suites using its built-in test +runner: + +~~~~~~~~~~~~~~~~ +$ cabal configure --enable-tests +$ cabal build +$ cabal test +~~~~~~~~~~~~~~~~ + +See the output of `cabal help test` for a list of options you can pass +to `cabal test`. + +### Benchmarks ### + +Benchmark sections (if present) describe benchmarks contained in the package and +must have an argument after the section label, which defines the name of the +benchmark. This is a freeform argument, but may not contain spaces. It should +be unique among the names of the package's other benchmarks, the package's test +suites, the package's executables, and the package itself. Using benchmark +sections requires at least Cabal version 1.9.2. + +The benchmark may be described using the following fields, as well as build +information fields (see the section on [build information](#build-information)). + +`type:` _interface_ (required) +: The interface type and version of the benchmark. At the moment Cabal only + support one benchmark interface, called `exitcode-stdio-1.0`. + +Benchmarks using the `exitcode-stdio-1.0` interface are executables that +indicate failure to run the benchmark with a non-zero exit code when run; they +may provide human-readable information through the standard output and error +channels. + +`main-is:` _filename_ (required: `exitcode-stdio-1.0`) +: The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the + `.hs` filename that must be listed, even if that file is generated + using a preprocessor. The source file must be relative to one of the + directories listed in `hs-source-dirs`. This field is analogous to the + `main-is` field of an executable section. + +#### Example: Package using `exitcode-stdio-1.0` interface #### + +The example package description and executable source file below demonstrate +the use of the `exitcode-stdio-1.0` interface. 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. + +foo.cabal: + +~~~~~~~~~~~~~~~~ +Name: foo +Version: 1.0 +License: BSD3 +Cabal-Version: >= 1.9.2 +Build-Type: Simple + +Benchmark bench-foo + type: exitcode-stdio-1.0 + main-is: bench-foo.hs + build-depends: base, time +~~~~~~~~~~~~~~~~ + +bench-foo.hs: + +~~~~~~~~~~~~~~~~ +{-# LANGUAGE BangPatterns #-} +module Main where + +import Data.Time.Clock + +fib 0 = 1 +fib 1 = 1 +fib n = fib (n-1) + fib (n-2) + +main = do + start <- getCurrentTime + let !r = fib 20 + end <- getCurrentTime + putStrLn $ "fib 20 took " ++ show (diffUTCTime end start) +~~~~~~~~~~~~~~~~ + +#### Running benchmarks #### + +You can have Cabal run your benchmark using its built-in benchmark runner: + +~~~~~~~~~~~~~~~~ +$ cabal configure --enable-benchmarks +$ cabal build +$ cabal bench +~~~~~~~~~~~~~~~~ + +See the output of `cabal help bench` for a list of options you can +pass to `cabal bench`. + +### Build information ### + +The following fields may be optionally present in a library or +executable section, and give information for the building of the +corresponding library or executable. See also the sections on +[system-dependent parameters](#system-dependent-parameters) and +[configurations](#configurations) for a way to supply system-dependent +values for these fields. + +`build-depends:` _package list_ +: A list of packages needed to build this one. Each package can be + annotated with a version constraint. + + Version constraints use the operators `==, >=, >, <, <=` and a + version number. Multiple constraints can be combined using `&&` or + `||`. If no version constraint is specified, any version is assumed + to be acceptable. For example: + + ~~~~~~~~~~~~~~~~ + library + build-depends: + base >= 2, + foo >= 1.2 && < 1.3, + bar + ~~~~~~~~~~~~~~~~ + + Dependencies like `foo >= 1.2 && < 1.3` turn out to be very common + because it is recommended practise for package versions to + correspond to API versions. As of Cabal 1.6, there is a special + syntax to support this use: + + ~~~~~~~~~~~~~~~~ + build-depends: foo ==1.2.* + ~~~~~~~~~~~~~~~~ + + It is only syntactic sugar. It is exactly equivalent to `foo >= 1.2 && < 1.3`. + + Note: Prior to Cabal 1.8, build-depends specified in each section + were global to all sections. This was unintentional, but some packages + were written to depend on it, so if you need your build-depends to + be local to each section, you must specify at least + `Cabal-Version: >= 1.8` in your `.cabal` file. + +`other-modules:` _identifier list_ +: A list of modules used by the component but not exposed to users. + For a library component, these would be hidden modules of the + library. For an executable, these would be auxiliary modules to be + linked with the file named in the `main-is` field. + + Note: Every module in the package *must* be listed in one of + `other-modules`, `exposed-modules` or `main-is` fields. + +`hs-source-dirs:` _directory list_ (default: "`.`") +: Root directories for the module hierarchy. + + For backwards compatibility, the old variant `hs-source-dir` is also + recognized. + +`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. + + Extensions used only by one module may be specified by placing a + `LANGUAGE` pragma in the source file affected, e.g.: + + ~~~~~~~~~~~~~~~~ + {-# LANGUAGE CPP, MultiParamTypeClasses #-} + ~~~~~~~~~~~~~~~~ + + Note: GHC versions prior to 6.6 do not support the `LANGUAGE` pragma. + +`build-tools:` _program list_ +: A list of programs, possibly annotated with versions, needed to + build this package, e.g. `c2hs >= 0.15, cpphs`.If no version + constraint is specified, any version is assumed to be acceptable. + +`buildable:` _boolean_ (default: `True`) +: Is the component buildable? Like some of the other fields below, + this field is more useful with the slightly more elaborate form of + the simple build infrastructure described in the section on + [system-dependent parameters](#system-dependent-parameters). + +`ghc-options:` _token list_ +: Additional options for GHC. You can often achieve the same effect + using the `extensions` field, which is preferred. + + Options required only by one module may be specified by placing an + `OPTIONS_GHC` pragma in the source file affected. + +`ghc-prof-options:` _token list_ +: 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. + +`hugs-options:` _token list_ +: Additional options for Hugs. 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_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. + +`includes:` _filename list_ +: A list of header files to be included in any compilations via C. + This field applies to both header files that are already installed + on the system and to those coming with the package to be installed. + These files typically contain function prototypes for foreign + imports used by the package. + +`install-includes:` _filename list_ +: A list of header files from this package to be installed into + `$libdir/includes` when the package is installed. Files listed in + `install-includes:` should be found in relative to the top of the + source tree or relative to one of the directories listed in + `include-dirs`. + + `install-includes` is typically used to name header files that + contain prototypes for foreign imports used in Haskell code in this + package, for which the C implementations are also provided with the + package. Note that to include them when compiling the package + itself, they need to be listed in the `includes:` field as well. + +`include-dirs:` _directory list_ +: A list of directories to search for header files, when preprocessing + with `c2hs`, `hsc2hs`, `ffihugs`, `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. + +`extra-libraries:` _token list_ +: A list of extra libraries to link with. + +`extra-lib-dirs:` _directory list_ +: A list of directories to search for libraries. + +`cc-options:` _token list_ +: Command-line arguments to be passed to the C compiler. Since the + arguments are compiler-dependent, this field is more useful with the + setup described in the section on [system-dependent + parameters](#system-dependent-parameters). + +`ld-options:` _token list_ +: Command-line arguments to be passed to the linker. Since the + arguments are compiler-dependent, this field is more useful with the + setup described in the section on [system-dependent + parameters](#system-dependent-parameters)>. + +`pkgconfig-depends:` _package list_ +: A list of [pkg-config][] packages, needed to build this package. + They can be annotated with versions, e.g. `gtk+-2.0 >= 2.10, cairo + >= 1.0`. If no version constraint is specified, any version is + assumed to be acceptable. Cabal uses `pkg-config` to find if the + packages are available on the system and to find the extra + compilation and linker options needed to use the packages. + + If you need to bind to a C library that supports `pkg-config` (use + `pkg-config --list-all` to find out if it is supported) then it is + much preferable to use this field rather than hard code options into + the other fields. + +`frameworks:` _token list_ +: On Darwin/MacOS X, a list of frameworks to link to. See Apple's + developer documentation for more details on frameworks. This entry + is ignored on all other platforms. + +### Configurations ### + +Library and executable sections may include conditional +blocks, which test for various system parameters and +configuration flags. The flags mechanism is rather generic, +but most of the time a flag represents certain feature, that +can be switched on or off by the package user. +Here is an example package description file using +configurations: + +#### Example: A package containing a library and executable programs #### + +~~~~~~~~~~~~~~~~ +Name: Test1 +Version: 0.0.1 +Cabal-Version: >= 1.2 +License: BSD3 +Author: Jane Doe +Synopsis: Test package to test configurations +Category: Example + +Flag Debug + Description: Enable debug support + Default: False + +Flag WebFrontend + Description: Include API for web frontend. + -- Cabal checks if the configuration is possible, first + -- with this flag set to True and if not it tries with False + +Library + Build-Depends: base + Exposed-Modules: Testing.Test1 + Extensions: CPP + + if flag(debug) + GHC-Options: -DDEBUG + if !os(windows) + CC-Options: "-DDEBUG" + else + CC-Options: "-DNDEBUG" + + if flag(webfrontend) + Build-Depends: cgi > 0.42 + Other-Modules: Testing.WebStuff + +Executable test1 + Main-is: T1.hs + Other-Modules: Testing.Test1 + Build-Depends: base + + if flag(debug) + CC-Options: "-DDEBUG" + GHC-Options: -DDEBUG +~~~~~~~~~~~~~~~~ + +#### Layout #### + +Flags, conditionals, library and executable sections use layout to +indicate structure. This is very similar to the Haskell layout rule. +Entries in a section have to all be indented to the same level which +must be more than the section header. Tabs are not allowed to be used +for indentation. + +As an alternative to using layout you can also use explicit braces `{}`. +In this case the indentation of entries in a section does not matter, +though different fields within a block must be on different lines. Here +is a bit of the above example again, using braces: + +#### Example: Using explicit braces rather than indentation for layout #### + +~~~~~~~~~~~~~~~~ +Name: Test1 +Version: 0.0.1 +Cabal-Version: >= 1.2 +License: BSD3 +Author: Jane Doe +Synopsis: Test package to test configurations +Category: Example + +Flag Debug { + Description: Enable debug support + Default: False +} + +Library { + Build-Depends: base + Exposed-Modules: Testing.Test1 + Extensions: CPP + if flag(debug) { + GHC-Options: -DDEBUG + if !os(windows) { + CC-Options: "-DDEBUG" + } else { + CC-Options: "-DNDEBUG" + } + } +} +~~~~~~~~~~~~~~~~ + +#### Configuration Flags #### + +A flag section takes the flag name as an argument and may contain the +following fields. + +`description:` _freeform_ +: The description of this flag. + +`default:` _boolean_ (default: `True`) +: The default value of this flag. + + Note that this value may be [overridden in several + ways](#controlling-flag-assignments"). The rationale for having + flags default to True is that users usually want new features as + soon as they are available. Flags representing features that are not + (yet) recommended for most users (such as experimental features or + debugging support) should therefore explicitly override the default + to False. + +`manual:` _boolean_ (default: `False`) +: By default, Cabal will first try to satisfy dependencies with the + default flag value and then, if that is not possible, with the + negated value. However, if the flag is manual, then the default + value (which can be overridden by commandline flags) will be used. + +#### Conditional Blocks #### + +Conditional blocks may appear anywhere inside a library or executable +section. They have to follow rather strict formatting rules. +Conditional blocks must always be of the shape + +~~~~~~~~~~~~~~~~ + `if `_condition_ + _property-descriptions-or-conditionals*_ +~~~~~~~~~~~~~~~~ + +or + +~~~~~~~~~~~~~~~~ + `if `_condition_ + _property-descriptions-or-conditionals*_ + `else` + _property-descriptions-or-conditionals*_ +~~~~~~~~~~~~~~~~ + +Note that the `if` and the condition have to be all on the same line. + +#### Conditions #### + +Conditions can be formed using boolean tests and the boolean operators +`||` (disjunction / logical "or"), `&&` (conjunction / logical "and"), +or `!` (negation / logical "not"). The unary `!` takes highest +precedence, `||` takes lowest. Precedence levels may be overridden +through the use of parentheses. For example, `os(darwin) && !arch(i386) +|| os(freebsd)` is equivalent to `(os(darwin) && !(arch(i386))) || +os(freebsd)`. + +The following tests are currently supported. + +`os(`_name_`)` +: Tests if the current operating system is _name_. The argument is + tested against `System.Info.os` on the target system. There is + unfortunately some disagreement between Haskell implementations + about the standard values of `System.Info.os`. Cabal canonicalises + it so that in particular `os(windows)` works on all implementations. + If the canonicalised os names match, this test evaluates to true, + otherwise false. The match is case-insensitive. + +`arch(`_name_`)` +: Tests if the current architecture is _name_. The argument is + matched against `System.Info.arch` on the target system. If the arch + names match, this test evaluates to true, otherwise false. The match + is case-insensitive. + +`impl(`_compiler_`)` +: Tests for the configured Haskell implementation. An optional version + constraint may be specified (for example `impl(ghc >= 6.6.1)`). If + the configured implementation is of the right type and matches the + version constraint, then this evaluates to true, otherwise false. + The match is case-insensitive. + +`flag(`_name_`)` +: Evaluates to the current assignment of the flag of the given name. + Flag names are case insensitive. Testing for flags that have not + been introduced with a flag section is an error. + +`true` +: Constant value true. + +`false` +: Constant value false. + +#### Resolution of Conditions and Flags #### + +If a package descriptions specifies configuration flags the package user +can [control these in several ways](#controlling-flag-assignments). If +the user does not fix the value of a flag, Cabal will try to find a flag +assignment in the following way. + + * For each flag specified, it will assign its default value, evaluate + all conditions with this flag assignment, and check if all + dependencies can be satisfied. If this check succeeded, the package + will be configured with those flag assignments. + + * If dependencies were missing, the last flag (as by the order in + which the flags were introduced in the package description) is tried + with its alternative value and so on. This continues until either + an assignment is found where all dependencies can be satisfied, or + all possible flag assignments have been tried. + +To put it another way, Cabal does a complete backtracking search to find +a satisfiable package configuration. It is only the dependencies +specified in the `build-depends` field in conditional blocks that +determine if a particular flag assignment is satisfiable (`build-tools` +are not considered). The order of the declaration and the default value +of the flags determines the search order. Flags overridden on the +command line fix the assignment of that flag, so no backtracking will be +tried for that flag. + +If no suitable flag assignment could be found, the configuration phase +will fail and a list of missing dependencies will be printed. Note that +this resolution process is exponential in the worst case (i.e., in the +case where dependencies cannot be satisfied). There are some +optimizations applied internally, but the overall complexity remains +unchanged. + +### Meaning of field values when using conditionals ### + +During the configuration phase, a flag assignment is chosen, all +conditionals are evaluated, and the package description is combined into +a flat package descriptions. If the same field both inside a conditional +and outside then they are combined using the following rules. + + + * Boolean fields are combined using conjunction (logical "and"). + + * List fields are combined by appending the inner items to the outer + items, for example + + ~~~~~~~~~~~~~~~~ + Extensions: CPP + if impl(ghc) || impl(hugs) + Extensions: MultiParamTypeClasses + ~~~~~~~~~~~~~~~~ + + when compiled using Hugs or GHC will be combined to + + ~~~~~~~~~~~~~~~~ + Extensions: CPP, MultiParamTypeClasses + ~~~~~~~~~~~~~~~~ + + Similarly, if two conditional sections appear at the same nesting + level, properties specified in the latter will come after properties + specified in the former. + + * All other fields must not be specified in ambiguous ways. For + example + + ~~~~~~~~~~~~~~~~ + Main-is: Main.hs + if flag(useothermain) + Main-is: OtherMain.hs + ~~~~~~~~~~~~~~~~ + + will lead to an error. Instead use + + ~~~~~~~~~~~~~~~~ + if flag(useothermain) + Main-is: OtherMain.hs + else + Main-is: Main.hs + ~~~~~~~~~~~~~~~~ + +### Source Repositories ### + +It is often useful to be able to specify a source revision control +repository for a package. Cabal lets you specifying this information in +a relatively structured form which enables other tools to interpret and +make effective use of the information. For example the information +should be sufficient for an automatic tool to checkout the sources. + +Cabal supports specifying different information for various common +source control systems. Obviously not all automated tools will support +all source control systems. + +Cabal supports specifying repositories for different use cases. By +declaring which case we mean automated tools can be more useful. There +are currently two kinds defined: + + * The `head` kind refers to the latest development branch of the + package. This may be used for example to track activity of a project + or as an indication to outside developers what sources to get for + making new contributions. + + * The `this` kind refers to the branch and tag of a repository that + contains the sources for this version or release of a package. For most + source control systems this involves specifying a tag, id or hash of + some form and perhaps a branch. The purpose is to be able to + reconstruct the sources corresponding to a particular package + version. This might be used to indicate what sources to get if + someone needs to fix a bug in an older branch that is no longer an + active head branch. + +You can specify one kind or the other or both. As an example here are +the repositories for the Cabal library. Note that the `this` kind of +repo specifies a tag. + +~~~~~~~~~~~~~~~~ +source-repository head + type: darcs + location: http://darcs.haskell.org/cabal/ + +source-repository this + type: darcs + location: http://darcs.haskell.org/cabal-branches/cabal-1.6/ + tag: 1.6.1 +~~~~~~~~~~~~~~~~ + +The exact fields are as follows: + +`type:` _token_ +: The name of the source control system used for this repository. The + currently recognised types are: + + * `darcs` + * `git` + * `svn` + * `cvs` + * `mercurial` (or alias `hg`) + * `bazaar` (or alias `bzr`) + * `arch` + * `monotone` + + This field is required. + +`location:` _URL_ +: The location of the repository. The exact form of this field depends + on the repository type. For example: + + * for darcs: `http://code.haskell.org/foo/` + * for git: `git://github.com/foo/bar.git` + * for CVS: `anoncvs@cvs.foo.org:/cvs` + + This field is required. + +`module:` _token_ +: CVS requires a named module, as each CVS server can host multiple + named repositories. + + This field is required for the CVS repo type and should not be used + otherwise. + +`branch:` _token_ +: Many source control systems support the notion of a branch, as a + distinct concept from having repositories in separate locations. For + example CVS, SVN and git use branches while for darcs uses different + locations for different branches. If you need to specify a branch to + identify a your repository then specify it in this field. + + This field is optional. + +`tag:` _token_ +: A tag identifies a particular state of a source repository. The tag + can be used with a `this` 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. + + This field is required for the `this` repo 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. + + This field is optional. It default to empty which corresponds to the + root directory of the repository. + +## Accessing data files from package code ## + +The placement on the target system of files listed in the `data-files` +field varies between systems, and in some cases one can even move +packages around after installation (see [prefix +independence](#prefix-independence)). To enable packages to find these +files in a portable way, Cabal generates a module called +`Paths_`_pkgname_ (with any hyphens in _pkgname_ replaced by +underscores) during building, so that it may be imported by modules of +the package. This module defines a function + +~~~~~~~~~~~~~~~ +getDataFileName :: FilePath -> IO FilePath +~~~~~~~~~~~~~~~ + +If the argument is a filename listed in the `data-files` field, the +result is the name of the corresponding file on the system on which the +program is running. + +Note: If you decide to import the `Paths_`_pkgname_ module then it +*must* be listed in the `other-modules` field just like any other module +in your package. + +The `Paths_`_pkgname_ module is not platform independent so it does not +get included in the source tarballs generated by `sdist`. + +### Accessing the package version ### + +The aforementioned auto generated `Paths_`_pkgname_ module also +exports the constant `version ::` [Version][data-version] which is +defined as the version of your package as specified in the `version` +field. + +## System-dependent parameters ## + +For some packages, especially those interfacing with C libraries, +implementation details and the build procedure depend on the build +environment. A variant of the simple build infrastructure (the +`build-type` `Configure`) handles many such situations using a slightly +longer `Setup.hs`: + +~~~~~~~~~~~~~~~~ +import Distribution.Simple +main = defaultMainWithHooks autoconfUserHooks +~~~~~~~~~~~~~~~~ + +Most packages, however, would probably do better with +[configurations](#configurations). + +This program differs from `defaultMain` in two ways: + +* The package root directory must contain a shell script called + `configure`. The configure step will run the script. This `configure` + script may be produced by [autoconf][] or may be hand-written. The + `configure` script typically discovers information about the system + and records it for later steps, e.g. by generating system-dependent + header files for inclusion in C source files and preprocessed Haskell + source files. (Clearly this won't work for Windows without MSYS or + Cygwin: other ideas are needed.) + +* If the package root directory contains a file called + _package_`.buildinfo` after the configuration step, subsequent steps + will read it to obtain additional settings for [build + information](#build-information) fields,to be merged with the ones + given in the `.cabal` file. In particular, this file may be generated + by the `configure` script mentioned above, allowing these settings to + vary depending on the build environment. + + The build information file should have the following structure: + + > _buildinfo_ + > + > `executable:` _name_ + > _buildinfo_ + > + > `executable:` _name_ + > _buildinfo_ + > ... + + where each _buildinfo_ consists of settings of fields listed in the + section on [build information](#build-information). The first one (if + present) relates to the library, while each of the others relate to + the named executable. (The names must match the package description, + but you don't have to have entries for all of them.) + +Neither of these files is required. If they are absent, this setup +script is equivalent to `defaultMain`. + +#### Example: Using autoconf #### + +This example is for people familiar with the [autoconf][] tools. + +In the X11 package, the file `configure.ac` contains: + +~~~~~~~~~~~~~~~~ +AC_INIT([Haskell X11 package], [1.1], [libraries@haskell.org], [X11]) + +# Safety check: Ensure that we are in the correct source directory. +AC_CONFIG_SRCDIR([X11.cabal]) + +# Header file to place defines in +AC_CONFIG_HEADERS([include/HsX11Config.h]) + +# Check for X11 include paths and libraries +AC_PATH_XTRA +AC_TRY_CPP([#include ],,[no_x=yes]) + +# Build the package if we found X11 stuff +if test "$no_x" = yes +then BUILD_PACKAGE_BOOL=False +else BUILD_PACKAGE_BOOL=True +fi +AC_SUBST([BUILD_PACKAGE_BOOL]) + +AC_CONFIG_FILES([X11.buildinfo]) +AC_OUTPUT +~~~~~~~~~~~~~~~~ + +Then the setup script will run the `configure` script, which checks for +the presence of the X11 libraries and substitutes for variables in the +file `X11.buildinfo.in`: + +~~~~~~~~~~~~~~~~ +buildable: @BUILD_PACKAGE_BOOL@ +cc-options: @X_CFLAGS@ +ld-options: @X_LIBS@ +~~~~~~~~~~~~~~~~ + +This generates a file `X11.buildinfo` supplying the parameters needed by +later stages: + +~~~~~~~~~~~~~~~~ +buildable: True +cc-options: -I/usr/X11R6/include +ld-options: -L/usr/X11R6/lib +~~~~~~~~~~~~~~~~ + +The `configure` script also generates a header file +`include/HsX11Config.h` containing C preprocessor defines recording the +results of various tests. This file may be included by C source files +and preprocessed Haskell source files in the package. + +Note: Packages using these features will also need to list +additional files such as `configure`, +templates for `.buildinfo` files, files named +only in `.buildinfo` files, header files and +so on in the `extra-source-files` field, +to ensure that they are included in source distributions. +They should also list files and directories generated by +`configure` in the +`extra-tmp-files` field to ensure that they +are removed by `setup clean`. + +## Conditional compilation ## + +Sometimes you want to write code that works with more than one version +of a dependency. You can specify a range of versions for the depenency +in the `build-depends`, but how do you then write the code that can use +different versions of the API? + +Haskell lets you preprocess your code using the C preprocessor (either +the real C preprocessor, or `cpphs`). To enable this, add `extensions: +CPP` to your package description. When using CPP, Cabal provides some +pre-defined macros to let you test the version of dependent packages; +for example, suppose your package works with either version 3 or version +4 of the `base` package, you could select the available version in your +Haskell modules like this: + +~~~~~~~~~~~~~~~~ +#if MIN_VERSION_base(4,0,0) +... code that works with base-4 ... +#else +... code that works with base-3 ... +#endif +~~~~~~~~~~~~~~~~ + +In general, Cabal supplies a macro `MIN_VERSION_`_`package`_`_(A,B,C)` +for each package depended on via `build-depends`. This macro is true if +the actual version of the package in use is greater than or equal to +`A.B.C` (using the conventional ordering on version numbers, which is +lexicographic on the sequence, but numeric on each component, so for +example 1.2.0 is greater than 1.0.3). + +Cabal places the definitions of these macros into an +automatically-generated header file, which is included when +preprocessing Haskell source code by passing options to the C +preprocessor. + +## More complex packages ## + +For packages that don't fit the simple schemes described above, you have +a few options: + + * You can customize the simple build infrastructure using _hooks_. + These allow you to perform additional actions before and after each + command is run, and also to specify additional preprocessors. See + `UserHooks` in [Distribution.Simple][dist-simple] for the details, + but note that this interface is experimental, and likely to change + in future releases. + + * You could delegate all the work to `make`, though this is unlikely + to be very portable. Cabal supports this with the `build-type` + `Make` and a trivial setup library [Distribution.Make][dist-make], + which simply parses the command line arguments and invokes `make`. + Here `Setup.hs` looks like + + ~~~~~~~~~~~~~~~~ + import Distribution.Make + main = defaultMain + ~~~~~~~~~~~~~~~~ + + The root directory of the package should contain a `configure` + script, and, after that has run, a `Makefile` with a default target + that builds the package, plus targets `install`, `register`, + `unregister`, `clean`, `dist` and `docs`. Some options to commands + are passed through as follows: + + * The `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, + `--datadir` and `--libexecdir` options to the `configure` + command are passed on to the `configure` script. In addition the + value of the `--with-compiler` option is passed in a `--with-hc` + option and all options specified with `--configure-option=` are + passed on. + + * The `--destdir` option to the `copy` command becomes a setting + of a `destdir` variable on the invocation of `make copy`. The + supplied `Makefile` should provide a `copy` target, which will + probably look like this: + + ~~~~~~~~~~~~~~~~ + copy : + $(MAKE) install prefix=$(destdir)/$(prefix) \ + bindir=$(destdir)/$(bindir) \ + libdir=$(destdir)/$(libdir) \ + datadir=$(destdir)/$(datadir) \ + libexecdir=$(destdir)/$(libexecdir) + ~~~~~~~~~~~~~~~~ + + * You can write your own setup script conforming to the interface + described in the section on [building and installing + packages](#building-and-installing-a-package), possibly using the + Cabal library for 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 +[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/ +[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/ diff --git a/cabal/Cabal/doc/index.markdown b/cabal/Cabal/doc/index.markdown new file mode 100644 --- /dev/null +++ b/cabal/Cabal/doc/index.markdown @@ -0,0 +1,169 @@ +% Cabal User Guide + +Cabal is package system for [Haskell] software. + +Cabal specifies a standard way in which Haskell libraries and +applications can be packaged so that it is easy for consumers to use +them, or re-package them, regardless of the Haskell implementation or +installation platform. + +Cabal defines a common interface -- the _Cabal package_ -- between +package authors, builders and users. There is a library to help package +authors implement this interface, and a tool to enable developers, +builders and users to work with Cabal packages. + +# Contents # + + * [Introduction](#introduction) + - [What's in a package](#whats-in-a-package) + - [A tool for working with packages](#a-tool-for-working-with-packages) + * [Developing packages](developing-packages.html) + - [Package descriptions](developing-packages.html#package-descriptions) + + [Package properties](developing-packages.html#package-properties) + + [Library](developing-packages.html#library) + + [Executables](developing-packages.html#executables) + + [Test suites](developing-packages.html#test-suites) + + [Build information](developing-packages.html#build-information) + + [Configurations](developing-packages.html#configurations) + + [Source Repositories](developing-packages.html#source-repositories) + - [Accessing data files from package code](developing-packages.html#accessing-data-files-from-package-code) + + [Accessing the package version](developing-packages.html#accessing-the-package-version) + - [System-dependent parameters](developing-packages.html#system-dependent-parameters) + - [Conditional compilation](developing-packages.html#conditional-compilation) + - [More complex packages](developing-packages.html#more-complex-packages) + * [Building and installing packages](installing-packages.html) + - [Building and installing a system package](installing-packages.html#building-and-installing-a-system-package) + - [Building and installing a user package](installing-packages.html#building-and-installing-a-user-package) + - [Creating a binary package](installing-packages.html#creating-a-binary-package) + - [setup configure](installing-packages.html#setup-configure) + + [Programs used for building](installing-packages.html#programs-used-for-building) + + [Installation paths](installing-packages.html#installation-paths) + + [Controlling Flag Assignments](installing-packages.html#controlling-flag-assignments) + + [Building Test Suites](installing-packages.html#building-test-suites) + + [Miscellaneous options](installing-packages.html#miscellaneous-options) + - [setup build](installing-packages.html#setup-build) + - [setup haddock](installing-packages.html#setup-haddock) + - [setup hscolour](installing-packages.html#setup-hscolour) + - [setup install](installing-packages.html#setup-install) + - [setup copy](installing-packages.html#setup-copy) + - [setup register](installing-packages.html#setup-register) + - [setup unregister](installing-packages.html#setup-unregister) + - [setup clean](installing-packages.html#setup-clean) + - [setup test](installing-packages.html#setup-test) + - [setup sdist](installing-packages.html#setup-sdist) + * [Reporting bugs and deficiencies](misc.html#reporting-bugs-and-deficiencies) + * [Stability of Cabal interfaces](misc.html#stability-of-cabal-interfaces) + - [Cabal file format](misc.html#cabal-file-format) + - [Command-line interface](misc.html#command-line-interface) + + [Very Stable Command-line interfaces](misc.html#very-stable-command-line-interfaces) + + [Stable Command-line interfaces](misc.html#stable-command-line-interfaces) + + [Unstable command-line](misc.html#unstable-command-line) + - [Functions and Types](misc.html#functions-and-types) + + [Very Stable API](misc.html#very-stable-api) + + [Semi-stable API](misc.html#semi-stable-api) + + [Unstable API](#unstable-api) + - [Hackage](misc.html#hackage) + +# Introduction # + +Cabal is package system for Haskell software. The point of a packaging +system is to enable software developers and users to easily distribute, +use and reuse software. A good packaging system makes it easier for +developers to get their software into the hands of users, but equally +importantly it makes it easier for software developers to be able to +reuse software components written by other developers. + +Packaging systems deal with packages and with Cabal we call them _Cabal +packages_. The Cabal package is the unit of distribution. Every Cabal +package has a name and a version number which are used to identify the +package, e.g. `filepath-1.0`. + +Cabal packages are source based and are typically (but not necessarily) +portable to many platforms and Haskell implementations. The Cabal +package format is designed to make it possible to translate into other +formats, including binary packages for various systems. + +When distributed, Cabal packages use the standard compressed tarball +format, with the file extension `.tar.gz`, e.g. `filepath-1.0.tar.gz`. + +Note that packages are not part of the Haskell language, but most +Haskell implementations have some notion of package, and Cabal supports +most Haskell implementations. + + +## What's in a package ## + +A Cabal package consists of: + + * Haskell software, including libraries, executables and tests + * meta-data about the package in a standard human and machine + readable format (the "`.cabal`" file) + * a standard interface to build the package (the "`Setup.hs`" file) + +The `.cabal` file contains information about the package, supplied by +the package author. Some of this information is used for identifying and +managing the package when it comes to distribution. + +For the majority of packages it is possible to supply enough information +in the `.cabal` file so that it can be built without the package author +needing to write any extra build system scripts. For complex packages it +may be necessary to add code to the `Setup.hs` file. + +Here is an example `foo.cabal` for a very simple Haskell library that +exposes one Haskell module called `Data.Foo`: + +~~~~~~~~~~~~~~~~ +name: foo +version: 1.0 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Data.Foo + build-depends: base >= 3 && < 5 +~~~~~~~~~~~~~~~~ + +For full details on what goes in the `.cabal` and `Setup.hs` files, and +for all the other features provided by the build system, see the section +on [developing packages](developing-packages.html). + + +## A tool for working with packages ## + +There is a command line tool, called `cabal`, that users and developers +can use to install Cabal packages. It can be used for both local +packages and for packages available remotely over the network. + +Developers can use the tool with packages in local directories, e.g. + +~~~~~~~~~~~~~~~~ +cd foo/ +cabal install +~~~~~~~~~~~~~~~~ + +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 centeralised Haskell community archive called [Hackage] but it +is possible to use it with any other suitable archive. + +~~~~~~~~~~~~~~~~ +cabal install xmonad +~~~~~~~~~~~~~~~~ + +This will install the `xmonad` package plus all of its dependencies. + +Cabal provides a number of ways for a user to customise how and where a +package is installed. They can decide where a package will be installed, +which Haskell implementation to use and whether to build optimised code +or build with the ability to profile code. It is not expected that users +will have to modify any of the information in the `.cabal` file. + +For full details, see the section on [building and installing +packages](installing-packages.html). + +Note that `cabal` is not the only tool for working with Cabal packages. +Due to the standardised format and a library for reading `.cabal` files, +there are several other special-purpose tools. + +[Haskell]: http://www.haskell.org/ +[Hackage]: http://hackage.haskell.org/ diff --git a/cabal/Cabal/doc/installing-packages.markdown b/cabal/Cabal/doc/installing-packages.markdown new file mode 100644 --- /dev/null +++ b/cabal/Cabal/doc/installing-packages.markdown @@ -0,0 +1,809 @@ +% Cabal User Guide + + +# Building and installing packages # + +After you've unpacked a Cabal package, you can build it by moving into +the root directory of the package and using the `Setup.hs` or +`Setup.lhs` script there: + +> `_runhaskell_ Setup.hs` [_command_] [_option_...] + +The _command_ argument selects a particular step in the build/install +process. You can also get a summary of the command syntax with + +> `runhaskell Setup.hs --help` + +## Building and installing a system package ## + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs configure --ghc +runhaskell Setup.hs build +runhaskell Setup.hs install +~~~~~~~~~~~~~~~~ + +The first line readies the system to build the tool using GHC; for +example, it checks that GHC exists on the system. The second line +performs the actual building, while the last both copies the build +results to some permanent place and registers the package with GHC. + +## Building and installing a user package ## + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs configure --user +runhaskell Setup.hs build +runhaskell Setup.hs install +~~~~~~~~~~~~~~~~ + +The package is installed under the user's home directory and is +registered in the user's package database (`--user`). + +## Creating a binary package ## + +When creating binary packages (e.g. for RedHat or Debian) one needs to +create a tarball that can be sent to another system for unpacking in the +root directory: + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs configure --prefix=/usr +runhaskell Setup.hs build +runhaskell Setup.hs copy --destdir=/tmp/mypkg +tar -czf mypkg.tar.gz /tmp/mypkg/ +~~~~~~~~~~~~~~~~ + +If the package contains a library, you need two additional steps: + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs register --gen-script +runhaskell Setup.hs unregister --gen-script +~~~~~~~~~~~~~~~~ + +This creates shell scripts `register.sh` and `unregister.sh`, which must +also be sent to the target system. After unpacking there, the package +must be registered by running the `register.sh` script. The +`unregister.sh` script would be used in the uninstall procedure of the +package. Similar steps may be used for creating binary packages for +Windows. + + +The following options are understood by all commands: + +`--help`, `-h` or `-?` +: List the available options for the command. + +`--verbose=`_n_ or `-v`_n_ +: Set the verbosity level (0-3). The normal level is 1; a missing _n_ + defaults to 2. + +The various commands and the additional options they support are +described below. In the simple build infrastructure, any other options +will be reported as errors. + +## setup configure ## + +Prepare to build the package. Typically, this step checks that the +target platform is capable of building the package, and discovers +platform-specific features that are needed during the build. + +The user may also adjust the behaviour of later stages using the options +listed in the following subsections. In the simple build +infrastructure, the values supplied via these options are recorded in a +private file read by later stages. + +If a user-supplied `configure` script is run (see the section on +[system-dependent parameters](#system-dependent-parameters) or on +[complex packages](#complex-packages)), it is passed the +`--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, `--datadir` and +`--libexecdir` 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` +: Specify which Haskell implementation to use to build the package. + At most one of these flags may be given. If none is given, the + implementation under which the setup script was compiled or + interpreted is used. + +`--with-compiler=`_path_ or `-w`_path_ +: Specify the path to a particular compiler. If given, this must match + the implementation selected above. The default is to search for the + usual name of the selected implementation. + + This flag also sets the default value of the `--with-hc-pkg` option + to the package tool for this compiler. Check the output of `setup + configure -v` to ensure that it finds the right package tool (or use + `--with-hc-pkg` explicitly). + + +`--with-hc-pkg=`_path_ +: Specify the path to the package tool, e.g. `ghc-pkg`. The package + tool must be compatible with the compiler specified by + `--with-compiler`. If this option is omitted, the default value is + determined from the compiler selected. + +`--with-`_`prog`_`=`_path_ +: Specify the path to the program _prog_. Any program known to Cabal + can be used in place of _prog_. It can either be a fully path or the + name of a program that can be found on the program search path. For + example: `--with-ghc=ghc-6.6.1` or + `--with-cpphs=/usr/local/bin/cpphs`. + +`--`_`prog`_`-options=`_options_ +: Specify additional options to the program _prog_. Any program known + to Cabal can be used in place of _prog_. For example: + `--alex-options="--template=mytemplatedir/"`. The _options_ is split + into program options based on spaces. Any options containing embeded + spaced need to be quoted, for example + `--foo-options='--bar="C:\Program File\Bar"'`. As an alternative + that takes only one option at a time but avoids the need to quote, + use `--`_`prog`_`-option` instead. + +`--`_`prog`_`-option=`_option_ +: Specify a single additional option to the program _prog_. For + passing an option that contain embeded spaces, such as a file name + with embeded spaces, using this rather than `--`_`prog`_`-options` + means you do not need an additional level of quoting. Of course if + you are using a command shell you may still need to quote, for + example `--foo-options="--bar=C:\Program File\Bar"`. + +All of the options passed with either `--`_`prog`_`-options` or +`--`_`prog`_`-option` are passed in the order they were specified on the +configure command line. + +### Installation paths ### + +The following options govern the location of installed files from a +package: + +`--prefix=`_dir_ +: The root of the installation. For example for a global install you + might use `/usr/local` on a Unix system, or `C:\Program Files` on a + Windows system. The other installation paths are usually + subdirectories of _prefix_, but they don't have to be. + + In the simple build system, _dir_ may contain the following path + variables: `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, + `$arch` + +`--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` + +`--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` + +`--libexecdir=`_dir_ +: Executables that are not expected to be invoked directly by the user + are installed here. + + In the simple build system, _dir_ may contain the following path + variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, + `$pkg`, `$version`, `$compiler`, `$os`, `$arch` + +`--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` + +In addition the simple build system supports the following installation path options: + +`--libsubdir=`_dir_ +: A subdirectory of _libdir_ in which libraries are actually + installed. For example, in the simple build system on Unix, the + default _libdir_ is `/usr/local/lib`, and _libsubdir_ contains the + package identifier and compiler, e.g. `mypkg-0.2/ghc-6.4`, so + libraries would be installed in `/usr/local/lib/mypkg-0.2/ghc-6.4`. + + _dir_ may contain the following path variables: `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch` + +`--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` + +`--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` + +`--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` + +`--program-prefix=`_prefix_ +: Prepend _prefix_ to installed program names. + + _prefix_ may contain the following path variables: `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch` + +`--program-suffix=`_suffix_ +: Append _suffix_ to installed program names. The most obvious use for + this is to append the program's version number to make it possible + to install several versions of a program at once: + `--program-suffix='$version'`. + + _suffix_ may contain the following path variables: `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch` + +#### Path variables in the simple build system #### + +For the simple build system, there are a number of variables that can be +used when specifying installation paths. The defaults are also specified +in terms of these variables. A number of the variables are actually for +other paths, like `$prefix`. This allows paths to be specified relative +to each other rather than as absolute paths, which is important for +building relocatable packages (see [prefix +independence](#prefix-independence)). + +`$prefix` +: The path variable that stands for the root of the installation. For + an installation to be relocatable, all other instllation paths must + be relative to the `$prefix` variable. + +`$bindir` +: The path variable that expands to the path given by the `--bindir` + configure option (or the default). + +`$libdir` +: As above but for `--libdir` + +`$libsubdir` +: As above but for `--libsubdir` + +`$datadir` +: As above but for `--datadir` + +`$datasubdir` +: As above but for `--datasubdir` + +`$docdir` +: As above but for `--docdir` + +`$pkgid` +: The name and version of the package, eg `mypkg-0.2` + +`$pkg` +: The name of the package, eg `mypkg` + +`$version` +: The version of the package, eg `0.2` + +`$compiler` +: The compiler being used to build the package, eg `ghc-6.6.1` + +`$os` +: The operating system of the computer being used to build the + package, eg `linux`, `windows`, `osx`, `freebsd` or `solaris` + +`$arch` +: The architecture of the computer being used to build the package, eg + `i386`, `x86_64`, `ppc` or `sparc` + +#### Paths in the simple build system #### + +For the simple build system, the following defaults apply: + +Option Windows Default Unix Default +------- ---------------- ------------- +`--prefix` (global) `C:\Program Files\Haskell` `/usr/local` +`--prefix` (per-user) `C:\Documents And Settings\user\Application Data\cabal` `$HOME/.cabal` +`--bindir` `$prefix\bin` `$prefix/bin` +`--libdir` `$prefix` `$prefix/lib` +`--libsubdir` (Hugs) `hugs\packages\$pkg` `hugs/packages/$pkg` +`--libsubdir` (others) `$pkgid\$compiler` `$pkgid/$compiler` +`--libexecdir` `$prefix\$pkgid` `$prefix/libexec` +`--datadir` (executable) `$prefix` `$prefix/share` +`--datadir` (library) `C:\Program Files\Haskell` `$prefix/share` +`--datasubdir` `$pkgid` `$pkgid` +`--docdir` `$prefix\doc\$pkgid` `$datadir/doc/$pkgid` +`--htmldir` `$docdir\html` `$docdir/html` +`--program-prefix` (empty) (empty) +`--program-suffix` (empty) (empty) + + +#### 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. + +In order to achieve this, we require that for an executable on Windows, +all of `$bindir`, `$libdir`, `$datadir` and `$libexecdir` begin with +`$prefix`. If this is not the case then the compiled executable will +have baked-in all absolute paths. + +The application need do nothing special to achieve prefix-independence. +If it finds any files using `getDataFileName` and the [other functions +provided for the purpose](#accessing-data-files-from-package-code), the +files will be accessed relative to the location of the current +executable. + +A library cannot (currently) be prefix-independent, because it will be +linked into an executable whose file system location bears no relation +to the library package. + +### Controlling Flag Assignments ### + +Flag assignments (see the [resolution of conditions and +flags](#resolution-of-conditions-and-flags)) can be controlled with the +followingcommand line options. + +`-f` _flagname_ or `-f` `-`_flagname_ +: Force the specified flag to `true` or `false` (if preceded with a `-`). Later + specifications for the same flags will override earlier, i.e., + specifying `-fdebug -f-debug` is equivalent to `-f-debug` + +`--flags=`_flagspecs_ +: Same as `-f`, but allows specifying multiple flag assignments at + once. The parameter is a space-separated list of flag names (to + force a flag to `true`), optionally preceded by a `-` (to force a + flag to `false`). For example, `--flags="debug -feature1 feature2"` is + equivalent to `-fdebug -f-feature1 -ffeature2`. + +### Building Test Suites ### + +`--enable-tests` +: Build the test suites defined in the package description file during the + `build` stage. Check for dependencies required by the test suites. If the + package is configured with this option, it will be possible to run the test + suites with the `test` command after the package is built. + +`--disable-tests` +: (default) Do not build any test suites during the `build` stage. + Do not check for dependencies required only by the test suites. It will not + be possible to invoke the `test` command without reconfiguring the package. + +### Miscellaneous options ## + +`--user` +: Does a per-user installation. This changes the [default installation + prefix](#paths-in-the-simple-build-system). It also allow + dependencies to be satisfied by the user's package database, in + addition to the global database. This also implies a default of + `--user` for any subsequent `install` command, as packages + registered in the global database should not depend on packages + registered in a user's database. + +`--global` +: (default) Does a global installation. In this case package + dependencies must be satisfied by the global package database. All + packages in the user's package database will be ignored. Typically + the final instllation step will require administrative privileges. + +`--package-db=`_db_ +: Allows package dependencies to be satisfied from this additional + package database _db_ in addition to the global package database. + All packages in the user's package database will be ignored. The + interpretation of _db_ is implementation-specific. Typically it will + be a file or directory. Not all implementations support arbitrary + package databases. + +`--enable-optimization`[=_n_] or `-O`[_n_] +: (default) Build with optimization flags (if available). This is + appropriate for production use, taking more time to build faster + libraries and programs. + + The optional _n_ value is the optimisation level. Some compilers + support multiple optimisation levels. The range is 0 to 2. Level 0 + is equivalent to `--disable-optimization`, level 1 is the default if + no _n_ parameter is given. Level 2 is higher optimisation if the + compiler supports it. Level 2 is likely to lead to longer compile + times and bigger generated code. + +`--disable-optimization` +: Build without optimization. This is suited for development: building + will be quicker, but the resulting library or programs will be slower. + +`--enable-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). + +`--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. + +`--disable-executable-profiling` +: (default) Do not enable profiling in generated executables. + +`--enable-library-vanilla` +: (default) Build ordinary libraries (as opposed to profiling + libraries). This is independent of the `--enable-library-profiling` + option. If you enable both, you get both. + +`--disable-library-vanilla` +: Do not build ordinary libraries. This is useful in conjunction with + `--enable-library-profiling` to build only profiling libraries, + rather than profiling and ordinary libraries. + +`--enable-library-for-ghci` +: (default) Build libraries suitable for use with GHCi. + +`--disable-library-for-ghci` +: Not all platforms support GHCi and indeed on some platforms, trying + to build GHCi libs fails. In such cases this flag can be used as a + workaround. + +`--enable-split-objs` +: Use the GHC `-split-objs` feature when building the library. This + reduces the final size of the executables that use the library by + allowing them to link with only the bits that they use rather than + the entire library. The downside is that building the library takes + longer and uses considerably more memory. + +`--disable-split-objs` +: (default) Do not use the GHC `-split-objs` feature. This makes + building the library quicker but the final executables that use the + library will be larger. + +`--enable-executable-stripping` +: (default) When installing binary executable programs, run the + `strip` program on the binary. This can considerably reduce the size + of the executable binary file. It does this by removing debugging + information and symbols. While such extra information is useful for + debugging C programs with traditional debuggers it is rarely helpful + for debugging binaries produced by Haskell compilers. + + Not all Haskell implementations generate native binaries. For such + implementations this option has no effect. + +`--disable-executable-stripping` +: Do not strip binary executables during installation. You might want + to use this option if you need to debug a program using gdb, for + example if you want to debug the C parts of a program containing + both Haskell and C code. Another reason is if your are building a + package for a system which has a policy of managing the stripping + itself (such as some linux distributions). + +`--enable-shared` +: Build shared library. This implies a seperate compiler run to + generate position independent code as required on most platforms. + +`--disable-shared` +: (default) Do not build shared library. + +`--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. + +`--extra-include-dirs`[=_dir_] +: An extra directory to search for C header files. You can use this + flag multiple times to get a list of directories. + + You might need to use this flag if you have standard system header + files in a non-standard location that is not mentioned in the + package's `.cabal` file. Using this option has the same affect as + appending the directory _dir_ to the `include-dirs` field in each + library and executable in the package's `.cabal` file. The advantage + of course is that you do not have to modify the package at all. + These extra directories will be used while building the package and + for libraries it is also saved in the package registration + information and used when compiling modules that use the library. + +`--extra-lib-dirs`[=_dir_] +: An extra directory to search for system libraries files. You can use + this flag multiple times to get a list of directories. + + You might need to use this flag if you have standard system + libraries in a non-standard location that is not mentioned in the + package's `.cabal` file. Using this option has the same affect as + appending the directory _dir_ to the `extra-lib-dirs` field in each + library and executable in the package's `.cabal` file. The advantage + of course is that you do not have to modify the package at all. + These extra directories will be used while building the package and + for libraries it is also saved in the package registration + information and used when compiling modules that use the library. + +In the simple build infrastructure, an additional option is recognized: + +`--scratchdir=`_dir_ +: Specify the directory into which the Hugs output will be placed + (default: `dist/scratch`). + +## setup build ## + +Perform any preprocessing or compilation needed to make this package ready for installation. + +This command takes the following options: + +--_prog_-options=_options_, --_prog_-option=_option_ +: These are mostly the same as the [options configure + step](#setup-configure). Unlike the options specified at the + configure step, any program options specified at the build step are + not persistent but are used for that invocation only. They options + specified at the build step are in addition not in replacement of + any options specified at the configure step. + +## setup haddock ## + +Build the documentation for the package using [haddock][]. By default, +only the documentation for the exposed modules is generated (but see the +`--executables` and `--internal` flags below). + +This command takes the following options: + +`--hoogle` +: Generate a file `dist/doc/html/`_pkgid_`.txt`, which can be + converted by [Hoogle](http://www.haskell.org/hoogle/) into a + database for searching. This is equivalent to running [haddock][] + with the `--hoogle` flag. + +`--html-location=`_url_ +: Specify a template for the location of HTML documentation for + prerequisite packages. The substitutions ([see + listing](#paths-in-the-simple-build-system)) are applied to the + template to obtain a location for each package, which will be used + by hyperlinks in the generated documentation. For example, the + following command generates links pointing at [Hackage] pages: + + > setup haddock --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' + + Here the argument is quoted to prevent substitution by the shell. If + this option is omitted, the location for each package is obtained + using the package tool (e.g. `ghc-pkg`). + +`--executables` +: Also run [haddock][] for the modules of all the executable programs. + By default [haddock][] is run only on the exported modules. + +`--internal` +: Run [haddock][] for the all modules, including unexposed ones, and + make [haddock][] generate documentation for unexported symbols as + well. + +`--css=`_path_ +: The argument _path_ denotes a CSS file, which is passed to + [haddock][] and used to set the style of the generated + documentation. This is only needed to override the default style + that [haddock][] uses. + +`--hyperlink-source` +: Generate [haddock][] documentation integrated with [HsColour][]. + First, [HsColour][] is run to generate colourised code. Then + [haddock][] is run to generate HTML documentation. Each entity + shown in the documentation is linked to its definition in the + colourised code. + +`--hscolour-css=`_path_ +: The argument _path_ denotes a CSS file, which is passed to [HsColour][] as in + + > runhaskell Setup.hs hscolour --css=_path_ + +## setup hscolour ## + +Produce colourised code in HTML format using [HsColour][]. Colourised +code for exported modules is put in `dist/doc/html/`_pkgid_`/src`. + +This command takes the following options: + +`--executables` +: Also run [HsColour][] on the sources of all executable programs. + Colourised code is put in `dist/doc/html/`_pkgid_/_executable_`/src`. + +`--css=`_path_ +: Use the given CSS file for the generated HTML files. The CSS file + defines the colours used to colourise code. Note that this copies + the given CSS file to the directory with the generated HTML files + (renamed to `hscolour.css`) rather than linking to it. + +## setup install ## + +Copy the files into the install locations and (for library packages) +register the package with the compiler, i.e. make the modules it +contains available to programs. + +The [install locations](#installation-paths) are determined by options +to `setup configure`. + +This command takes the following options: + +`--global` +: Register this package in the system-wide database. (This is the + default, unless the `--user` option was supplied to the `configure` + command.) + +`--user` +: Register this package in the user's local package database. (This is + the default if the `--user` option was supplied to the `configure` + command.) + +## setup copy ## + +Copy the files without registering them. This command is mainly of use +to those creating binary packages. + +This command takes the following option: + +`--destdir=`_path_ + +Specify the directory under which to place installed files. If this is +not given, then the root directory is assumed. + +## setup register ## + +Register this package with the compiler, i.e. make the modules it +contains available to programs. This only makes sense for library +packages. Note that the `install` command incorporates this action. The +main use of this separate command is in the post-installation step for a +binary package. + +This command takes the following options: + +`--global` +: Register this package in the system-wide database. (This is the default.) + + +`--user` +: Register this package in the user's local package database. + + +`--gen-script` +: Instead of registering the package, generate a script containing + commands to perform the registration. On Unix, this file is called + `register.sh`, on Windows, `register.bat`. This script might be + included in a binary bundle, to be run after the bundle is unpacked + on the target system. + +`--gen-pkg-config`[=_path_] +: Instead of registering the package, generate a package registration + file. This only applies to compilers that support package + registration files which at the moment is only GHC. The file should + be used with the compiler's mechanism for registering packages. This + option is mainly intended for packaging systems. If possible use the + `--gen-script` option instead since it is more portable across + Haskell implementations. The _path_ is + optional and can be used to specify a particular output file to + generate. Otherwise, by default the file is the package name and + version with a `.conf` extension. + +`--inplace` +: Registers the package for use directly from the build tree, without + needing to install it. This can be useful for testing: there's no + need to install the package after modifying it, just recompile and + test. + + This flag does not create a build-tree-local package database. It + still registers the package in one of the user or global databases. + + However, there are some caveats. It only works with GHC + (currently). It only works if your package doesn't depend on having + any supplemental files installed --- plain Haskell libraries should + be fine. + +## setup unregister ## + +Deregister this package with the compiler. + +This command takes the following options: + +`--global` +: Deregister this package in the system-wide database. (This is the default.) + +`--user` +: Deregister this package in the user's local package database. + +`--gen-script` +: Instead of deregistering the package, generate a script containing + commands to perform the deregistration. On Unix, this file is + called `unregister.sh`, on Windows, `unregister.bat`. This script + might be included in a binary bundle, to be run on the target + system. + +## setup clean ## + +Remove any local files created during the `configure`, `build`, +`haddock`, `register` or `unregister` steps, and also any files and +directories listed in the `extra-tmp-files` field. + +This command takes the following options: + +`--save-configure` or `-s` +: Keeps the configuration information so it is not necessary to run + the configure step again before building. + +## setup test ## + +Run the test suites specified in the package description file. Aside from +the following flags, Cabal accepts the name of one or more test suites on the +command line after `test`. When supplied, Cabal will run only the named test +suites, otherwise, Cabal will run all test suites in the package. + +`--builddir=`_dir_ +: The directory where Cabal puts generated build files (default: `dist`). + Test logs will be located in the `test` subdirectory. + +`--human-log=`_path_ +: The template used to name human-readable test logs; the path is relative + to `dist/test`. By default, logs are named according to the template + `$pkgid-$test-suite.log`, so that each test suite will be logged to its own + human-readable log file. Template variables allowed are: `$pkgid`, + `$compiler`, `$os`, `$arch`, `$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`. + +`--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). + +`--test-options=`_options_ +: Give extra options to the test executables. + +`--test-option=`_option_ +: give an extra option to the test executables. There is no need to quote + options containing spaces because a single option is assumed, so options + will not be split on spaces. + +## setup sdist ## + +Create a system- and compiler-independent source distribution in a file +_package_-_version_`.tar.gz` in the `dist` subdirectory, for +distribution to package builders. When unpacked, the commands listed in +this section will be available. + +The files placed in this distribution are the package description file, +the setup script, the sources of the modules named in the package +description file, and files named in the `license-file`, `main-is`, +`c-sources`, `data-files` and `extra-source-files` fields. + +This command takes the following option: + +`--snapshot` +: Append today's date (in "YYYYMMDD" format) to the version number for + the generated source package. The original package is unaffected. + + +[dist-simple]: ../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 +[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/ +[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/ diff --git a/cabal/Cabal/doc/misc.markdown b/cabal/Cabal/doc/misc.markdown new file mode 100644 --- /dev/null +++ b/cabal/Cabal/doc/misc.markdown @@ -0,0 +1,109 @@ +% Cabal User Guide + +# Reporting bugs and deficiencies # + +Please report any flaws or feature requests in the [bug tracker][]. + +For general discussion or queries email the libraries mailing list +. There is also a development mailing list +. + +[bug tracker]: http://hackage.haskell.org/trac/hackage/ + +# Stability of Cabal interfaces # + +The Cabal library and related infrastructure is still under active +development. New features are being added and limitations and bugs are +being fixed. This requires internal changes and often user visible +changes as well. We therefor cannot promise complete future-proof +stability, at least not without halting all development work. + +This section documents the aspects of the Cabal interface that we can +promise to keep stable and which bits are subject to change. + +## Cabal file format ## + +This is backwards compatible and mostly forwards compatible. New fields +can be added without breaking older versions of Cabal. Fields can be +deprecated without breaking older packages. + +## Command-line interface ## + +### Very Stable Command-line interfaces ### + +* `./setup configure` + * `--prefix` + * `--user` + * `--ghc`, `--hugs` + * `--verbose` + * `--prefix` + +* `./setup build` +* `./setup install` +* `./setup register` +* `./setup copy` + +### Stable Command-line interfaces ### + +### Unstable command-line ### + +## Functions and Types ## + +The Cabal library follows the [Package Versioning Policy][PVP]. This +means that within a stable major release, for example 1.2.x, there will +be no incompatible API changes. But minor versions increments, for +example 1.2.3, indicate compatible API additions. + +The Package Versioning Policy does not require any API guarantees +between major releases, for example between 1.2.x and 1.4.x. In practise +of course not everything changes between major releases. Some parts of +the API are more prone to change than others. The rest of this section +gives some informal advice on what level of API stability you can expect +between major releases. + +[PVP]: http://haskell.org/haskellwiki/Package_versioning_policy + +### Very Stable API ### + +* `defaultMain` + +* `defaultMainWithHooks defaultUserHooks` + + But regular `defaultMainWithHooks` isn't stable since `UserHooks` + changes. + +### Semi-stable API ### + +* `UserHooks` The hooks API will change in the future + +* `Distribution.*` is mostly declarative information about packages and + is somewhat stable. + +### Unstable API ### + +Everything under `Distribution.Simple.*` has no stability guarantee. + +## Hackage ## + +The index format is a partly stable interface. It consists of a tar.gz +file that contains directories with `.cabal` files in. In future it may +contain more kinds of files so do not assume every file is a `.cabal` +file. Incompatible revisions to the format would involve bumping the +name of the index file, i.e., `00-index.tar.gz`, `01-index.tar.gz` etc. + + +[dist-simple]: ../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 +[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/ +[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/ diff --git a/cabal/Cabal/prologue.txt b/cabal/Cabal/prologue.txt new file mode 100644 --- /dev/null +++ b/cabal/Cabal/prologue.txt @@ -0,0 +1,7 @@ +The Haskell Cabal is the Common Architecture for Building Applications +and Libraries. It is a framework which defines a common interface for +authors to more easily build their applications in a portable way. The +Haskell Cabal is meant to be a part of a larger infrastructure for +distributing, organizing, and cataloging Haskell Libraries and +Tools. For more information, please see: +. diff --git a/cabal/Cabal/runTests.sh b/cabal/Cabal/runTests.sh new file mode 100644 --- /dev/null +++ b/cabal/Cabal/runTests.sh @@ -0,0 +1,21 @@ +#!/bin/sh + +HCBASE=/usr/bin/ +HC=$HCBASE/ghc +GHCFLAGS='--make -Wall -fno-warn-unused-matches -cpp' +ISPOSIX=-DHAVE_UNIX_PACKAGE + +rm -f moduleTest +mkdir -p dist/debug +echo Building... +$HC $GHCFLAGS $ISPOSIX -DDEBUG -odir dist/debug -hidir dist/debug -idist/debug/:.:tests/HUnit-1.0/src tests/ModuleTest.hs -o moduleTest 2> stderr +RES=$? +if [ $RES != 0 ] +then + cat stderr >&2 + exit $RES +fi +echo Running... +./moduleTest +echo Done + diff --git a/cabal/Cabal/tests/PackageTests.hs b/cabal/Cabal/tests/PackageTests.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests.hs @@ -0,0 +1,82 @@ +-- The intention is that this will be the new unit test framework. +-- Please add any working tests here. This file should do nothing +-- but import tests from other modules. +-- +-- Stephen Blackheath, 2009 + +module Main where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import qualified Test.HUnit as HUnit +import PackageTests.BenchmarkExeV10.Check +import PackageTests.BenchmarkOptions.Check +import PackageTests.BenchmarkStanza.Check +import PackageTests.BuildDeps.SameDepsAllRound.Check +import PackageTests.BuildDeps.TargetSpecificDeps1.Check +import PackageTests.BuildDeps.TargetSpecificDeps1.Check +import PackageTests.BuildDeps.TargetSpecificDeps2.Check +import PackageTests.BuildDeps.TargetSpecificDeps3.Check +import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check +import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check +import PackageTests.BuildDeps.InternalLibrary0.Check +import PackageTests.BuildDeps.InternalLibrary1.Check +import PackageTests.BuildDeps.InternalLibrary2.Check +import PackageTests.BuildDeps.InternalLibrary3.Check +import PackageTests.BuildDeps.InternalLibrary4.Check +import PackageTests.TestOptions.Check +import PackageTests.TestStanza.Check +import PackageTests.TestSuiteExeV10.Check +import PackageTests.TemplateHaskell.Check +import Distribution.Text (display) +import Distribution.Simple.Utils (cabalVersion) +import Data.Version +import System.Directory + +hunit :: TestName -> HUnit.Test -> Test +hunit name test = testGroup name $ hUnitTestToTests test + +tests :: Version -> [Test] +tests cabalVersion = [ + hunit "PackageTests/BuildDeps/SameDepsAllRound/" PackageTests.BuildDeps.SameDepsAllRound.Check.suite, + -- The two following tests were disabled by Johan Tibell as + -- they have been failing for a long time: + -- hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check.suite, + -- hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary0/" (PackageTests.BuildDeps.InternalLibrary0.Check.suite cabalVersion), + hunit "PackageTests/TestStanza/" (PackageTests.TestStanza.Check.suite cabalVersion), + -- ^ The Test stanza test will eventually be required + -- only for higher versions. + hunit "PackageTests/TestSuiteExeV10/Test" + (PackageTests.TestSuiteExeV10.Check.checkTest cabalVersion), + hunit "PackageTests/TestSuiteExeV10/TestWithHpc" + (PackageTests.TestSuiteExeV10.Check.checkTestWithHpc cabalVersion), + hunit "PackageTests/TestOptions" PackageTests.TestOptions.Check.suite, + hunit "PackageTests/BenchmarkStanza/" (PackageTests.BenchmarkStanza.Check.suite cabalVersion), + -- ^ The benchmark stanza test will eventually be required + -- only for higher versions. + hunit "PackageTests/BenchmarkExeV10/Test" + (PackageTests.BenchmarkExeV10.Check.checkBenchmark cabalVersion), + hunit "PackageTests/BenchmarkOptions" PackageTests.BenchmarkOptions.Check.suite, + hunit "PackageTests/TemplateHaskell/profiling" PackageTests.TemplateHaskell.Check.profiling, + hunit "PackageTests/TemplateHaskell/dynamic" PackageTests.TemplateHaskell.Check.dynamic + ] ++ + -- These tests are only required to pass on cabal version >= 1.7 + (if cabalVersion >= Version [1, 7] [] + then [ + hunit "PackageTests/BuildDeps/TargetSpecificDeps1/" PackageTests.BuildDeps.TargetSpecificDeps1.Check.suite, + hunit "PackageTests/BuildDeps/TargetSpecificDeps2/" PackageTests.BuildDeps.TargetSpecificDeps2.Check.suite, + hunit "PackageTests/BuildDeps/TargetSpecificDeps3/" PackageTests.BuildDeps.TargetSpecificDeps3.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary1/" PackageTests.BuildDeps.InternalLibrary1.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary2/" PackageTests.BuildDeps.InternalLibrary2.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary3/" PackageTests.BuildDeps.InternalLibrary3.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary4/" PackageTests.BuildDeps.InternalLibrary4.Check.suite + ] + else []) + +main = do + putStrLn $ "Cabal test suite - testing cabal version "++display cabalVersion + setCurrentDirectory "tests" + defaultMain (tests cabalVersion) + diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Check.hs b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Check.hs @@ -0,0 +1,21 @@ +module PackageTests.BenchmarkExeV10.Check + ( checkBenchmark + ) where + +import Distribution.PackageDescription ( Benchmark(..), emptyBenchmark ) +import Distribution.Simple.Hpc +import Distribution.Version +import Test.HUnit +import System.Directory +import System.FilePath +import PackageTests.PackageTester + +dir :: FilePath +dir = "PackageTests" "BenchmarkExeV10" + +checkBenchmark :: Version -> Test +checkBenchmark cabalVersion = TestCase $ do + let spec = PackageSpec dir ["--enable-benchmarks"] + buildResult <- cabal_build spec + let buildMessage = "\'setup build\' should succeed" + assertEqual buildMessage True $ successful buildResult diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Foo.hs b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +fooTest :: [String] -> Bool +fooTest _ = True diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Setup.hs b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs @@ -0,0 +1,8 @@ +module Main where + +import Foo +import System.Exit + +main :: IO () +main | fooTest [] = exitSuccess + | otherwise = exitFailure diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/my.cabal b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BenchmarkExeV10/my.cabal @@ -0,0 +1,15 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.9.2 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base + +benchmark bench-Foo + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: bench-Foo.hs + build-depends: base, my diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal @@ -0,0 +1,20 @@ +name: BenchmarkOptions +version: 0.1 +license: BSD3 +author: Johan Tibell +stability: stable +category: PackageTests +build-type: Simple +cabal-version: >= 1.9.2 + +description: + Check that Cabal passes the correct test options to test suites. + +executable dummy + main-is: test-BenchmarkOptions.hs + build-depends: base + +benchmark test-BenchmarkOptions + main-is: test-BenchmarkOptions.hs + type: exitcode-stdio-1.0 + build-depends: base diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkOptions/Check.hs b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/Check.hs @@ -0,0 +1,23 @@ +module PackageTests.BenchmarkOptions.Check where + +import Test.HUnit +import System.FilePath +import PackageTests.PackageTester + +suite :: Test +suite = TestCase $ do + let directory = "PackageTests" "BenchmarkOptions" + pdFile = directory "BenchmarkOptions" <.> "cabal" + spec = PackageSpec directory ["--enable-benchmarks"] + _ <- cabal_build spec + result <- cabal_bench spec ["--benchmark-options=1 2 3"] + let message = "\"cabal bench\" did not pass the correct options to the " + ++ "benchmark executable with \"--benchmark-options\"" + assertEqual message True $ successful result + result' <- cabal_bench spec [ "--benchmark-option=1" + , "--benchmark-option=2" + , "--benchmark-option=3" + ] + let message = "\"cabal bench\" did not pass the correct options to the " + ++ "benchmark executable with \"--benchmark-option\"" + assertEqual message True $ successful result' diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkOptions/Setup.hs b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs @@ -0,0 +1,11 @@ +module Main where + +import System.Environment ( getArgs ) +import System.Exit ( exitFailure, exitSuccess ) + +main :: IO () +main = do + args <- getArgs + if args == ["1", "2", "3"] + then exitSuccess + else putStrLn ("Got: " ++ show args) >> exitFailure diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkStanza/Check.hs b/cabal/Cabal/tests/PackageTests/BenchmarkStanza/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BenchmarkStanza/Check.hs @@ -0,0 +1,57 @@ +module PackageTests.BenchmarkStanza.Check where + +import Test.HUnit +import System.FilePath +import PackageTests.PackageTester +import Data.List (isInfixOf, intercalate) +import Distribution.Version +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Dependency(..) ) +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), Benchmark(..), Library(..) + , BenchmarkInterface(..) + , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary + , emptyBenchmark, BuildType(..) ) +import Distribution.Verbosity (silent) +import Distribution.License (License(..)) +import Distribution.ModuleName (fromString) +import Distribution.System (buildPlatform) +import Distribution.Compiler + ( CompilerId(..), CompilerFlavor(..) ) +import Distribution.Text + +suite :: Version -> Test +suite cabalVersion = TestCase $ do + let directory = "PackageTests" "BenchmarkStanza" + pdFile = directory "my" <.> "cabal" + spec = PackageSpec directory [] + result <- cabal_configure spec + let message = "cabal configure should recognize benchmark section" + test = "unknown section type" + `isInfixOf` + (intercalate " " $ lines $ outputText result) + assertEqual message False test + genPD <- readPackageDescription silent pdFile + let compiler = CompilerId GHC $ Version [6, 12, 2] [] + anyV = intersectVersionRanges anyVersion anyVersion + anticipatedBenchmark = emptyBenchmark + { benchmarkName = "dummy" + , benchmarkInterface = BenchmarkExeV10 (Version [1,0] []) "dummy.hs" + , benchmarkBuildInfo = emptyBuildInfo + { targetBuildDepends = + [ Dependency (PackageName "base") anyVersion ] + , hsSourceDirs = ["."] + } + , benchmarkEnabled = False + } + case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of + Left xs -> let depMessage = "should not have missing dependencies:\n" ++ + (unlines $ map (show . disp) xs) + in assertEqual depMessage True False + Right (f, _) -> let gotBenchmark = head $ benchmarks f + in assertEqual "parsed benchmark stanza does not match anticipated" + gotBenchmark anticipatedBenchmark diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkStanza/Setup.hs b/cabal/Cabal/tests/PackageTests/BenchmarkStanza/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BenchmarkStanza/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BenchmarkStanza/my.cabal b/cabal/Cabal/tests/PackageTests/BenchmarkStanza/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BenchmarkStanza/my.cabal @@ -0,0 +1,19 @@ +name: BenchmarkStanza +version: 0.1 +license: BSD3 +author: Johan Tibell +stability: stable +category: PackageTests +build-type: Simple + +description: + Check that Cabal recognizes the benchmark stanza defined below. + +Library + exposed-modules: MyLibrary + build-depends: base + +benchmark dummy + main-is: dummy.hs + type: exitcode-stdio-1.0 + build-depends: base diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs @@ -0,0 +1,22 @@ +module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List +import Control.Exception +import Prelude hiding (catch) + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive1") [] + result <- cabal_build spec + do + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + let sb = "Could not find module `Prelude'" + assertBool ("cabal output should be "++show sb) $ + sb `isInfixOf` outputText result + `catch` \exc -> do + putStrLn $ "Cabal result was "++show result + throwIO (exc :: SomeException) diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDeps b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDeps new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDeps @@ -0,0 +1,20 @@ +name: GlobalBuildDepsNotAdditive1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + If you specify 'base' in the global build dependencies, then define + a library without base, it fails to find 'base' for the library. + +--------------------------------------- + +build-depends: base + +Library + exposed-modules: MyLibrary + build-depends: bytestring, old-time diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs @@ -0,0 +1,22 @@ +module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List +import Control.Exception +import Prelude hiding (catch) + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive2") [] + result <- cabal_build spec + do + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + let sb = "Could not find module `Prelude'" + assertBool ("cabal output should be "++show sb) $ + sb `isInfixOf` outputText result + `catch` \exc -> do + putStrLn $ "Cabal result was "++show result + throwIO (exc :: SomeException) diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDeps b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDeps new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDeps @@ -0,0 +1,20 @@ +name: GlobalBuildDepsNotAdditive1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + If you specify 'base' in the global build dependencies, then define + an executable without base, it fails to find 'base' for the executable + +--------------------------------------- + +build-depends: base + +Executable lemon + main-is: lemon.hs + build-depends: bytestring, old-time diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs @@ -0,0 +1,26 @@ +module PackageTests.BuildDeps.InternalLibrary0.Check where + +import Test.HUnit +import PackageTests.PackageTester +import Control.Monad +import System.FilePath +import Data.Version +import Data.List (isInfixOf, intercalate) +import Control.Exception +import Prelude hiding (catch) + + +suite :: Version -> Test +suite cabalVersion = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary0") [] + result <- cabal_build spec + do + assertEqual "cabal build should fail" False (successful result) + when (cabalVersion >= Version [1, 7] []) $ do + let sb = "library which is defined within the same package." + -- In 1.7 it should tell you how to enable the desired behaviour. + assertEqual ("cabal output should say "++show sb) True $ + sb `isInfixOf` (intercalate " " $ lines $ outputText result) + `catch` \exc -> do + putStrLn $ "Cabal result was "++show result + throwIO (exc :: SomeException) diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal @@ -0,0 +1,24 @@ +name: InternalLibrary0 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check that with 'cabal-version:' containing versions less than 1.7, we do *not* + have the new behaviour to allow executables to refer to the library defined + in the same module. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary0 diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs @@ -0,0 +1,18 @@ +module PackageTests.BuildDeps.InternalLibrary1.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Control.Exception +import Prelude hiding (catch) + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary1") [] + result <- cabal_build spec + do + assertEqual "cabal build should succeed - see test-log.txt" True (successful result) + `catch` \exc -> do + putStrLn $ "Cabal result was "++show result + throwIO (exc :: SomeException) diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new (in >= 1.7.1) ability to allow executables to refer to + the library defined in the same module. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary1 diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs @@ -0,0 +1,34 @@ +module PackageTests.BuildDeps.InternalLibrary2.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import qualified Data.ByteString.Char8 as C +import Control.Exception +import Prelude hiding (catch) + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary2") [] + let specTI = PackageSpec (directory spec "to-install") [] + + unregister "InternalLibrary2" + iResult <- cabal_install specTI + do + assertEqual "cabal install should succeed" True (successful iResult) + `catch` \exc -> do + putStrLn $ "Cabal result was "++show iResult + throwIO (exc :: SomeException) + bResult <- cabal_build spec + do + assertEqual "cabal build should succeed" True (successful bResult) + `catch` \exc -> do + putStrLn $ "Cabal result was "++show bResult + throwIO (exc :: SomeException) + unregister "InternalLibrary2" + + (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] + C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) + assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output) + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary2 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name and version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary2 diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal @@ -0,0 +1,18 @@ +name: InternalLibrary2 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name and version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs @@ -0,0 +1,34 @@ +module PackageTests.BuildDeps.InternalLibrary3.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import qualified Data.ByteString.Char8 as C +import Control.Exception +import Prelude hiding (catch) + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary3") [] + let specTI = PackageSpec (directory spec "to-install") [] + + unregister "InternalLibrary3" + iResult <- cabal_install specTI + do + assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) + `catch` \exc -> do + putStrLn $ "Cabal result was "++show iResult + throwIO (exc :: SomeException) + bResult <- cabal_build spec + do + assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) + `catch` \exc -> do + putStrLn $ "Cabal result was "++show bResult + throwIO (exc :: SomeException) + unregister "InternalLibrary3" + + (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] + C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) + assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output) + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary3 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name, but a *newer* version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary3 diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal @@ -0,0 +1,18 @@ +name: InternalLibrary3 +version: 0.2 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name but a *newer* version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs @@ -0,0 +1,34 @@ +module PackageTests.BuildDeps.InternalLibrary4.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import qualified Data.ByteString.Char8 as C +import Control.Exception +import Prelude hiding (catch) + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary4") [] + let specTI = PackageSpec (directory spec "to-install") [] + + unregister "InternalLibrary4" + iResult <- cabal_install specTI + do + assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) + `catch` \exc -> do + putStrLn $ "Cabal result was "++show iResult + throwIO (exc :: SomeException) + bResult <- cabal_build spec + do + assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) + `catch` \exc -> do + putStrLn $ "Cabal result was "++show bResult + throwIO (exc :: SomeException) + unregister "InternalLibrary4" + + (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] + C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) + assertEqual "executable should have linked with the installed library" "myLibFunc installed" (concat $ lines output) + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary4 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that we can explicitly say we want InternalLibrary4-0.2 + and it will give us the *installed* version 0.2 instead of the internal 0.1. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary4 >= 0.2 diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal @@ -0,0 +1,18 @@ +name: InternalLibrary4 +version: 0.2 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name but a *newer* version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs @@ -0,0 +1,18 @@ +module PackageTests.BuildDeps.SameDepsAllRound.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Control.Exception +import Prelude hiding (catch) + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "SameDepsAllRound") [] + result <- cabal_build spec + do + assertEqual "cabal build should succeed - see test-log.txt" True (successful result) + `catch` \exc -> do + putStrLn $ "Cabal result was "++show result + throwIO (exc :: SomeException) diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal @@ -0,0 +1,31 @@ +name: SameDepsAllRound +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +synopsis: Same dependencies all round +category: PackageTests +build-type: Simple + +description: + Check for the "old build-dep behaviour" namely that we get the same + package dependencies on all build targets, even if different ones + were specified for different targets + . + Here all .hs files use the three packages mentioned, so this shows + that build-depends is not target-specific. This is the behaviour + we want when cabal-version contains versions less than 1.7. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring + +Executable lemon + main-is: lemon.hs + build-depends: old-time + +Executable pineapple + main-is: pineapple.hs diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "pineapple" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs @@ -0,0 +1,24 @@ +module PackageTests.BuildDeps.TargetSpecificDeps1.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List +import Control.Exception +import Prelude hiding (catch) + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps1") [] + result <- cabal_build spec + do + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + assertBool "error should be in MyLibrary.hs" $ + "MyLibrary.hs:" `isInfixOf` outputText result + assertBool "error should be \"Could not find module `System.Time\"" $ + "Could not find module `System.Time'" `isInfixOf` + (intercalate " " $ lines $ outputText result) + `catch` \exc -> do + putStrLn $ "Cabal result was "++show result + throwIO (exc :: SomeException) diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal @@ -0,0 +1,22 @@ +name: TargetSpecificDeps1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new build-dep behaviour, where build-depends are + handled specifically for each target + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring + +Executable lemon + main-is: lemon.hs + build-depends: base, bytestring, old-time diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs @@ -0,0 +1,19 @@ +module PackageTests.BuildDeps.TargetSpecificDeps2.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List +import Control.Exception +import Prelude hiding (catch) + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps2") [] + result <- cabal_build spec + do + assertEqual "cabal build should succeed - see test-log.txt" True (successful result) + `catch` \exc -> do + putStrLn $ "Cabal result was "++show result + throwIO (exc :: SomeException) diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs @@ -0,0 +1,5 @@ +import qualified Data.ByteString.Char8 as C + +main = do + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal @@ -0,0 +1,24 @@ +name: TargetSpecificDeps1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new build-dep behaviour, where build-depends are + handled specifically for each target + This one is a control against TargetSpecificDeps1 - it is correct and should + succeed. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + build-depends: base, bytestring diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs @@ -0,0 +1,23 @@ +module PackageTests.BuildDeps.TargetSpecificDeps3.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List +import Control.Exception +import Prelude hiding (catch) + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps3") [] + result <- cabal_build spec + do + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + assertBool "error should be in lemon.hs" $ + "lemon.hs:" `isInfixOf` outputText result + assertBool "error should be \"Could not find module `System.Time\"" $ + "Could not find module `System.Time'" `isInfixOf` (intercalate " " $ lines $ outputText result) + `catch` \exc -> do + putStrLn $ "Cabal result was "++show result + throwIO (exc :: SomeException) diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal @@ -0,0 +1,22 @@ +name: test +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new build-dep behaviour, where build-depends are + handled specifically for each target + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + build-depends: base, bytestring diff --git a/cabal/Cabal/tests/PackageTests/PackageTester.hs b/cabal/Cabal/tests/PackageTests/PackageTester.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/PackageTester.hs @@ -0,0 +1,179 @@ +module PackageTests.PackageTester ( + PackageSpec(..), + Success(..), + Result(..), + cabal_configure, + cabal_build, + cabal_test, + cabal_bench, + cabal_install, + unregister, + run + ) where + +import qualified Control.Exception.Extensible as E +import System.Directory +import System.FilePath +import System.IO +import System.Posix.IO +import System.Process +import System.Exit +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Concurrent +import Control.Monad +import Data.List +import Data.Maybe +import qualified Data.ByteString.Char8 as C + + +data PackageSpec = + PackageSpec { + directory :: FilePath, + configOpts :: [String] + } + +data Success = Failure + | ConfigureSuccess + | BuildSuccess + | InstallSuccess + | TestSuccess + | BenchSuccess + deriving (Eq, Show) + +data Result = Result { + successful :: Bool, + success :: Success, + outputText :: String + } + deriving Show + +nullResult :: Result +nullResult = Result True Failure "" + +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 + } + +cabal_configure :: PackageSpec -> IO Result +cabal_configure spec = do + res <- doCabalConfigure spec + record spec res + return res + +doCabalConfigure :: PackageSpec -> IO Result +doCabalConfigure spec = do + cleanResult@(_, _, cleanOutput) <- cabal spec ["clean"] + requireSuccess cleanResult + res <- cabal spec $ ["configure", "--user"] ++ configOpts spec + return $ recordRun res ConfigureSuccess nullResult + +doCabalBuild :: PackageSpec -> IO Result +doCabalBuild spec = do + configResult <- doCabalConfigure spec + if successful configResult + then do + res <- cabal spec ["build"] + return $ recordRun res BuildSuccess configResult + else + return configResult + +cabal_build :: PackageSpec -> IO Result +cabal_build spec = do + res <- doCabalBuild spec + record spec res + return res + +unregister :: String -> IO () +unregister libraryName = do + res@(_, _, output) <- run Nothing "ghc-pkg" ["unregister", "--user", libraryName] + if "cannot find package" `isInfixOf` output + then return () + else requireSuccess res + +-- | Install this library in the user area +cabal_install :: PackageSpec -> IO Result +cabal_install spec = do + buildResult <- doCabalBuild spec + res <- if successful buildResult + then do + res <- cabal spec ["install"] + return $ recordRun res InstallSuccess buildResult + else + return buildResult + record spec res + return res + +cabal_test :: PackageSpec -> [String] -> IO Result +cabal_test spec extraArgs = do + res <- cabal spec $ "test" : extraArgs + let r = recordRun res TestSuccess nullResult + record spec r + return r + +cabal_bench :: PackageSpec -> [String] -> IO Result +cabal_bench spec extraArgs = do + res <- cabal spec $ "bench" : extraArgs + let r = recordRun res BenchSuccess nullResult + record spec r + return r + +-- | Returns the command that was issued, the return code, and hte output text +cabal :: PackageSpec -> [String] -> IO (String, ExitCode, String) +cabal spec cabalArgs = do + wd <- getCurrentDirectory + r <- run (Just $ directory spec) "ghc" + [ "--make" +-- HPC causes trouble -- see #1012 +-- , "-fhpc" + , "-package-conf " ++ wd "../dist/package.conf.inplace" + , "Setup.hs" + ] + requireSuccess r + run (Just $ directory spec) (wd directory spec "Setup") cabalArgs + +-- | Returns the command that was issued, the return code, and hte output text +run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String) +run cwd cmd args = do + -- Posix-specific + (outf, outf0) <- createPipe + outh <- fdToHandle outf + outh0 <- fdToHandle outf0 + pid <- runProcess cmd args cwd Nothing Nothing (Just outh0) (Just outh0) + + -- fork off a thread to start consuming the output + output <- suckH [] outh + hClose outh + + -- wait on the process + ex <- waitForProcess pid + let fullCmd = intercalate " " $ cmd:args + return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, + ex, output) + where + suckH output h = do + eof <- hIsEOF h + if eof + then return (reverse output) + else do + c <- hGetChar h + suckH (c:output) h + +requireSuccess :: (String, ExitCode, String) -> IO () +requireSuccess (cmd, exitCode, output) = do + case exitCode of + ExitSuccess -> return () + ExitFailure r -> do + ioError $ userError $ "Command " ++ cmd ++ " failed." + +record :: PackageSpec -> Result -> IO () +record spec res = do + C.writeFile (directory spec "test-log.txt") (C.pack $ outputText res) + diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/Check.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/Check.hs @@ -0,0 +1,44 @@ +module PackageTests.TemplateHaskell.Check where + +import Test.HUnit +import System.FilePath +import PackageTests.PackageTester +import Data.List (isInfixOf, intercalate) +import Distribution.Version +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Dependency(..) ) +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), TestSuite(..), Library(..) + , TestSuiteInterface(..) + , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary + , emptyTestSuite, BuildType(..) ) +import Distribution.Verbosity (silent) +import Distribution.License (License(..)) +import Distribution.ModuleName (fromString) +import Distribution.System (buildPlatform) +import Distribution.Compiler + ( CompilerId(..), CompilerFlavor(..) ) +import Distribution.Text + +profiling :: Test +profiling = TestCase $ do + let flags = ["--enable-library-profiling" +-- ,"--disable-library-vanilla" + ,"--enable-executable-profiling"] + spec = PackageSpec ("PackageTests" "TemplateHaskell" "profiling") flags + result <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful result) + +dynamic :: Test +dynamic = TestCase $ do + let flags = ["--enable-shared" +-- ,"--disable-library-vanilla" + ,"--enable-executable-dynamic"] + spec = PackageSpec ("PackageTests" "TemplateHaskell" "dynamic") flags + result <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful result) + diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Exe.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Exe.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Exe.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import TH + +main = print $(splice) diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Lib where + +import TH + +val = $(splice) diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Setup.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/TH.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/TH.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/TH.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH where + +splice = [| () |] diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/my.cabal b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/my.cabal @@ -0,0 +1,15 @@ +Name: templateHaskell +Version: 0.1 +Build-Type: Simple +Cabal-Version: >= 1.2 + +Library + Exposed-Modules: Lib + Other-Modules: TH + Build-Depends: base, template-haskell + Extensions: TemplateHaskell + +Executable main + Main-is: Exe.hs + Build-Depends: base, template-haskell + Extensions: TemplateHaskell diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Exe.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Exe.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Exe.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import TH + +main = print $(splice) diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Lib.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Lib.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Lib.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Lib where + +import TH + +val = $(splice) diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Setup.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/TH.hs b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/TH.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/TH.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH where + +splice = [| () |] diff --git a/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/my.cabal b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/my.cabal @@ -0,0 +1,15 @@ +Name: templateHaskell +Version: 0.1 +Build-Type: Simple +Cabal-Version: >= 1.2 + +Library + Exposed-Modules: Lib + Other-Modules: TH + Build-Depends: base, template-haskell + Extensions: TemplateHaskell + +Executable main + Main-is: Exe.hs + Build-Depends: base, template-haskell + Extensions: TemplateHaskell diff --git a/cabal/Cabal/tests/PackageTests/TestOptions/Check.hs b/cabal/Cabal/tests/PackageTests/TestOptions/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TestOptions/Check.hs @@ -0,0 +1,23 @@ +module PackageTests.TestOptions.Check where + +import Test.HUnit +import System.FilePath +import PackageTests.PackageTester + +suite :: Test +suite = TestCase $ do + let directory = "PackageTests" "TestOptions" + pdFile = directory "TestOptions" <.> "cabal" + spec = PackageSpec directory ["--enable-tests"] + _ <- cabal_build spec + result <- cabal_test spec ["--test-options=1 2 3"] + let message = "\"cabal test\" did not pass the correct options to the " + ++ "test executable with \"--test-options\"" + assertEqual message True $ successful result + result' <- cabal_test spec [ "--test-option=1" + , "--test-option=2" + , "--test-option=3" + ] + let message = "\"cabal test\" did not pass the correct options to the " + ++ "test executable with \"--test-option\"" + assertEqual message True $ successful result' diff --git a/cabal/Cabal/tests/PackageTests/TestOptions/Setup.hs b/cabal/Cabal/tests/PackageTests/TestOptions/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TestOptions/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/TestOptions/TestOptions.cabal b/cabal/Cabal/tests/PackageTests/TestOptions/TestOptions.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TestOptions/TestOptions.cabal @@ -0,0 +1,20 @@ +name: TestOptions +version: 0.1 +license: BSD3 +author: Thomas Tuegel +stability: stable +category: PackageTests +build-type: Simple +cabal-version: >= 1.9.2 + +description: + Check that Cabal passes the correct test options to test suites. + +executable dummy + main-is: test-TestOptions.hs + build-depends: base + +test-suite test-TestOptions + main-is: test-TestOptions.hs + type: exitcode-stdio-1.0 + build-depends: base diff --git a/cabal/Cabal/tests/PackageTests/TestOptions/test-TestOptions.hs b/cabal/Cabal/tests/PackageTests/TestOptions/test-TestOptions.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TestOptions/test-TestOptions.hs @@ -0,0 +1,11 @@ +module Main where + +import System.Environment ( getArgs ) +import System.Exit ( exitFailure, exitSuccess ) + +main :: IO () +main = do + args <- getArgs + if args == ["1", "2", "3"] + then exitSuccess + else putStrLn ("Got: " ++ show args) >> exitFailure diff --git a/cabal/Cabal/tests/PackageTests/TestStanza/Check.hs b/cabal/Cabal/tests/PackageTests/TestStanza/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TestStanza/Check.hs @@ -0,0 +1,57 @@ +module PackageTests.TestStanza.Check where + +import Test.HUnit +import System.FilePath +import PackageTests.PackageTester +import Data.List (isInfixOf, intercalate) +import Distribution.Version +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Dependency(..) ) +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), TestSuite(..), Library(..) + , TestSuiteInterface(..) + , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary + , emptyTestSuite, BuildType(..) ) +import Distribution.Verbosity (silent) +import Distribution.License (License(..)) +import Distribution.ModuleName (fromString) +import Distribution.System (buildPlatform) +import Distribution.Compiler + ( CompilerId(..), CompilerFlavor(..) ) +import Distribution.Text + +suite :: Version -> Test +suite cabalVersion = TestCase $ do + let directory = "PackageTests" "TestStanza" + pdFile = directory "my" <.> "cabal" + spec = PackageSpec directory [] + result <- cabal_configure spec + let message = "cabal configure should recognize test section" + test = "unknown section type" + `isInfixOf` + (intercalate " " $ lines $ outputText result) + assertEqual message False test + genPD <- readPackageDescription silent pdFile + let compiler = CompilerId GHC $ Version [6, 12, 2] [] + anyV = intersectVersionRanges anyVersion anyVersion + anticipatedTestSuite = emptyTestSuite + { testName = "dummy" + , testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs" + , testBuildInfo = emptyBuildInfo + { targetBuildDepends = + [ Dependency (PackageName "base") anyVersion ] + , hsSourceDirs = ["."] + } + , testEnabled = False + } + case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of + Left xs -> let depMessage = "should not have missing dependencies:\n" ++ + (unlines $ map (show . disp) xs) + in assertEqual depMessage True False + Right (f, _) -> let gotTest = head $ testSuites f + in assertEqual "parsed test-suite stanza does not match anticipated" + gotTest anticipatedTestSuite diff --git a/cabal/Cabal/tests/PackageTests/TestStanza/Setup.hs b/cabal/Cabal/tests/PackageTests/TestStanza/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TestStanza/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/TestStanza/my.cabal b/cabal/Cabal/tests/PackageTests/TestStanza/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TestStanza/my.cabal @@ -0,0 +1,19 @@ +name: TestStanza +version: 0.1 +license: BSD3 +author: Thomas Tuegel +stability: stable +category: PackageTests +build-type: Simple + +description: + Check that Cabal recognizes the Test stanza defined below. + +Library + exposed-modules: MyLibrary + build-depends: base + +test-suite dummy + main-is: dummy.hs + type: exitcode-stdio-1.0 + build-depends: base diff --git a/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Check.hs b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Check.hs @@ -0,0 +1,47 @@ +module PackageTests.TestSuiteExeV10.Check + ( checkTest + , checkTestWithHpc + ) where + +import Distribution.PackageDescription ( TestSuite(..), emptyTestSuite ) +import Distribution.Simple.Hpc +import Distribution.Version +import Test.HUnit +import System.Directory +import System.FilePath +import PackageTests.PackageTester + +dir :: FilePath +dir = "PackageTests" "TestSuiteExeV10" + +checkTest :: Version -> Test +checkTest cabalVersion = TestCase $ do + let spec = PackageSpec dir ["--enable-tests"] + buildResult <- cabal_build spec + let buildMessage = "\'setup build\' should succeed" + assertEqual buildMessage True $ successful buildResult + testResult <- cabal_test spec [] + let testMessage = "\'setup test\' should succeed" + assertEqual testMessage True $ successful testResult + +checkTestWithHpc :: Version -> Test +checkTestWithHpc cabalVersion = TestCase $ do + let spec = PackageSpec dir [ "--enable-tests" + , "--enable-library-coverage" + ] + buildResult <- cabal_build spec + let buildMessage = "\'setup build\' should succeed" + assertEqual buildMessage True $ successful buildResult + testResult <- cabal_test spec [] + let testMessage = "\'setup test\' should succeed" + assertEqual testMessage True $ successful testResult + let dummy = emptyTestSuite { testName = "test-Foo" } + tixFile = tixFilePath (dir "dist") $ testName dummy + tixFileMessage = ".tix file should exist" + markupDir = htmlDir (dir "dist") $ testName dummy + markupFile = markupDir "hpc_index" <.> "html" + markupFileMessage = "HPC markup file should exist" + tixFileExists <- doesFileExist tixFile + assertEqual tixFileMessage True tixFileExists + markupFileExists <- doesFileExist markupFile + assertEqual markupFileMessage True markupFileExists diff --git a/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +fooTest :: [String] -> Bool +fooTest _ = True diff --git a/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/my.cabal b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/my.cabal @@ -0,0 +1,15 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.9.2 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base + +test-suite test-Foo + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: test-Foo.hs + build-depends: base, my diff --git a/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs @@ -0,0 +1,8 @@ +module Main where + +import Foo +import System.Exit + +main :: IO () +main | fooTest [] = exitSuccess + | otherwise = exitFailure diff --git a/cabal/Cabal/tests/UnitTests.hs b/cabal/Cabal/tests/UnitTests.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/UnitTests.hs @@ -0,0 +1,17 @@ +module Main + ( main + ) where + +import Test.Framework +import Test.Framework.Providers.HUnit + +import qualified UnitTests.Distribution.Compat.ReadP + +tests :: [Test] +tests = [ + testGroup "Distribution.Compat.ReadP" + UnitTests.Distribution.Compat.ReadP.tests + ] + +main :: IO () +main = defaultMain tests diff --git a/cabal/Cabal/tests/UnitTests/Distribution/Compat/ReadP.hs b/cabal/Cabal/tests/UnitTests/Distribution/Compat/ReadP.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/UnitTests/Distribution/Compat/ReadP.hs @@ -0,0 +1,140 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compat.ReadP +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This code was originally in Distribution.Compat.ReadP. Please see that file +-- for provenace. The tests have been integrated into the test framework. +-- Some properties cannot be tested, as they hold over arbitrary ReadP values, +-- and we don't have a good Arbitrary instance (nor Show instance) for ReadP. +-- +module UnitTests.Distribution.Compat.ReadP + ( tests + -- * Properties + -- $properties + ) where + +import Data.List +import Distribution.Compat.ReadP + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 + +tests = + [ testProperty "Get Nil" prop_Get_Nil + , testProperty "Get Cons" prop_Get_Cons + , testProperty "Look" prop_Look + , testProperty "Fail" prop_Fail + , testProperty "Return" prop_Return + --, testProperty "Bind" prop_Bind + --, testProperty "Plus" prop_Plus + --, testProperty "LeftPlus" prop_LeftPlus + --, testProperty "Gather" prop_Gather + , testProperty "String Yes" prop_String_Yes + , testProperty "String Maybe" prop_String_Maybe + , testProperty "Munch" (prop_Munch evenChar) + , testProperty "Munch1" (prop_Munch1 evenChar) + --, testProperty "Choice" prop_Choice + --, testProperty "ReadS" prop_ReadS + ] + +-- --------------------------------------------------------------------------- +-- QuickCheck properties that hold for the combinators + +{- $properties +The following are QuickCheck specifications of what the combinators do. +These can be seen as formal specifications of the behavior of the +combinators. + +We use bags to give semantics to the combinators. +-} + +type Bag a = [a] + +-- Equality on bags does not care about the order of elements. + +(=~) :: Ord a => Bag a -> Bag a -> Bool +xs =~ ys = sort xs == sort ys + +-- A special equality operator to avoid unresolved overloading +-- when testing the properties. + +(=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool +(=~.) = (=~) + +-- Here follow the properties: + +prop_Get_Nil = + readP_to_S get [] =~ [] + +prop_Get_Cons c s = + readP_to_S get (c:s) =~ [(c,s)] + +prop_Look s = + readP_to_S look s =~ [(s,s)] + +prop_Fail s = + readP_to_S pfail s =~. [] + +prop_Return x s = + readP_to_S (return x) s =~. [(x,s)] + +prop_Bind p k s = + readP_to_S (p >>= k) s =~. + [ ys'' + | (x,s') <- readP_to_S p s + , ys'' <- readP_to_S (k (x::Int)) s' + ] + +prop_Plus p q s = + readP_to_S (p +++ q) s =~. + (readP_to_S p s ++ readP_to_S q s) + +prop_LeftPlus p q s = + readP_to_S (p <++ q) s =~. + (readP_to_S p s +<+ readP_to_S q s) + where + [] +<+ ys = ys + xs +<+ _ = xs + +{- +prop_Gather s = + forAll readPWithoutReadS $ \p -> + readP_to_S (gather p) s =~ + [ ((pre,x::Int),s') + | (x,s') <- readP_to_S p s + , let pre = take (length s - length s') s + ] +-} + +prop_String_Yes this s = + readP_to_S (string this) (this ++ s) =~ + [(this,s)] + +prop_String_Maybe this s = + readP_to_S (string this) s =~ + [(this, drop (length this) s) | this `isPrefixOf` s] + +prop_Munch p s = + readP_to_S (munch p) s =~ + [(takeWhile p s, dropWhile p s)] + +prop_Munch1 p s = + readP_to_S (munch1 p) s =~ + [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)] + +prop_Choice ps s = + readP_to_S (choice ps) s =~. + readP_to_S (foldr (+++) pfail ps) s + +prop_ReadS r s = + readP_to_S (readS_to_P r) s =~. r s + +evenChar :: Char -> Bool +evenChar = even . fromEnum + diff --git a/cabal/Cabal/tests/hackage/check.sh b/cabal/Cabal/tests/hackage/check.sh new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/hackage/check.sh @@ -0,0 +1,25 @@ +#!/bin/sh + +base_version=1.4.0.2 +test_version=1.5.6 + +for setup in archive/*/*/Setup.hs archive/*/*/Setup.lhs; do + + pkgname=$(basename ${setup}) + + if test $(wc -w < ${setup}) -gt 21; then + if ghc -package Cabal-${base_version} -S ${setup} -o /dev/null 2> /dev/null; then + + if ghc -package Cabal-${test_version} -S ${setup} -o /dev/null 2> /dev/null; then + echo "OK ${setup}" + else + echo "FAIL ${setup} does not compile with Cabal-${test_version}" + fi + else + echo "OK ${setup} (does not compile with Cabal-${base_version})" + fi + else + echo "trivial ${setup}" + fi + +done diff --git a/cabal/Cabal/tests/hackage/download.sh b/cabal/Cabal/tests/hackage/download.sh new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/hackage/download.sh @@ -0,0 +1,19 @@ +#!/bin/sh + +if test ! -f archive/archive.tar; then + + wget http://hackage.haskell.org/cgi-bin/hackage-scripts/archive.tar + mkdir -p archive + mv archive.tar archive/ + tar -C archive -xf archive/archive.tar + +fi + +if test ! -f archive/00-index.tar.gz; then + + wget http://hackage.haskell.org/packages/archive/00-index.tar.gz + mkdir -p archive + mv 00-index.tar.gz archive/ + tar -C archive -xzf archive/00-index.tar.gz + +fi diff --git a/cabal/Cabal/tests/hackage/unpack.sh b/cabal/Cabal/tests/hackage/unpack.sh new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/hackage/unpack.sh @@ -0,0 +1,16 @@ +#!/bin/sh + +for tarball in archive/*/*/*.tar.gz; do + + pkgdir=$(dirname ${tarball}) + pkgname=$(basename ${tarball} .tar.gz) + + if tar -tzf ${tarball} ${pkgname}/Setup.hs 2> /dev/null; then + tar -xzf ${tarball} ${pkgname}/Setup.hs -O > ${pkgdir}/Setup.hs + elif tar -tzf ${tarball} ${pkgname}/Setup.lhs 2> /dev/null; then + tar -xzf ${tarball} ${pkgname}/Setup.lhs -O > ${pkgdir}/Setup.lhs + else + echo "${pkgname} has no Setup.hs or .lhs at all!!?!" + fi + +done diff --git a/cabal/Cabal/tests/misc/ghc-supported-languages.hs b/cabal/Cabal/tests/misc/ghc-supported-languages.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/tests/misc/ghc-supported-languages.hs @@ -0,0 +1,99 @@ +-- | A test program to check that ghc has got all of its extensions registered +-- +module Main where + +import Language.Haskell.Extension +import Distribution.Text +import Distribution.Simple.Utils +import Distribution.Verbosity + +import Data.List ((\\)) +import Data.Maybe +import Control.Applicative +import Control.Monad +import System.Environment +import System.Exit + +-- | A list of GHC extensions that are deliberately not registered, +-- e.g. due to being experimental and not ready for public consumption +-- +exceptions = map readExtension + [ "PArr" -- still classed as experimental, will be renamed and registered + ] + +checkProblems :: [Extension] -> [String] +checkProblems implemented = + + let unregistered = + [ ext | ext <- implemented -- extensions that ghc knows about + , not (registered ext) -- but that are not registered + , ext `notElem` exceptions ] -- except for the exceptions + + -- check if someone has forgotten to update the exceptions list... + + -- exceptions that are not implemented + badExceptions = exceptions \\ implemented + + -- exceptions that are now registered + badExceptions' = filter registered exceptions + + in catMaybes + [ check unregistered $ unlines + [ "The following extensions are known to GHC but are not in the " + , "extension registry in Language.Haskell.Extension." + , " " ++ intercalate "\n " (map display unregistered) + , "If these extensions are ready for public consumption then they " + , "should be registered. If they are still experimental and you " + , "think they are not ready to be registered then please add them " + , "to the exceptions list in this test program along with an " + , "explanation." + ] + , check badExceptions $ unlines + [ "Error in the extension exception list. The following extensions" + , "are listed as exceptions but are not even implemented by GHC:" + , " " ++ intercalate "\n " (map display badExceptions) + , "Please fix this test program by correcting the list of" + , "exceptions." + ] + , check badExceptions' $ unlines + [ "Error in the extension exception list. The following extensions" + , "are listed as exceptions to registration but they are in fact" + , "now registered in Language.Haskell.Extension:" + , " " ++ intercalate "\n " (map display badExceptions') + , "Please fix this test program by correcting the list of" + , "exceptions." + ] + ] + where + registered (UnknownExtension _) = False + registered _ = True + + check [] _ = Nothing + check _ i = Just i + + +main = topHandler $ do + [ghcPath] <- getArgs + exts <- getExtensions ghcPath + let problems = checkProblems exts + putStrLn (intercalate "\n" problems) + if null problems + then exitSuccess + else exitFailure + +getExtensions :: FilePath -> IO [Extension] +getExtensions ghcPath = + map readExtension . lines + <$> rawSystemStdout normal ghcPath ["--supported-languages"] + +readExtension :: String -> Extension +readExtension str = handleNoParse $ do + -- GHC defines extensions in a positive way, Cabal defines them + -- relative to H98 so we try parsing ("No" ++ extName) first + ext <- simpleParse ("No" ++ str) + case ext of + UnknownExtension _ -> simpleParse str + _ -> return ext + where + handleNoParse :: Maybe Extension -> Extension + handleNoParse = fromMaybe (error $ "unparsable extension " ++ show str) diff --git a/cabal/IMPORTED-FROM b/cabal/IMPORTED-FROM deleted file mode 100644 --- a/cabal/IMPORTED-FROM +++ /dev/null @@ -1,7 +0,0 @@ -http://darcs.haskell.org/cabal-branches/cabal-1.12 - -Fri Jul 15 15:04:46 EEST 2011 Ian Lynagh - * Bump version number - hunk ./cabal/Cabal.cabal 2 - -Version: 1.11.2 - +Version: 1.12.0 diff --git a/cabal/Paths_Cabal.hs b/cabal/Paths_Cabal.hs new file mode 100644 --- /dev/null +++ b/cabal/Paths_Cabal.hs @@ -0,0 +1,8 @@ +module Paths_Cabal ( + version, + ) where + +import Data.Version (Version(..)) + +version :: Version +version = Version {versionBranch = [1,17,0], versionTags = []} diff --git a/cabal/Paths_cabal_install.hs b/cabal/Paths_cabal_install.hs new file mode 100644 --- /dev/null +++ b/cabal/Paths_cabal_install.hs @@ -0,0 +1,8 @@ +module Paths_cabal_install ( + version, + ) where + +import Data.Version (Version(..)) + +version :: Version +version = Version {versionBranch = [0,17,0], versionTags = []} diff --git a/cabal/README b/cabal/README --- a/cabal/README +++ b/cabal/README @@ -1,8 +1,8 @@ This Cabal darcs repository contains multiple packages: - * cabal/ -- the Cabal library package + * Cabal/ -- the Cabal library package * cabal-install/ -- the cabal-install package containing the 'cabal' tool. See the README in each subdir for more details. -The canonical upstream repo lives at http://darcs.haskell.org/cabal/ +The canonical upstream repo lives at https://github.com/haskell/cabal diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs --- a/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs +++ b/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs @@ -56,9 +56,9 @@ import qualified Distribution.Compat.ReadP as Parse ( ReadP, pfail, munch1, skipSpaces ) -import qualified Text.PrettyPrint.HughesPJ as Disp +import qualified Text.PrettyPrint as Disp ( Doc, render, char, text ) -import Text.PrettyPrint.HughesPJ +import Text.PrettyPrint ( (<+>), (<>) ) import Data.List @@ -112,6 +112,7 @@ | SetupFailed | ConfigureFailed | BuildFailed + | TestsFailed | InstallFailed | InstallOk deriving Eq @@ -122,7 +123,7 @@ new :: OS -> Arch -> CompilerId -- -> Version -> ConfiguredPackage -> BR.BuildResult -> BuildReport -new os' arch' comp (ConfiguredPackage pkg flags deps) result = +new os' arch' comp (ConfiguredPackage pkg flags _ deps) result = BuildReport { package = packageId pkg, os = os', @@ -143,6 +144,7 @@ Left (BR.UnpackFailed _) -> UnpackFailed Left (BR.ConfigureFailed _) -> ConfigureFailed Left (BR.BuildFailed _) -> BuildFailed + Left (BR.TestsFailed _) -> TestsFailed Left (BR.InstallFailed _) -> InstallFailed Right (BR.BuildOk _ _) -> InstallOk convertDocsOutcome = case result of @@ -151,9 +153,9 @@ Right (BR.BuildOk BR.DocsFailed _) -> Failed Right (BR.BuildOk BR.DocsOk _) -> Ok convertTestsOutcome = case result of + Left (BR.TestsFailed _) -> Failed Left _ -> NotTried Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried - Right (BR.BuildOk _ BR.TestsFailed) -> Failed Right (BR.BuildOk _ BR.TestsOk) -> Ok cabalInstallID :: PackageIdentifier @@ -280,6 +282,7 @@ disp SetupFailed = Disp.text "SetupFailed" disp ConfigureFailed = Disp.text "ConfigureFailed" disp BuildFailed = Disp.text "BuildFailed" + disp TestsFailed = Disp.text "TestsFailed" disp InstallFailed = Disp.text "InstallFailed" disp InstallOk = Disp.text "InstallOk" @@ -294,6 +297,7 @@ "SetupFailed" -> return SetupFailed "ConfigureFailed" -> return ConfigureFailed "BuildFailed" -> return BuildFailed + "TestsFailed" -> return TestsFailed "InstallFailed" -> return InstallFailed "InstallOk" -> return InstallOk _ -> Parse.pfail diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs --- a/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs +++ b/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs @@ -117,11 +117,11 @@ fromPlanPackage (Platform arch os) comp planPackage = case planPackage of InstallPlan.Installed pkg@(ConfiguredPackage (SourcePackage { - packageSource = RepoTarballPackage repo _ _ }) _ _) result + packageSource = RepoTarballPackage repo _ _ }) _ _ _) result -> Just $ (BuildReport.new os arch comp pkg (Right result), repo) InstallPlan.Failed pkg@(ConfiguredPackage (SourcePackage { - packageSource = RepoTarballPackage repo _ _ }) _ _) result + packageSource = RepoTarballPackage repo _ _ }) _ _ _) result -> Just $ (BuildReport.new os arch comp pkg (Left result), repo) _ -> Nothing diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs --- a/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs +++ b/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs @@ -19,7 +19,7 @@ import qualified Distribution.Compat.ReadP as Parse ( pfail, munch1 ) -import qualified Text.PrettyPrint.HughesPJ as Disp +import qualified Text.PrettyPrint as Disp ( text ) import Data.Char as Char diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs --- a/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs +++ b/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs @@ -29,10 +29,8 @@ type BuildLog = String uploadReports :: URI -> [(BuildReport, Maybe BuildLog)] - -> BrowserAction (HandleStream String) () -> BrowserAction (HandleStream BuildLog) () -uploadReports uri reports auth = do - auth +uploadReports uri reports = do forM_ reports $ \(report, mbBuildLog) -> do buildId <- postBuildReport uri report case mbBuildLog of @@ -63,7 +61,7 @@ -> BrowserAction (HandleStream BuildLog) () putBuildLog reportId buildLog = do --FIXME: do something if the request fails - (_, response) <- request Request { + (_, _response) <- request Request { rqURI = reportId{uriPath = uriPath reportId "log"}, rqMethod = PUT, rqHeaders = [Header HdrContentType ("text/plain"), diff --git a/cabal/cabal-install/Distribution/Client/Config.hs b/cabal/cabal-install/Distribution/Client/Config.hs --- a/cabal/cabal-install/Distribution/Client/Config.hs +++ b/cabal/cabal-install/Distribution/Client/Config.hs @@ -8,7 +8,8 @@ -- Stability : provisional -- Portability : portable -- --- Utilities for handling saved state such as known packages, known servers and downloaded packages. +-- Utilities for handling saved state such as known packages, known servers and +-- downloaded packages. ----------------------------------------------------------------------------- module Distribution.Client.Config ( SavedConfig(..), @@ -21,7 +22,14 @@ defaultCabalDir, defaultConfigFile, defaultCacheDir, + defaultCompiler, defaultLogsDir, + + baseSavedConfig, + commentSavedConfig, + initialSavedConfig, + configFieldDescriptions, + installDirsFields ) where @@ -36,19 +44,26 @@ , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand , showRepo, parseRepo ) +import Distribution.Client.Utils + ( numberOfProcessors ) +import Distribution.Simple.Compiler + ( OptimisationLevel(..) ) import Distribution.Simple.Setup ( ConfigFlags(..), configureOptions, defaultConfigFlags , installDirsOptions - , Flag, toFlag, flagToMaybe, fromFlagOrDefault ) + , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs ( InstallDirs(..), defaultInstallDirs , PathTemplate, toPathTemplate ) import Distribution.ParseUtils ( FieldDescr(..), liftField - , ParseResult(..), locatedErrorMsg, showPWarning + , ParseResult(..), PError(..), PWarning(..) + , locatedErrorMsg, showPWarning , readFields, warning, lineNo , simpleField, listField, parseFilePathQ, parseTokenQ ) +import Distribution.Client.ParseUtils + ( parseFields, ppFields, ppSection ) import qualified Distribution.ParseUtils as ParseUtils ( Field(..) ) import qualified Distribution.Text as Text @@ -73,23 +88,24 @@ ( Monoid(..) ) import Control.Monad ( when, foldM, liftM ) -import qualified Data.Map as Map import qualified Distribution.Compat.ReadP as Parse ( option ) -import qualified Text.PrettyPrint.HughesPJ as Disp - ( Doc, render, text, colon, vcat, empty, isEmpty, nest ) -import Text.PrettyPrint.HughesPJ - ( (<>), (<+>), ($$), ($+$) ) +import qualified Text.PrettyPrint as Disp + ( render, text, empty ) +import Text.PrettyPrint + ( ($+$) ) import System.Directory - ( createDirectoryIfMissing, getAppUserDataDirectory ) + ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile ) import Network.URI ( URI(..), URIAuth(..) ) import System.FilePath - ( (), takeDirectory ) + ( (<.>), (), takeDirectory ) import System.Environment ( getEnvironment ) import System.IO.Error ( isDoesNotExistError ) +import Distribution.Compat.Exception + ( catchIO ) -- -- * Configuration saved in the config file @@ -195,7 +211,8 @@ }, savedInstallFlags = mempty { installSummaryFile = [toPathTemplate (logsDir "build.log")], - installBuildReports= toFlag AnonymousReports + installBuildReports= toFlag AnonymousReports, + installNumJobs = toFlag (Just numberOfProcessors) } } @@ -288,15 +305,17 @@ fmap (Just . parseConfig initial) (readFile file) where - handleNotExists action = catch action $ \ioe -> + handleNotExists action = catchIO action $ \ioe -> if isDoesNotExistError ioe then return Nothing else ioError ioe writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () writeConfigFile file comments vals = do + let tmpFile = file <.> "tmp" createDirectoryIfMissing True (takeDirectory file) - writeFile file $ explanation ++ showConfigWithComments comments vals ++ "\n" + writeFile tmpFile $ explanation ++ showConfigWithComments comments vals ++ "\n" + renameFile tmpFile file where explanation = unlines ["-- This is the configuration file for the 'cabal' command line tool." @@ -343,7 +362,7 @@ ++ toSavedConfig liftConfigFlag (configureOptions ParseArgs) - (["builddir", "configure-option"] ++ map fieldName installDirsFields) + (["builddir", "configure-option", "constraint"] ++ map fieldName installDirsFields) --FIXME: this is only here because viewAsFieldDescr gives us a parser -- that only recognises 'ghc' etc, the case-sensitive flag names, not @@ -351,6 +370,31 @@ [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. + ,liftField configOptimization (\v flags -> flags { configOptimization = v }) $ + let name = "optimization" in + FieldDescr name + (\f -> case f of + Flag NoOptimisation -> Disp.text "False" + Flag NormalOptimisation -> Disp.text "True" + Flag MaximumOptimisation -> Disp.text "2" + _ -> Disp.empty) + (\line str _ -> case () of + _ | str == "False" -> ParseOk [] (Flag NoOptimisation) + | str == "True" -> ParseOk [] (Flag NormalOptimisation) + | str == "0" -> ParseOk [] (Flag NoOptimisation) + | str == "1" -> ParseOk [] (Flag NormalOptimisation) + | str == "2" -> ParseOk [] (Flag MaximumOptimisation) + | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation) + | lstr == "true" -> ParseOk [caseWarning] (Flag NormalOptimisation) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = PWarning $ + "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.") ] ++ toSavedConfig liftConfigExFlag @@ -359,7 +403,7 @@ ++ toSavedConfig liftInstallFlag (installOptions ParseArgs) - ["dry-run", "reinstall", "only"] [] + ["dry-run", "only"] [] ++ toSavedConfig liftUploadFlag (commandOptions uploadCommand ParseArgs) @@ -495,42 +539,5 @@ ppSection "install-dirs" name installDirsFields (field comment) (field vals) ------------------------- --- * Parsing utils --- - ---FIXME: replace this with something better in Cabal-1.5 -parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a -parseFields fields initial = foldM setField initial - where - fieldMap = Map.fromList - [ (name, f) | f@(FieldDescr name _ _) <- fields ] - setField accum (ParseUtils.F line name value) = case Map.lookup name fieldMap of - Just (FieldDescr _ _ set) -> set line value accum - Nothing -> do - warning $ "Unrecognized field " ++ name ++ " on line " ++ show line - return accum - setField accum f = do - warning $ "Unrecognized stanza on line " ++ show (lineNo f) - return accum - --- | This is a customised version of the function from Cabal that also prints --- default values for empty fields as comments. --- -ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc -ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur) - | FieldDescr name getter _ <- fields] - -ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc -ppField name def cur - | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def - | otherwise = Disp.text name <> Disp.colon <+> cur - -ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc -ppSection name arg fields def cur = - Disp.text name <+> Disp.text arg - $$ Disp.nest 2 (ppFields fields def cur) - installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirsFields = map viewAsFieldDescr installDirsOptions - diff --git a/cabal/cabal-install/Distribution/Client/Configure.hs b/cabal/cabal-install/Distribution/Client/Configure.hs --- a/cabal/cabal-install/Distribution/Client/Configure.hs +++ b/cabal/cabal-install/Distribution/Client/Configure.hs @@ -32,8 +32,8 @@ , PackageDB(..), PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration ) import Distribution.Simple.Setup - ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault ) -import Distribution.Client.PackageIndex (PackageIndex) + ( ConfigFlags(..), fromFlag, toFlag, flagToMaybe, fromFlagOrDefault ) +import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Simple.Utils ( defaultPackageDesc ) import Distribution.Package @@ -82,7 +82,7 @@ configureCommand (const configFlags) extraArgs Right installPlan -> case InstallPlan.ready installPlan of - [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _)) _ _)] -> + [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _)) _ _ _)] -> configurePackage verbosity (InstallPlan.planPlatform installPlan) (InstallPlan.planCompiler installPlan) @@ -97,22 +97,27 @@ useCabalVersion = maybe anyVersion thisVersion (flagToMaybe (configCabalVersion configExFlags)), useCompiler = Just comp, - -- 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 packageDBs ++ [UserPackageDB], - usePackageIndex = if UserPackageDB `elem` packageDBs - then Just index - else Nothing, + usePackageDB = packageDBs', + usePackageIndex = index', useProgramConfig = conf, useDistPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) (configDistPref configFlags), useLoggingHandle = Nothing, - useWorkingDir = 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) logMsg message rest = debug verbosity message >> rest @@ -121,12 +126,13 @@ -- planLocalPackage :: Verbosity -> Compiler -> ConfigFlags -> ConfigExFlags - -> PackageIndex InstalledPackage + -> PackageIndex -> SourcePackageDb -> IO (Progress String String InstallPlan) planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex (SourcePackageDb _ packagePrefs) = do pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity + solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerId comp) let -- We create a local package and ask to resolve a dependency on it localPkg = SourcePackage { @@ -135,6 +141,10 @@ packageSource = LocalUnpackedPackage "." } + testsEnabled = fromFlagOrDefault False $ configTests configFlags + benchmarksEnabled = + fromFlagOrDefault False $ configBenchmarks configFlags + resolverParams = addPreferences @@ -153,12 +163,21 @@ [ PackageConstraintFlags (packageName pkg) (configConfigurationsFlags configFlags) ] + . addConstraints + -- '--enable-tests' and '--enable-benchmarks' constraints from + -- command line + [ PackageConstraintStanzas (packageName pkg) $ concat + [ if testsEnabled then [TestStanzas] else [] + , if benchmarksEnabled then [BenchStanzas] else [] + ] + ] + $ standardInstallPolicy installedPkgIndex (SourcePackageDb mempty packagePrefs) [SpecificSourcePackage localPkg] - return (resolveDependencies buildPlatform (compilerId comp) resolverParams) + return (resolveDependencies buildPlatform (compilerId comp) solver resolverParams) -- | Call an installer for an 'SourcePackage' but override the configure @@ -175,7 +194,7 @@ -> [String] -> IO () configurePackage verbosity platform comp scriptOptions configFlags - (ConfiguredPackage (SourcePackage _ gpkg _) flags deps) extraArgs = + (ConfiguredPackage (SourcePackage _ gpkg _) flags stanzas deps) extraArgs = setupWrapper verbosity scriptOptions (Just pkg) configureCommand configureFlags extraArgs @@ -184,11 +203,13 @@ configureFlags = filterConfigureFlags configFlags { configConfigurationsFlags = flags, configConstraints = map thisPackageVersion deps, - configVerbosity = toFlag verbosity + configVerbosity = toFlag verbosity, + configBenchmarks = toFlag (BenchStanzas `elem` stanzas), + configTests = toFlag (TestStanzas `elem` stanzas) } pkg = case finalizePackageDescription flags (const True) - platform comp [] gpkg of + platform comp [] (enableStanzas stanzas gpkg) of Left _ -> error "finalizePackageDescription ConfiguredPackage failed" Right (desc, _) -> desc diff --git a/cabal/cabal-install/Distribution/Client/Dependency.hs b/cabal/cabal-install/Distribution/Client/Dependency.hs --- a/cabal/cabal-install/Distribution/Client/Dependency.hs +++ b/cabal/cabal-install/Distribution/Client/Dependency.hs @@ -14,6 +14,7 @@ ----------------------------------------------------------------------------- module Distribution.Client.Dependency ( -- * The main package dependency resolver + chooseSolver, resolveDependencies, Progress(..), foldProgress, @@ -42,44 +43,57 @@ addConstraints, addPreferences, setPreferenceDefault, + setReorderGoals, + setIndependentGoals, + setAvoidReinstalls, + setShadowPkgs, + setMaxBackjumps, addSourcePackages, - hideInstalledPackagesSpecific, + hideInstalledPackagesSpecificByInstalledPackageId, + hideInstalledPackagesSpecificBySourcePackageId, hideInstalledPackagesAllVersions, ) where -import Distribution.Client.Dependency.TopDown (topDownResolver) +import Distribution.Client.Dependency.TopDown + ( topDownResolver ) +import Distribution.Client.Dependency.Modular + ( modularResolver, SolverConfig(..) ) import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) +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(..), InstalledPackage ) + , SourcePackage(..) ) import Distribution.Client.Dependency.Types - ( DependencyResolver, PackageConstraint(..) + ( PreSolver(..), Solver(..), DependencyResolver, PackageConstraint(..) , PackagePreferences(..), InstalledPreference(..) + , PackagesPreferenceDefault(..) , Progress(..), foldProgress ) import Distribution.Client.Targets +import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package ( PackageName(..), PackageId, Package(..), packageVersion - , Dependency(Dependency)) + , InstalledPackageId, Dependency(Dependency)) import Distribution.Version - ( VersionRange, anyVersion, withinRange, simplifyVersionRange ) + ( Version(..), VersionRange, anyVersion, withinRange, simplifyVersionRange ) import Distribution.Compiler - ( CompilerId(..) ) + ( CompilerId(..), CompilerFlavor(..) ) import Distribution.System ( Platform ) -import Distribution.Simple.Utils (comparing) +import Distribution.Simple.Utils + ( comparing, warn, info ) import Distribution.Text ( display ) +import Distribution.Verbosity + ( Verbosity ) import Data.List (maximumBy, foldl') -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (fromMaybe) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set) - -- ------------------------------------------------------------ -- * High level planner policy -- ------------------------------------------------------------ @@ -93,36 +107,16 @@ depResolverConstraints :: [PackageConstraint], depResolverPreferences :: [PackagePreference], depResolverPreferenceDefault :: PackagesPreferenceDefault, - depResolverInstalledPkgIndex :: PackageIndex InstalledPackage, - depResolverSourcePkgIndex :: PackageIndex SourcePackage + depResolverInstalledPkgIndex :: InstalledPackageIndex.PackageIndex, + depResolverSourcePkgIndex :: PackageIndex.PackageIndex SourcePackage, + depResolverReorderGoals :: Bool, + depResolverIndependentGoals :: Bool, + depResolverAvoidReinstalls :: Bool, + depResolverShadowPkgs :: Bool, + depResolverMaxBackjumps :: Maybe Int } --- | 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. --- -data PackagesPreferenceDefault = - - -- | Always prefer the latest version irrespective of any existing - -- installed version. - -- - -- * This is the standard policy for upgrade. - -- - PreferAllLatest - - -- | Always prefer the installed versions over ones that would need to be - -- installed. Secondarily, prefer latest versions (eg the latest installed - -- version or if there are none then the latest source version). - | PreferAllInstalled - - -- | Prefer the latest version for packages that are explicitly requested - -- but prefers the installed version for any other packages. - -- - -- * This is the standard policy for install. - -- - | PreferLatestForSelected - - -- | A package selection preference for a particular package. -- -- Preferences are soft constraints that the dependency resolver should try to @@ -137,8 +131,8 @@ -- | If we prefer versions of packages that are already installed. | PackageInstalledPreference PackageName InstalledPreference -basicDepResolverParams :: PackageIndex InstalledPackage - -> PackageIndex SourcePackage +basicDepResolverParams :: InstalledPackageIndex.PackageIndex + -> PackageIndex.PackageIndex SourcePackage -> DepResolverParams basicDepResolverParams installedPkgIndex sourcePkgIndex = DepResolverParams { @@ -147,7 +141,12 @@ depResolverPreferences = [], depResolverPreferenceDefault = PreferLatestForSelected, depResolverInstalledPkgIndex = installedPkgIndex, - depResolverSourcePkgIndex = sourcePkgIndex + depResolverSourcePkgIndex = sourcePkgIndex, + depResolverReorderGoals = False, + depResolverIndependentGoals = False, + depResolverAvoidReinstalls = False, + depResolverShadowPkgs = False, + depResolverMaxBackjumps = Nothing } addTargets :: [PackageName] @@ -180,6 +179,36 @@ depResolverPreferenceDefault = preferenceDefault } +setReorderGoals :: Bool -> DepResolverParams -> DepResolverParams +setReorderGoals b params = + params { + depResolverReorderGoals = b + } + +setIndependentGoals :: Bool -> DepResolverParams -> DepResolverParams +setIndependentGoals b params = + params { + depResolverIndependentGoals = b + } + +setAvoidReinstalls :: Bool -> DepResolverParams -> DepResolverParams +setAvoidReinstalls b params = + params { + depResolverAvoidReinstalls = b + } + +setShadowPkgs :: Bool -> DepResolverParams -> DepResolverParams +setShadowPkgs b params = + params { + depResolverShadowPkgs = b + } + +setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams +setMaxBackjumps n params = + params { + depResolverMaxBackjumps = n + } + dontUpgradeBasePackage :: DepResolverParams -> DepResolverParams dontUpgradeBasePackage params = addConstraints extraConstraints params @@ -193,7 +222,7 @@ -- below when there are no targets and thus no dep on base. -- Need to refactor contraints separate from needing packages. isInstalled = not . null - . PackageIndex.lookupPackageName + . InstalledPackageIndex.lookupPackageName (depResolverInstalledPkgIndex params) addSourcePackages :: [SourcePackage] @@ -205,36 +234,46 @@ (depResolverSourcePkgIndex params) pkgs } -hideInstalledPackagesSpecific :: [PackageId] - -> DepResolverParams -> DepResolverParams -hideInstalledPackagesSpecific pkgids params = +hideInstalledPackagesSpecificByInstalledPackageId :: [InstalledPackageId] + -> DepResolverParams -> DepResolverParams +hideInstalledPackagesSpecificByInstalledPackageId pkgids params = --TODO: this should work using exclude constraints instead params { depResolverInstalledPkgIndex = - foldl' (flip PackageIndex.deletePackageId) + foldl' (flip InstalledPackageIndex.deleteInstalledPackageId) (depResolverInstalledPkgIndex params) pkgids } +hideInstalledPackagesSpecificBySourcePackageId :: [PackageId] + -> DepResolverParams -> DepResolverParams +hideInstalledPackagesSpecificBySourcePackageId pkgids params = + --TODO: this should work using exclude constraints instead + params { + depResolverInstalledPkgIndex = + foldl' (flip InstalledPackageIndex.deleteSourcePackageId) + (depResolverInstalledPkgIndex params) pkgids + } + hideInstalledPackagesAllVersions :: [PackageName] -> DepResolverParams -> DepResolverParams hideInstalledPackagesAllVersions pkgnames params = --TODO: this should work using exclude constraints instead params { depResolverInstalledPkgIndex = - foldl' (flip PackageIndex.deletePackageName) + foldl' (flip InstalledPackageIndex.deletePackageName) (depResolverInstalledPkgIndex params) pkgnames } hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams hideBrokenInstalledPackages params = - hideInstalledPackagesSpecific pkgids params + hideInstalledPackagesSpecificByInstalledPackageId pkgids params where - pkgids = map packageId - . PackageIndex.reverseDependencyClosure + pkgids = map Installed.installedPackageId + . InstalledPackageIndex.reverseDependencyClosure (depResolverInstalledPkgIndex params) - . map (packageId . fst) - . PackageIndex.brokenPackages + . map (Installed.installedPackageId . fst) + . InstalledPackageIndex.brokenPackages $ depResolverInstalledPkgIndex params @@ -247,7 +286,7 @@ hideInstalledPackagesAllVersions (depResolverTargets params) params -standardInstallPolicy :: PackageIndex InstalledPackage +standardInstallPolicy :: InstalledPackageIndex.PackageIndex -> SourcePackageDb -> [PackageSpecifier SourcePackage] -> DepResolverParams @@ -265,7 +304,7 @@ . addTargets (map pkgSpecifierTarget pkgSpecifiers) - . hideInstalledPackagesSpecific + . hideInstalledPackagesSpecificBySourcePackageId [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] . addSourcePackages @@ -279,9 +318,21 @@ -- * Interface to the standard resolver -- ------------------------------------------------------------ -defaultResolver :: DependencyResolver -defaultResolver = topDownResolver +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 +runSolver :: Solver -> SolverConfig -> DependencyResolver +runSolver TopDown = const topDownResolver -- TODO: warn about unsuported options +runSolver Modular = modularResolver + -- | Run the dependency solver. -- -- Since this is potentially an expensive operation, the result is wrapped in a @@ -290,27 +341,40 @@ -- resolveDependencies :: Platform -> CompilerId + -> Solver -> DepResolverParams -> Progress String String InstallPlan --TODO: is this needed here? see dontUpgradeBasePackage -resolveDependencies platform comp params +resolveDependencies platform comp _solver params | null (depResolverTargets params) = return (mkInstallPlan platform comp []) -resolveDependencies platform comp params = +resolveDependencies platform comp solver params = fmap (mkInstallPlan platform comp) - $ defaultResolver platform comp installedPkgIndex sourcePkgIndex - preferences constraints targets + $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls shadowing maxBkjumps) + platform comp installedPkgIndex sourcePkgIndex + preferences constraints targets where DepResolverParams targets constraints prefs defpref installedPkgIndex - sourcePkgIndex = dontUpgradeBasePackage - . hideBrokenInstalledPackages - $ params + sourcePkgIndex + reorderGoals + indGoals + noReinstalls + shadowing + maxBkjumps = dontUpgradeBasePackage + -- 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. + . (if solver /= Modular then hideBrokenInstalledPackages + else id) + $ params preferences = interpretPackagesPreference (Set.fromList targets) defpref prefs @@ -383,7 +447,8 @@ resolveWithoutDependencies :: DepResolverParams -> Either [ResolveNoDepsError] [SourcePackage] resolveWithoutDependencies (DepResolverParams targets constraints - prefs defpref installedPkgIndex sourcePkgIndex) = + prefs defpref installedPkgIndex sourcePkgIndex + _reorderGoals _indGoals _avoidReinstalls _shadowing _maxBjumps) = collectEithers (map selectPackage targets) where selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage @@ -406,7 +471,7 @@ (installPref pkg, versionPref pkg, packageVersion pkg) installPref = case preferInstalled of PreferLatest -> const False - PreferInstalled -> isJust . PackageIndex.lookupPackageId + PreferInstalled -> not . null . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex . packageId versionPref pkg = packageVersion pkg `withinRange` preferredVersions diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular.hs @@ -0,0 +1,58 @@ +module Distribution.Client.Dependency.Modular + ( modularResolver, SolverConfig(..)) where + +-- Here, we try to map between the external cabal-install solver +-- interface and the internal interface that the solver actually +-- expects. There are a number of type conversions to perform: we +-- have to convert the package indices to the uniform index used +-- by the solver; we also have to convert the initial constraints; +-- and finally, we have to convert back the resulting install +-- plan. + +import Data.Map as M + ( fromListWith ) +import Distribution.Client.Dependency.Modular.Assignment + ( Assignment, toCPs ) +import Distribution.Client.Dependency.Modular.Dependency + ( RevDepMap ) +import Distribution.Client.Dependency.Modular.ConfiguredConversion + ( convCP ) +import Distribution.Client.Dependency.Modular.IndexConversion + ( convPIs ) +import Distribution.Client.Dependency.Modular.Log + ( logToProgress ) +import Distribution.Client.Dependency.Modular.Package + ( PN ) +import Distribution.Client.Dependency.Modular.Solver + ( SolverConfig(..), solve ) +import Distribution.Client.Dependency.Types + ( DependencyResolver, PackageConstraint(..) ) +import Distribution.Client.InstallPlan + ( PlanPackage ) +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 = + 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 + -- Constraints have to be converted into a finite map indexed by PN. + gcs = M.fromListWith (++) (map (\ pc -> (pcName pc, [pc])) pcs) + + -- Results have to be converted into an install plan. + postprocess :: Assignment -> RevDepMap -> [PlanPackage] + postprocess a rdm = map (convCP iidx sidx) (toCPs a rdm) + + -- Helper function to extract the PN from a constraint. + pcName :: PackageConstraint -> PN + pcName (PackageConstraintVersion pn _) = pn + pcName (PackageConstraintInstalled pn ) = pn + pcName (PackageConstraintSource pn ) = pn + pcName (PackageConstraintFlags pn _) = pn + pcName (PackageConstraintStanzas pn _) = pn diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs @@ -0,0 +1,154 @@ +module Distribution.Client.Dependency.Modular.Assignment where + +import Control.Applicative +import Control.Monad +import Data.Array as A +import Data.List as L +import Data.Map as M +import Data.Maybe +import Data.Graph +import Prelude hiding (pi) + +import Distribution.PackageDescription (FlagAssignment) -- from Cabal +import Distribution.Client.Types (OptionalStanza) + +import Distribution.Client.Dependency.Modular.Configured +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.Version + +-- | A (partial) package assignment. Qualified package names +-- are associated with instances. +type PAssignment = Map QPN I + +-- | A (partial) package preassignment. Qualified package names +-- are associated with constrained instances. Constrained instances +-- record constraints about the instances that can still be chosen, +-- and in the extreme case fix a concrete instance. +type PPreAssignment = Map QPN (CI QPN) +type FAssignment = Map QFN Bool +type SAssignment = Map QSN Bool + +-- | A (partial) assignment of variables. +data Assignment = A PAssignment FAssignment SAssignment + deriving (Show, Eq) + +-- | A preassignment comprises knowledge about variables, but not +-- necessarily fixed values. +data PreAssignment = PA PPreAssignment FAssignment SAssignment + +-- | Extend a package preassignment. +-- +-- Takes the variable that causes the new constraints, a current preassignment +-- and a set of new dependency constraints. +-- +-- We're trying to extend the preassignment with each dependency one by one. +-- Each dependency is for a particular variable. We check if we already have +-- constraints for that variable in the current preassignment. If so, we're +-- trying to merge the constraints. +-- +-- Either returns a witness of the conflict that would arise during the merge, +-- or the successfully extended assignment. +extend :: Var QPN -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment +extend var pa qa = foldM (\ a (Dep qpn ci) -> + let ci' = M.findWithDefault (Constrained []) qpn a + in case (\ x -> M.insert qpn x a) <$> merge ci' ci of + Left (c, (d, d')) -> Left (c, L.map (Dep qpn) (simplify (P qpn) d d')) + Right x -> Right x) + pa qa + where + -- We're trying to remove trivial elements of the conflict. If we're just + -- making a choice pkg == instance, and pkg => pkg == instance is a part + -- of the conflict, then this info is clear from the context and does not + -- have to be repeated. + simplify v (Fixed _ (Goal var' _)) c | v == var && var' == var = [c] + simplify v c (Fixed _ (Goal var' _)) | v == var && var' == var = [c] + simplify _ c d = [c, d] + +-- | Delivers an ordered list of fully configured packages. +-- +-- TODO: This function is (sort of) ok. However, there's an open bug +-- w.r.t. unqualification. There might be several different instances +-- of one package version chosen by the solver, which will lead to +-- clashes. +toCPs :: Assignment -> RevDepMap -> [CP QPN] +toCPs (A pa fa sa) rdm = + let + -- get hold of the graph + g :: Graph + vm :: Vertex -> ((), QPN, [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 = transposeG g + -- Topsort the dependency graph, yielding a list of pkgs in the right order. + -- The graph will still contain all the installed packages, and it might + -- contain duplicates, because several variables might actually resolve to + -- the same package in the presence of qualified package names. + ps :: [PI QPN] + ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $ + topSort g + -- Determine the flags per package, by walking over and regrouping the + -- complete flag assignment by package. + fapp :: Map QPN FlagAssignment + fapp = M.fromListWith (++) $ + L.map (\ ((FN (PI qpn _) fn), b) -> (qpn, [(fn, b)])) $ + M.toList $ + fa + -- Stanzas per package. + sapp :: Map QPN [OptionalStanza] + sapp = M.fromListWith (++) $ + L.map (\ ((SN (PI qpn _) sn), b) -> (qpn, if b then [sn] else [])) $ + M.toList $ + sa + -- Dependencies per package. + depp :: QPN -> [PI QPN] + depp qpn = let v :: Vertex + v = fromJust (cvm qpn) + dvs :: [Vertex] + dvs = tg A.! v + in L.map (\ dv -> case vm dv of (_, x, _) -> PI x (pa M.! x)) dvs + in + L.map (\ pi@(PI qpn _) -> CP pi + (M.findWithDefault [] qpn fapp) + (M.findWithDefault [] qpn sapp) + (depp qpn)) + ps + +-- | Finalize an assignment and a reverse dependency map. +-- +-- This is preliminary, and geared towards output right now. +finalize :: Index -> Assignment -> RevDepMap -> IO () +finalize idx (A pa fa _) rdm = + let + -- get hold of the graph + g :: Graph + vm :: Vertex -> ((), QPN, [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] + f = L.filter (not . instPI) (L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) (topSort g)) + fapp :: Map QPN [(QFN, Bool)] -- flags per package + fapp = M.fromListWith (++) $ + L.map (\ (qfn@(FN (PI qpn _) _), b) -> (qpn, [(qfn, b)])) $ M.toList $ fa + -- print one instance + ppi pi@(PI qpn _) = showPI pi ++ status pi ++ " " ++ pflags (M.findWithDefault [] qpn fapp) + -- print install status + status :: PI QPN -> String + status (PI (Q _ pn) _) = + case insts of + [] -> " (new)" + vs -> " (" ++ intercalate ", " (L.map showVer vs) ++ ")" + where insts = L.map (\ (I v _) -> v) $ L.filter isInstalled $ + M.keys (M.findWithDefault M.empty pn idx) + isInstalled (I _ (Inst _ )) = True + isInstalled _ = False + -- print flag assignment + pflags = unwords . L.map (uncurry showFBool) + in + -- show packages with associated flag assignments + putStr (unlines (L.map ppi f)) diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs @@ -0,0 +1,143 @@ +module Distribution.Client.Dependency.Modular.Builder where + +-- Building the search tree. +-- +-- In this phase, we build a search tree that is too large, i.e, it contains +-- invalid solutions. We keep track of the open goals at each point. We +-- nondeterministically pick an open goal (via a goal choice node), create +-- subtrees according to the index and the available solutions, and extend the +-- set of open goals by superficially looking at the dependencies recorded in +-- the index. +-- +-- For each goal, we keep track of all the *reasons* why it is being +-- introduced. These are for debugging and error messages, mainly. A little bit +-- of care has to be taken due to the way we treat flags. If a package has +-- flag-guarded dependencies, we cannot introduce them immediately. Instead, we +-- store the entire dependency. + +import Control.Monad.Reader hiding (sequence, mapM) +import Data.List as L +import Data.Map as M +import Prelude hiding (sequence, mapM) + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Index +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.PSQ as P +import Distribution.Client.Dependency.Modular.Tree + +-- | 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 +} + +-- | 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' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs + where + 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 + +-- | 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 + +-- | 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 -> QGoalReasons -> FlaggedDeps 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 + qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs + gs = L.map (flip OpenGoal gr) (qfdeps ++ qfdefs) + +data BuildType = Goals | OneGoal OpenGoal | Instance QPN I PInfo QGoalReasons + +build :: BuildState -> Tree (QGoalReasons, Scope) +build = ana go + where + go :: BuildState -> TreeF (QGoalReasons, Scope) BuildState + + -- If we have a choice between many goals, we just record the choice in + -- the tree. We select each open goal in turn, and before we descend, remove + -- it from the queue of open goals. + go bs@(BS { rdeps = rds, open = gs, next = Goals }) + | P.null gs = DoneF rds + | otherwise = GoalChoiceF (P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' }) + (P.splits gs)) + + -- If we have already picked a goal, then the choice depends on the kind + -- of goal. + -- + -- For a package, we look up the instances available in the global info, + -- and then handle each instance in turn. + go bs@(BS { index = idx, scope = sc, 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 })) + (M.toList pis))) + -- TODO: data structure conversion is rather ugly here + + -- For a flag, we create only two subtrees, and we create them in the order + -- that is indicated by the flag default. + -- + -- TODO: Should we include the flag default in the tree? + go bs@(BS { 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 + [(True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True : gr)) t) bs) { next = Goals }), + (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })])) + where + reorder True = id + reorder False = reverse + trivial = L.null t && L.null f + + 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 }), + (True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })]) + where + trivial = L.null t + + -- For a particular instance, we change the state: we update the scope, + -- and furthermore we update the set of goals. + -- + -- TODO: We could inline this above. + go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs ecs _) gr }) = + go ((establishScope qpn ecs + (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 (QGoalReasons, Scope) +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) + where + sc | ind = makeIndependent igs + | otherwise = emptyScope + qpns = L.map (qualify sc) igs diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs @@ -0,0 +1,10 @@ +module Distribution.Client.Dependency.Modular.Configured where + +import Distribution.PackageDescription (FlagAssignment) -- from Cabal +import Distribution.Client.Types (OptionalStanza) + +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] diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs @@ -0,0 +1,40 @@ +module Distribution.Client.Dependency.Modular.ConfiguredConversion where + +import Data.Maybe +import Prelude hiding (pi) + +import Distribution.Client.InstallPlan +import Distribution.Client.Types +import Distribution.Compiler +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)) + +convCP :: SI.PackageIndex -> CI.PackageIndex SourcePackage -> + CP QPN -> PlanPackage +convCP iidx sidx (CP qpi fa es ds) = + case convPI qpi of + Left pi -> PreExisting $ InstalledPackage + (fromJust $ SI.lookupInstalledPackageId iidx pi) + (map convPI' ds) + Right pi -> Configured $ ConfiguredPackage + (fromJust $ CI.lookupPackageId sidx pi) + fa + es + (map convPI' ds) + +convPI :: PI QPN -> Either InstalledPackageId PackageId +convPI (PI _ (I _ (Inst pi))) = Left pi +convPI qpi = Right $ convPI' qpi + +convPI' :: PI QPN -> PackageId +convPI' (PI (Q _ pn) (I v _)) = PackageIdentifier pn v diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs @@ -0,0 +1,194 @@ +module Distribution.Client.Dependency.Modular.Dependency where + +import Prelude hiding (pi) + +import Data.List as L +import Data.Map as M +import Data.Set as S + +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Version + +-- | The type of variables that play a role in the solver. +-- Note that the tree currently does not use this type directly, +-- and rather has separate tree nodes for the different types of +-- variables. This fits better with the fact that in most cases, +-- these have to be treated differently. +-- +-- TODO: This isn't the ideal location to declare the type, +-- but we need them for constrained instances. +data Var qpn = P qpn | F (FN qpn) | S (SN qpn) + deriving (Eq, Ord, Show) + +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) + +type ConflictSet qpn = Set (Var qpn) + +showCS :: ConflictSet QPN -> String +showCS = intercalate ", " . L.map showVar . S.toList + +-- | 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 + +showCI :: CI QPN -> String +showCI (Fixed i _) = "==" ++ showI i +showCI (Constrained vr) = showVR (collapse vr) + +-- | Merge constrained instances. We currently adopt a lazy strategy for +-- merging, i.e., we only perform actual checking if one of the two choices +-- is fixed. If the merge fails, we return a conflict set indicating the +-- variables responsible for the failure, as well as the two conflicting +-- fragments. +-- +-- Note that while there may be more than one conflicting pair of version +-- ranges, we only return the first we find. +-- +-- TODO: Different pairs might have different conflict sets. We're +-- obviously interested to return a conflict that has a "better" conflict +-- set in the sense the it contains variables that allow us to backjump +-- further. We might apply some heuristics here, such as to change the +-- order in which we check the constraints. +merge :: Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn) +merge c@(Fixed i g1) d@(Fixed j g2) + | i == j = Right c + | otherwise = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, d)) +merge c@(Fixed (I v _) g1) (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ... + where + go [] = Right c + go (d@(vr, g2) : vrs) + | checkVR vr v = go vrs + | otherwise = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, Constrained [d])) +merge c@(Constrained _) d@(Fixed _ _) = merge d c +merge (Constrained rs) (Constrained ss) = Right (Constrained (rs ++ ss)) + + +type FlaggedDeps qpn = [FlaggedDep qpn] + +-- | Flagged dependencies can either be plain dependency constraints, +-- or flag-dependent dependency trees. +data FlaggedDep qpn = + Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) + | Stanza (SN qpn) (TrueFlaggedDeps qpn) + | Simple (Dep qpn) + deriving (Eq, Show) + +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) + +type TrueFlaggedDeps qpn = FlaggedDeps qpn +type FalseFlaggedDeps qpn = FlaggedDeps qpn + +-- | A dependency (constraint) associates a package name with a +-- constrained instance. +data Dep qpn = Dep qpn (CI qpn) + deriving (Eq, Show) + +showDep :: Dep QPN -> String +showDep (Dep qpn (Fixed i (Goal v _)) ) = + (if P qpn /= v then showVar v ++ " => " else "") ++ + showQPN qpn ++ "==" ++ showI i +showDep (Dep qpn (Constrained [(vr, Goal v _)])) = + showVar v ++ " => " ++ showQPN qpn ++ showVR vr +showDep (Dep qpn ci ) = + showQPN qpn ++ showCI ci + +instance Functor Dep where + fmap f (Dep x y) = Dep (f x) (fmap f y) + +instance ResetGoal Dep where + resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci) + +-- | A map containing reverse dependencies between qualified +-- package names. +type RevDepMap = Map QPN [QPN] + +-- | Goals are solver variables paired with information about +-- why they have been introduced. +data Goal qpn = Goal (Var qpn) (GoalReasons qpn) + deriving (Eq, Show) + +instance Functor Goal where + fmap f (Goal v gr) = Goal (fmap f v) (fmap (fmap f) gr) + +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) QGoalReasons + deriving (Eq, Show) + +-- | Reasons why a goal can be added to a goal set. +data GoalReason qpn = + UserGoal + | PDependency (PI qpn) + | FDependency (FN qpn) Bool + | SDependency (SN qpn) + deriving (Eq, Show) + +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) + +-- | The first element is the immediate reason. The rest are the reasons +-- for the reasons ... +type GoalReasons qpn = [GoalReason qpn] + +type QGoalReasons = GoalReasons QPN + +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 (SDependency qsn) = S.singleton (S qsn) + +goalReasonsToVars :: Ord qpn => GoalReasons qpn -> ConflictSet qpn +goalReasonsToVars = S.unions . L.map goalReasonToVars + +-- | 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 + +-- | 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 gr) = S.insert g (goalReasonsToVars gr) diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs @@ -0,0 +1,148 @@ +module Distribution.Client.Dependency.Modular.Explore where + +import Control.Applicative as A +import Data.Foldable +import Data.List as L +import Data.Map as M +import Data.Set as S + +import Distribution.Client.Dependency.Modular.Assignment +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Log +import Distribution.Client.Dependency.Modular.Message +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.PSQ as P +import Distribution.Client.Dependency.Modular.Tree + +-- | Backjumping. +-- +-- A tree traversal that tries to propagate conflict sets +-- up the tree from the leaves, and thereby cut branches. +-- All the tricky things are done in the function 'combine'. +backjump :: Tree a -> Tree (Maybe (ConflictSet QPN)) +backjump = snd . cata go + where + go (FailF c fr) = (Just c, Fail c fr) + go (DoneF rdm ) = (Nothing, Done rdm) + go (PChoiceF qpn _ ts) = (c, PChoice qpn c (P.fromList ts')) + where + ~(c, ts') = combine (P qpn) (P.toList ts) S.empty + go (FChoiceF qfn _ b m ts) = (c, FChoice qfn c b m (P.fromList ts')) + where + ~(c, ts') = combine (F qfn) (P.toList ts) S.empty + go (SChoiceF qsn _ b ts) = (c, SChoice qsn c b (P.fromList ts')) + where + ~(c, ts') = combine (S qsn) (P.toList ts) S.empty + go (GoalChoiceF ts) = (c, GoalChoice (P.fromList ts')) + where + ~(cs, ts') = unzip $ L.map (\ (k, (x, v)) -> (x, (k, v))) $ P.toList ts + c = case cs of [] -> Nothing + d : _ -> d + +-- | The 'combine' function is at the heart of backjumping. It takes +-- the variable we're currently considering, and a list of children +-- annotated with their respective conflict sets, and an accumulator +-- for the result conflict set. It returns a combined conflict set +-- for the parent node, and a (potentially shortened) list of children +-- with the annotations removed. +-- +-- It is *essential* that we produce the results as early as possible. +-- In particular, we have to produce the list of children prior to +-- traversing the entire list -- otherwise we lose the desired behaviour +-- of being able to traverse the tree from left to right incrementally. +-- +-- We can shorten the list of children if we find an individual conflict +-- set that does not contain the current variable. In this case, we can +-- just lift the conflict set to the current level, because the current +-- level cannot possibly have contributed to this conflict, so no other +-- choice at the current level would avoid the conflict. +-- +-- If any of the children might contain a successful solution +-- (indicated by Nothing), then Nothing will be the combined +-- conflict set. If all children contain conflict sets, we can +-- take the union as the combined conflict set. +combine :: Var QPN -> [(a, (Maybe (ConflictSet QPN), b))] -> + ConflictSet QPN -> (Maybe (ConflictSet QPN), [(a, b)]) +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) + +-- | Naive backtracking exploration of the search tree. This will yield correct +-- assignments only once the tree itself is validated. +explore :: Alternative m => Tree a -> (Assignment -> m (Assignment, RevDepMap)) +explore = cata go + where + go (FailF _ _) _ = A.empty + go (DoneF rdm) a = pure (a, rdm) + 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 + ts + go (FChoiceF qfn _ _ _ ts) (A pa fa sa) = + asum $ -- try children in order, + P.mapWithKey -- when descending ... + (\ k r -> r (A pa (M.insert qfn k fa) sa)) $ -- record the flag choice + ts + go (SChoiceF qsn _ _ ts) (A pa fa sa) = + asum $ -- try children in order, + P.mapWithKey -- when descending ... + (\ k r -> r (A pa fa (M.insert qsn k sa))) $ -- record the flag choice + ts + go (GoalChoiceF ts) a = + casePSQ ts A.empty -- empty goal choice is an internal error + (\ _k v _xs -> v a) -- commit to the first goal choice + +-- | Version of 'explore' that returns a 'Log'. +exploreLog :: Tree (Maybe (ConflictSet QPN)) -> (Assignment -> Log Message (Assignment, RevDepMap)) +exploreLog = cata go + where + go (FailF c fr) _ = failWith (Failure c fr) + go (DoneF rdm) a = succeedWith Success (a, rdm) + go (PChoiceF qpn c ts) (A pa fa sa) = + backjumpInfo c $ + asum $ -- try children in order, + P.mapWithKey -- when descending ... + (\ k r -> tryWith (TryP (PI qpn k)) $ -- 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) = + backjumpInfo c $ + asum $ -- try children in order, + P.mapWithKey -- when descending ... + (\ k r -> tryWith (TryF qfn k) $ -- log and ... + r (A pa (M.insert qfn k fa) sa)) -- record the pkg choice + ts + go (SChoiceF qsn c _ ts) (A pa fa sa) = + backjumpInfo c $ + asum $ -- try children in order, + P.mapWithKey -- when descending ... + (\ k r -> tryWith (TryS qsn k) $ -- log and ... + r (A pa fa (M.insert qsn k sa))) -- record the pkg choice + ts + go (GoalChoiceF ts) a = + casePSQ ts + (failWith (Failure S.empty EmptyGoalChoice)) -- empty goal choice is an internal error + (\ k v _xs -> continueWith (Next (close k)) (v a)) -- commit to the first goal choice + +-- | Add in information about pruned trees. +-- +-- TODO: This isn't quite optimal, because we do not merely report the shape of the +-- tree, but rather make assumptions about where that shape originated from. It'd be +-- better if the pruning itself would leave information that we could pick up at this +-- point. +backjumpInfo :: Maybe (ConflictSet QPN) -> Log Message a -> Log Message a +backjumpInfo c m = m <|> case c of -- important to produce 'm' before matching on 'c'! + Nothing -> A.empty + Just cs -> failWith (Failure cs Backjump) + +-- | Interface. +exploreTree :: Alternative m => Tree a -> m (Assignment, RevDepMap) +exploreTree t = explore t (A M.empty M.empty M.empty) + +-- | Interface. +exploreTreeLog :: Tree (Maybe (ConflictSet QPN)) -> Log Message (Assignment, RevDepMap) +exploreTreeLog t = exploreLog t (A M.empty M.empty M.empty) diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Flag.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Flag.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Flag.hs @@ -0,0 +1,71 @@ +module Distribution.Client.Dependency.Modular.Flag where + +import Data.Map as M +import Prelude hiding (pi) + +import Distribution.PackageDescription hiding (Flag) -- from Cabal + +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Types (OptionalStanza(..)) + +-- | Flag name. Consists of a package instance and the flag identifier itself. +data FN qpn = FN (PI qpn) Flag + deriving (Eq, Ord, Show) + +-- | 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 } + deriving (Eq, Ord, Show) + +-- | Flag defaults. +type FlagInfo = Map Flag FInfo + +-- | Qualified flag name. +type QFN = FN QPN + +-- | Stanza name. Paired with a package name, much like a flag. +data SN qpn = SN (PI qpn) OptionalStanza + deriving (Eq, Ord, Show) + +instance Functor SN where + fmap f (SN x y) = SN (fmap f x) y + +-- | Qualified stanza name. +type QSN = SN QPN + +unStanza :: OptionalStanza -> String +unStanza TestStanzas = "test" +unStanza BenchStanzas = "bench" + +showQFNBool :: QFN -> Bool -> String +showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b + +showQSNBool :: QSN -> Bool -> String +showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b + +showFBool :: FN qpn -> Bool -> String +showFBool (FN _ f) True = "+" ++ unFlag f +showFBool (FN _ f) False = "-" ++ unFlag f + +showSBool :: SN qpn -> Bool -> String +showSBool (SN _ s) True = "*" ++ unStanza s +showSBool (SN _ s) False = "!" ++ unStanza s + +showQFN :: QFN -> String +showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f + +showQSN :: QSN -> String +showQSN (SN pi f) = showPI pi ++ ":" ++ unStanza f diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Index.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Index.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Index.hs @@ -0,0 +1,33 @@ +module Distribution.Client.Dependency.Modular.Index where + +import Data.List as L +import Data.Map as M +import Prelude hiding (pi) + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Tree + +-- | 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. +-- 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) + 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) diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs @@ -0,0 +1,184 @@ +module Distribution.Client.Dependency.Modular.IndexConversion where + +import Data.List as L +import Data.Map as M +import Data.Maybe +import Prelude hiding (pi) + +import qualified Distribution.Client.PackageIndex as CI +import Distribution.Client.Types +import Distribution.Compiler +import Distribution.InstalledPackageInfo as IPI +import Distribution.Package -- from Cabal +import Distribution.PackageDescription as PD -- from Cabal +import qualified Distribution.Simple.PackageIndex as SI +import Distribution.System + +import Distribution.Client.Dependency.Modular.Dependency as D +import Distribution.Client.Dependency.Modular.Flag as F +import Distribution.Client.Dependency.Modular.Index +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Tree +import Distribution.Client.Dependency.Modular.Version + +-- | Convert both the installed package index and the source package +-- index into one uniform solver index. +-- +-- We use 'allPackagesBySourcePackageId' for the installed package index +-- because that returns us several instances of the same package and version +-- in order of preference. This allows us in principle to \"shadow\" +-- packages if there are several installed packages of the same version. +-- There are currently some shortcomings in both GHC and Cabal in +-- resolving these situations. However, the right thing to do is to +-- fix the problem there, so for now, shadowing is only activated if +-- explicitly requested. +convPIs :: OS -> Arch -> CompilerId -> Bool -> + SI.PackageIndex -> CI.PackageIndex SourcePackage -> Index +convPIs os arch cid sip iidx sidx = + mkIndex (convIPI' sip iidx ++ convSPI' os arch cid 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' sip idx = + -- apply shadowing whenever there are multple installed packages with + -- the same version + [ maybeShadow (convIP idx pkg) + | (_pkgid, pkgs) <- SI.allPackagesBySourcePackageId idx + , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ] + where + + -- shadowing is recorded in the package info + shadow (pn, i, PInfo fdeps fds encs _) | sip = (pn, i, PInfo fdeps fds encs (Just Shadowed)) + shadow x = x + +convIPI :: Bool -> SI.PackageIndex -> Index +convIPI sip = mkIndex . convIPI' sip + +-- | Convert a single installed package into the solver-specific format. +convIP :: SI.PackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) +convIP idx ipi = + let ipid = 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) +-- TODO: Installed packages should also store their encapsulations! + +-- | Convert dependencies specified by an installed package id into +-- flagged dependencies of the solver. +-- +-- May return Nothing if the package can't be found in the index. That +-- indicates that the original package having this dependency is broken +-- and should be ignored. +convIPId :: PN -> SI.PackageIndex -> 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') [])))) + +-- | Convert a cabal-install source package index to the simpler, +-- more uniform index format of the solver. +convSPI' :: OS -> Arch -> CompilerId -> + CI.PackageIndex SourcePackage -> [(PN, I, PInfo)] +convSPI' os arch cid = L.map (convSP os arch cid) . CI.allPackages + +convSPI :: OS -> Arch -> CompilerId -> + CI.PackageIndex SourcePackage -> Index +convSPI os arch cid = mkIndex . convSPI' os arch cid + +-- | 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) = + let i = I pv InRepo + in (pn, i, convGPD os arch cid (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 -> + PI PN -> GenericPackageDescription -> PInfo +convGPD os arch cid pi + (GenericPackageDescription _ flags libs exes tests benchs) = + let + fds = flagInfo flags + in + PInfo + (maybe [] (convCondTree os arch cid pi fds (const True) ) libs ++ + concatMap (convCondTree os arch cid pi fds (const True) . snd) exes ++ + (prefix (Stanza (SN pi TestStanzas)) + (L.map (convCondTree os arch cid pi fds (const True) . snd) tests)) ++ + (prefix (Stanza (SN pi BenchStanzas)) + (L.map (convCondTree os arch cid pi fds (const True) . snd) benchs))) + fds + [] -- TODO: add encaps + Nothing + +prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> [FlaggedDeps qpn] -> FlaggedDeps 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 condition trees to flagged dependencies. +convCondTree :: OS -> Arch -> CompilerId -> 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 + | otherwise = [] + +-- | Branch interpreter. +-- +-- Here, we try to simplify one of Cabal's condition tree branches into the +-- solver's flagged dependency format, which is weaker. Condition trees can +-- contain complex logical expression composed from flag choices and special +-- flags (such as architecture, or compiler flavour). We try to evaluate the +-- special flags and subsequently simplify to a tree that only depends on +-- simple flag choices. +convBranch :: OS -> Arch -> CompilerId -> + PI PN -> FlagInfo -> + (a -> Bool) -> -- how to detect if a branch is active + (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') + where + go :: Condition ConfVar -> + FlaggedDeps PN -> FlaggedDeps PN -> FlaggedDeps 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 (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 + | otherwise = f + +-- | Convert a Cabal dependency to a solver-specific dependency. +convDep :: PN -> Dependency -> Dep PN +convDep pn' (Dependency pn vr) = Dep pn (Constrained [(vr, Goal (P pn') [])]) + +-- | Convert 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') [])]) diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs @@ -0,0 +1,108 @@ +module Distribution.Client.Dependency.Modular.Log where + +import Control.Applicative +import Data.List as L +import Data.Set as S + +import Distribution.Client.Dependency.Types -- from Cabal + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Message +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Tree (FailReason(..)) + +-- | The 'Log' datatype. +-- +-- Represents the progress of a computation lazily. +-- +-- Parameterized over the type of actual messages and the final result. +type Log m a = Progress m () a + +runLog :: Log m a -> ([m], Maybe a) +runLog (Done x) = ([], Just x) +runLog (Fail _) = ([], Nothing) +runLog (Step m p) = let + (ms, r) = runLog p + in + (m : ms, r) + +-- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps. +-- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the +-- limit is 'Just 0', backtracking is completely disabled. +logToProgress :: Maybe Int -> Log Message a -> Progress String String a +logToProgress mbj l = let + (ms, s) = runLog l + (es, e) = proc 0 ms -- catch first error (always) + (ns, t) = case mbj of + Nothing -> (ms, Nothing) + Just n -> proc n ms + -- prefer first error over later error + r = case t of + Nothing -> case s of + Nothing -> e + Just _ -> Nothing + Just _ -> e + in go es es -- trace for first error + (showMessages (const True) True ns) -- shortened run + r s + where + -- Proc takes the allowed number of backjumps and a list of messages and explores the + -- message list until the maximum number of backjumps has been reached. The log until + -- that point as well as whether we have encountered an error or not are returned. + proc :: Int -> [Message] -> ([Message], Maybe (ConflictSet QPN)) + proc _ [] = ([], Nothing) + proc n ( Failure cs Backjump : xs@(Leave : Failure cs' Backjump : _)) + | cs == cs' = proc n xs -- repeated backjumps count as one + proc 0 ( Failure cs Backjump : _ ) = ([], Just cs) + proc n (x@(Failure _ Backjump) : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc (n - 1) xs) + proc n (x : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc n xs) + + -- This function takes a lot of arguments. The first two are both supposed to be + -- the log up to the first error. That's the error that will always be printed in + -- case we do not find a solution. We pass this log twice, because we evaluate it + -- in parallel with the full log, but we also want to retain the reference to its + -- beginning for when we print it. This trick prevents a space leak! + -- + -- The thirs argument is the full log, the fifth and six error conditions. + -- + -- The order of arguments is important! In particular 's' must not be evaluated + -- unless absolutely necessary. It contains the final result, and if we shortcut + -- with an error due to backjumping, evaluating 's' would still require traversing + -- the entire tree. + go ms (_ : ns) (x : xs) r s = Step x (go ms ns xs r s) + go ms [] (x : xs) r s = Step x (go ms [] xs r s) + go ms _ [] (Just cs) _ = Fail ("Could not resolve dependencies:\n" ++ + unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms)) + go _ _ [] _ (Just s) = Done s + go _ _ [] _ _ = Fail ("Could not resolve dependencies.") -- should not happen + +logToProgress' :: Log Message a -> Progress String String a +logToProgress' l = let + (ms, r) = runLog l + xs = showMessages (const True) True ms + in go xs r + where + go [x] Nothing = Fail x + go [] Nothing = Fail "" + go [] (Just r) = Done r + go (x:xs) r = Step x (go xs r) + + +runLogIO :: Log Message a -> IO (Maybe a) +runLogIO x = + do + let (ms, r) = runLog x + putStr (unlines $ showMessages (const True) True ms) + return r + +failWith :: m -> Log m a +failWith m = Step m (Fail ()) + +succeedWith :: m -> a -> Log m a +succeedWith m x = Step m (Done x) + +continueWith :: m -> Log m a -> Log m a +continueWith = Step + +tryWith :: Message -> Log Message a -> Log Message a +tryWith m x = Step m (Step Enter x) <|> failWith Leave diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs @@ -0,0 +1,98 @@ +module Distribution.Client.Dependency.Modular.Message where + +import qualified Data.List as L +import Prelude hiding (pi) + +import Distribution.Text -- from Cabal + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Tree + +data Message = + Enter -- ^ increase indentation level + | Leave -- ^ decrease indentation level + | TryP (PI QPN) + | TryF QFN Bool + | TryS QSN Bool + | Next (Goal QPN) + | Success + | Failure (ConflictSet QPN) FailReason + +-- | Transforms the structured message type to actual messages (strings). +-- +-- Takes an additional relevance predicate. The predicate gets a stack of goal +-- variables and can decide whether messages regarding these goals are relevant. +-- You can plug in 'const True' if you're interested in a full trace. If you +-- want a slice of the trace concerning a particular conflict set, then plug in +-- a predicate returning 'True' on the empty stack and if the head is in the +-- conflict set. +-- +-- The second argument indicates if the level numbers should be shown. This is +-- recommended for any trace that involves backtracking, because only the level +-- numbers will allow to keep track of backjumps. +showMessages :: ([Var QPN] -> Bool) -> Bool -> [Message] -> [String] +showMessages p sl = go [] 0 + where + 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 (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 (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) + + -- 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) + + -- 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 + | sl && p v = let s = show l + in ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) : xs + | p v = x : xs + | otherwise = xs + +showGRs :: QGoalReasons -> String +showGRs (gr : _) = showGR gr +showGRs [] = "" + +showGR :: GoalReason QPN -> String +showGR UserGoal = " (user goal)" +showGR (PDependency pi) = " (dependency of " ++ showPI pi ++ ")" +showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b ++ ")" +showGR (SDependency qsn) = " (dependency of " ++ showQSNBool qsn True ++ ")" + +showFR :: ConflictSet QPN -> FailReason -> String +showFR _ InconsistentInitialConstraints = " (inconsistent initial constraints)" +showFR _ (Conflicting ds) = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")" +showFR _ CannotInstall = " (only already installed instances can be used)" +showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" +showFR _ Shadowed = " (shadowed by another installed package with same version)" +showFR _ Broken = " (package is broken)" +showFR _ (GlobalConstraintVersion vr) = " (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 ++ ")" +-- 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)" diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs @@ -0,0 +1,102 @@ +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 +-- 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) +import Data.Traversable +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 + +keys :: PSQ k v -> [k] +keys (PSQ xs) = fmap fst xs + +lookup :: Eq k => k -> PSQ k v -> Maybe v +lookup k (PSQ xs) = S.lookup k xs + +map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2 +map f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs) + +mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v +mapKeys f (PSQ xs) = PSQ (fmap (\ (k, v) -> (f k, v)) xs) + +mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b +mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs) + +mapWithKeyState :: (s -> k -> a -> (b, s)) -> PSQ k a -> s -> PSQ k b +mapWithKeyState p (PSQ xs) s0 = + PSQ (foldr (\ (k, v) r s -> case p s k v of + (w, n) -> (k, w) : (r n)) + (const []) xs s0) + +delete :: Eq k => k -> PSQ k a -> PSQ k a +delete k (PSQ xs) = PSQ (snd (partition ((== k) . fst) xs)) + +fromList :: [(k, a)] -> PSQ k a +fromList = PSQ + +cons :: k -> a -> PSQ k a -> PSQ k a +cons k x (PSQ xs) = PSQ ((k, x) : xs) + +snoc :: PSQ k a -> k -> a -> PSQ k a +snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)]) + +casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r +casePSQ (PSQ xs) n c = + case xs of + [] -> n + (k, v) : ys -> c k v (PSQ ys) + +splits :: PSQ k a -> PSQ k (a, PSQ k a) +splits xs = + casePSQ xs + (PSQ []) + (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits ys))) + +sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a +sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs) + +sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a +sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs) + +filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a +filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs) + +filter :: (a -> Bool) -> PSQ k a -> PSQ k a +filter p (PSQ xs) = PSQ (S.filter (p . snd) xs) + +length :: PSQ k a -> Int +length (PSQ xs) = S.length xs + +-- | "Lazy length". +-- +-- Only approximates the length, but doesn't force the list. +llength :: PSQ k a -> Int +llength (PSQ []) = 0 +llength (PSQ (_:[])) = 1 +llength (PSQ (_:_:[])) = 2 +llength (PSQ _) = 3 + +null :: PSQ k a -> Bool +null (PSQ xs) = S.null xs + +toList :: PSQ k a -> [(k, a)] +toList (PSQ xs) = xs diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Package.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Package.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Package.hs @@ -0,0 +1,113 @@ +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 + +import Distribution.Client.Dependency.Modular.Version + +-- | A package name. +type PN = PackageName + +-- | Unpacking a package name. +unPN :: PN -> String +unPN (PackageName pn) = pn + +-- | Package version. A package name plus a version number. +type PV = PackageId + +-- | Qualified package version. +type QPV = Q PV + +-- | Package id. Currently just a black-box string. +type PId = InstalledPackageId + +-- | Location. Info about whether a package is installed or not, and where +-- exactly it is located. For installed packages, uniquely identifies the +-- package instance via its 'PId'. +-- +-- TODO: More information is needed about the repo. +data Loc = Inst PId | InRepo + deriving (Eq, Ord, Show) + +-- | Instance. A version number and a location. +data I = I Ver Loc + deriving (Eq, Ord, Show) + +-- | String representation of an instance. +showI :: I -> String +showI (I v InRepo) = showVer v +showI (I v (Inst (InstalledPackageId i))) = showVer v ++ "/installed" ++ shortId i + where + -- A hack to extract the beginning of the package ABI hash + shortId = snip (splitAt 4) (++ "...") . + snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':) + snip p f xs = case p xs of + (ys, zs) -> (if L.null zs then id else f) ys + +-- | Package instance. A package name and an instance. +data PI qpn = PI qpn I + deriving (Eq, Ord, Show) + +-- | String representation of a package instance. +showPI :: PI QPN -> String +showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i + +-- | Checks if a package instance corresponds to an installed package. +instPI :: PI qpn -> Bool +instPI (PI _ (I _ (Inst _))) = True +instPI _ = False + +instI :: I -> Bool +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.) +type PP = [PN] + +-- | String representation of a package path. +showPP :: PP -> String +showPP = intercalate "." . L.map display . reverse + + +-- | A qualified entity. Pairs a package path with the entity. +data Q a = Q PP a + deriving (Eq, Ord, Show) + +-- | Standard string representation of a qualified entity. +showQ :: (a -> String) -> (Q a -> String) +showQ showa (Q [] x) = showa x +showQ showa (Q pp x) = showPP pp ++ "." ++ showa x + +-- | Qualified package name. +type QPN = Q PN + +-- | String representation of a qualified package path. +showQPN :: QPN -> String +showQPN = showQ display + +-- | 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 + +unQualify :: Q a -> a +unQualify (Q _ x) = x diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs @@ -0,0 +1,275 @@ +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 +import Data.Monoid +import Data.Ord + +import Distribution.Client.Dependency.Types + ( PackageConstraint(..), PackagePreferences(..), InstalledPreference(..) ) +import Distribution.Client.Types + ( OptionalStanza(..) ) + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.PSQ as P +import Distribution.Client.Dependency.Modular.Tree +import Distribution.Client.Dependency.Modular.Version + +-- | Generic abstraction for strategies that just rearrange the package order. +-- Only packages that match the given predicate are reordered. +packageOrderFor :: (PN -> Bool) -> (PN -> I -> I -> Ordering) -> Tree a -> Tree a +packageOrderFor p cmp = trav go + where + go (PChoiceF v@(Q _ pn) r cs) + | p pn = PChoiceF v r (P.sortByKeys (flip (cmp pn)) cs) + | otherwise = PChoiceF v r cs + go x = x + +-- | Ordering that treats preferred versions as greater than non-preferred +-- versions. +preferredVersionsOrdering :: VR -> Ver -> Ver -> Ordering +preferredVersionsOrdering vr v1 v2 = + compare (checkVR vr v1) (checkVR vr v2) + +-- | Traversal that tries to establish package preferences (not constraints). +-- Works by reordering choice nodes. +preferPackagePreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a +preferPackagePreferences pcs = packageOrderFor (const True) preference + where + preference pn i1@(I v1 _) i2@(I v2 _) = + let PackagePreferences vr ipref = pcs pn + in preferredVersionsOrdering vr v1 v2 `mappend` -- combines lexically + locationsOrdering ipref i1 i2 + + -- Note that we always rank installed before uninstalled, and later + -- versions before earlier, but we can change the priority of the + -- two orderings. + locationsOrdering PreferInstalled v1 v2 = + preferInstalledOrdering v1 v2 `mappend` preferLatestOrdering v1 v2 + locationsOrdering PreferLatest v1 v2 = + preferLatestOrdering v1 v2 `mappend` preferInstalledOrdering v1 v2 + +-- | Ordering that treats installed instances as greater than uninstalled ones. +preferInstalledOrdering :: I -> I -> Ordering +preferInstalledOrdering (I _ (Inst _)) (I _ (Inst _)) = EQ +preferInstalledOrdering (I _ (Inst _)) _ = GT +preferInstalledOrdering _ (I _ (Inst _)) = LT +preferInstalledOrdering _ _ = EQ + +-- | Compare instances by their version numbers. +preferLatestOrdering :: I -> I -> Ordering +preferLatestOrdering (I v1 _) (I v2 _) = compare v1 v2 + +-- | Helper function that tries to enforce a single package constraint on a +-- given instance for a P-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintP :: 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 + +-- | 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 + +-- | 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 + +-- | 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 QGoalReasons -> Tree QGoalReasons +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 + (M.findWithDefault [] pn pcs) + in PChoiceF qpn gr (P.mapWithKey g ts) + go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m ts) = + let c = toConflictSet (Goal (F qfn) gr) + -- compose the transformation functions for each of the relevant constraint + g = \ b -> foldl (\ h pc -> h . processPackageConstraintF f c b pc) id + (M.findWithDefault [] pn pcs) + in FChoiceF qfn gr tr m (P.mapWithKey g ts) + go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) = + let c = toConflictSet (Goal (S qsn) gr) + -- compose the transformation functions for each of the relevant constraint + g = \ b -> foldl (\ h pc -> h . processPackageConstraintS f c b pc) id + (M.findWithDefault [] pn pcs) + in SChoiceF qsn gr tr (P.mapWithKey g ts) + go x = x + +-- | Transformation that tries to enforce manual flags. Manual flags +-- can only be re-set explicitly by the user. This transformation should +-- be run after user preferences have been enforced. For manual flags, +-- it disables all but the first non-disabled choice. +enforceManualFlags :: Tree QGoalReasons -> Tree QGoalReasons +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) + where + isDisabled (_, Fail _ _) = True + isDisabled _ = False + go x = x + +-- | Prefer installed packages over non-installed packages, generally. +-- All installed packages or non-installed packages are treated as +-- equivalent. +preferInstalled :: Tree a -> Tree a +preferInstalled = packageOrderFor (const True) (const preferInstalledOrdering) + +-- | Prefer packages with higher version numbers over packages with +-- lower version numbers, for certain packages. +preferLatestFor :: (PN -> Bool) -> Tree a -> Tree a +preferLatestFor p = packageOrderFor p (const preferLatestOrdering) + +-- | Prefer packages with higher version numbers over packages with +-- lower version numbers, for all packages. +preferLatest :: Tree a -> Tree a +preferLatest = preferLatestFor (const True) + +-- | Require installed packages. +requireInstalled :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a) +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 + where + installed (I _ (Inst _)) x = x + installed _ _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall + go x = x + +-- | Avoid reinstalls. +-- +-- This is a tricky strategy. If a package version is installed already and the +-- same version is available from a repo, the repo version will never be chosen. +-- This would result in a reinstall (either destructively, or potentially, +-- shadowing). The old instance won't be visible or even present anymore, but +-- other packages might have depended on it. +-- +-- TODO: It would be better to actually check the reverse dependencies of installed +-- packages. If they're not depended on, then reinstalling should be fine. Even if +-- they are, perhaps this should just result in trying to reinstall those other +-- packages as well. However, doing this all neatly in one pass would require to +-- change the builder, or at least to change the goal set after building. +avoidReinstalls :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a) +avoidReinstalls p = trav go + where + go (PChoiceF qpn@(Q _ pn) i@(gr, _) cs) + | p pn = PChoiceF qpn i disableReinstalls + | otherwise = PChoiceF qpn i cs + where + disableReinstalls = + let installed = [ v | (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 + go x = x + +-- | Always choose the first goal in the list next, abandoning all +-- other choices. +-- +-- This is unnecessary for the default search strategy, because +-- it descends only into the first goal choice anyway, +-- but may still make sense to just reduce the tree size a bit. +firstGoal :: Tree a -> Tree a +firstGoal = trav go + where + go (GoalChoiceF xs) = casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t) + go x = x + -- Note that we keep empty choice nodes, because they mean success. + +-- | Transformation that tries to make a decision on base as early as +-- possible. In nearly all cases, there's a single choice for the base +-- package. Also, fixing base early should lead to better error messages. +preferBaseGoalChoice :: Tree a -> Tree a +preferBaseGoalChoice = trav go + where + go (GoalChoiceF xs) = GoalChoiceF (P.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 + +-- | 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 +-- are immediately considered inconsistent), and choices with 1 +-- branch will also be preferred (as they don't involve choice). +preferEasyGoalChoices :: Tree a -> Tree a +preferEasyGoalChoices = trav go + where + 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 + where + go (GoalChoiceF xs) = GoalChoiceF (P.sortBy defer xs) + go x = x + + defer :: Tree a -> Tree a -> Ordering + defer (FChoice _ _ True _ _) _ = GT + defer _ (FChoice _ _ True _ _) = LT + defer _ _ = EQ + +-- | Variant of 'preferEasyGoalChoices'. +-- +-- Only approximates the number of choices in the branches. Less accurate, +-- more efficient. +lpreferEasyGoalChoices :: Tree a -> Tree a +lpreferEasyGoalChoices = trav go + where + go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing lchoices) xs) + go x = x + +-- | Variant of 'preferEasyGoalChoices'. +-- +-- I first thought that using a paramorphism might be faster here, +-- but it doesn't seem to make any difference. +preferEasyGoalChoices' :: Tree a -> Tree a +preferEasyGoalChoices' = para (inn . go) + where + go (GoalChoiceF xs) = GoalChoiceF (P.map fst (P.sortBy (comparing (choices . snd)) xs)) + go x = fmap fst x + diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs @@ -0,0 +1,54 @@ +module Distribution.Client.Dependency.Modular.Solver where + +import Data.Map as M + +import Distribution.Client.Dependency.Types + +import Distribution.Client.Dependency.Modular.Assignment +import Distribution.Client.Dependency.Modular.Builder +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Explore +import Distribution.Client.Dependency.Modular.Index +import Distribution.Client.Dependency.Modular.Log +import Distribution.Client.Dependency.Modular.Message +import Distribution.Client.Dependency.Modular.Package +import qualified Distribution.Client.Dependency.Modular.Preference as P +import Distribution.Client.Dependency.Modular.Validate + +-- | Various options for the modular solver. +data SolverConfig = SolverConfig { + preferEasyGoalChoices :: Bool, + independentGoals :: Bool, + avoidReinstalls :: Bool, + shadowPkgs :: 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 + Log Message (Assignment, RevDepMap) +solve sc idx userPrefs userConstraints userGoals = + explorePhase $ + heuristicsPhase $ + preferencesPhase $ + validationPhase $ + prunePhase $ + buildPhase + where + explorePhase = exploreTreeLog . backjump + heuristicsPhase = P.firstGoal . -- after doing goal-choice heuristics, commit to the first choice (saves space) + if preferEasyGoalChoices sc + then P.preferBaseGoalChoice . P.deferDefaultFlagChoices . P.lpreferEasyGoalChoices + else P.preferBaseGoalChoice + preferencesPhase = P.preferPackagePreferences userPrefs + validationPhase = P.enforceManualFlags . -- can only be done after user constraints + P.enforcePackageConstraints userConstraints . + 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 diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs @@ -0,0 +1,147 @@ +module Distribution.Client.Dependency.Modular.Tree where + +import Control.Applicative +import Control.Monad hiding (mapM) +import Data.Foldable +import Data.Traversable +import Prelude hiding (foldr, mapM) + +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 + +-- | 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 + | Done RevDepMap + | Fail (ConflictSet QPN) FailReason + deriving (Eq, Show) + -- 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. + +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 + +data FailReason = InconsistentInitialConstraints + | Conflicting [Dep QPN] + | CannotInstall + | CannotReinstall + | Shadowed + | Broken + | GlobalConstraintVersion VR + | GlobalConstraintInstalled + | GlobalConstraintSource + | GlobalConstraintFlag + | ManualFlag + | BuildFailureNotInIndex PN + | MalformedFlagChoice QFN + | MalformedStanzaChoice QSN + | EmptyGoalChoice + | Backjump + 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) + | DoneF RevDepMap + | FailF (ConflictSet QPN) FailReason + +out :: Tree a -> TreeF a (Tree a) +out (PChoice p i ts) = PChoiceF p i ts +out (FChoice p i b m ts) = FChoiceF p i b m ts +out (SChoice p i b ts) = SChoiceF p i b ts +out (GoalChoice ts) = GoalChoiceF ts +out (Done x ) = DoneF x +out (Fail c x ) = FailF c x + +inn :: TreeF a (Tree a) -> Tree a +inn (PChoiceF p i ts) = PChoice p i ts +inn (FChoiceF p i b m ts) = FChoice p i b m ts +inn (SChoiceF p i b ts) = SChoice p i b ts +inn (GoalChoiceF ts) = GoalChoice ts +inn (DoneF x ) = Done x +inn (FailF c x ) = Fail c x + +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 + +-- | Determines whether a tree is active, i.e., isn't a failure node. +active :: Tree a -> Bool +active (Fail _ _) = False +active _ = True + +-- | Determines how many active choices are available in a node. Note that we +-- count goal choices as having one choice, always. +choices :: Tree a -> Int +choices (PChoice _ _ ts) = P.length (P.filter active ts) +choices (FChoice _ _ _ _ ts) = P.length (P.filter active ts) +choices (SChoice _ _ _ ts) = P.length (P.filter active ts) +choices (GoalChoice _ ) = 1 +choices (Done _ ) = 1 +choices (Fail _ _ ) = 0 + +-- | Variant of 'choices' that only approximates the number of choices, +-- using 'llength'. +lchoices :: Tree a -> Int +lchoices (PChoice _ _ ts) = P.llength (P.filter active ts) +lchoices (FChoice _ _ _ _ ts) = P.llength (P.filter active ts) +lchoices (SChoice _ _ _ ts) = P.llength (P.filter active ts) +lchoices (GoalChoice _ ) = 1 +lchoices (Done _ ) = 1 +lchoices (Fail _ _ ) = 0 + +-- | Catamorphism on trees. +cata :: (TreeF a b -> b) -> Tree a -> b +cata phi x = (phi . fmap (cata phi) . out) x + +trav :: (TreeF a (Tree b) -> TreeF b (Tree b)) -> Tree a -> Tree b +trav psi x = cata (inn . psi) x + +-- | Paramorphism on trees. +para :: (TreeF a (b, Tree a) -> b) -> Tree a -> b +para phi = phi . fmap (\ x -> (para phi x, x)) . out + +cataM :: Monad m => (TreeF a b -> m b) -> Tree a -> m b +cataM phi = phi <=< mapM (cataM phi) <=< return . out + +-- | Anamorphism on trees. +ana :: (b -> TreeF a b) -> b -> Tree a +ana psi = inn . fmap (ana psi) . psi + +anaM :: Monad m => (b -> m (TreeF a b)) -> b -> m (Tree a) +anaM psi = return . inn <=< mapM (anaM psi) <=< psi diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs @@ -0,0 +1,232 @@ +module Distribution.Client.Dependency.Modular.Validate where + +-- Validation of the tree. +-- +-- The task here is to make sure all constraints hold. After validation, any +-- assignment returned by exploration of the tree should be a complete valid +-- assignment, i.e., actually constitute a solution. + +import Control.Applicative +import Control.Monad.Reader hiding (sequence) +import Data.List as L +import Data.Map as M +import Data.Traversable +import Prelude hiding (sequence) + +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.PSQ as P +import Distribution.Client.Dependency.Modular.Tree + +-- 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 +-- of currently active constraints that we pass down the node. +-- +-- We aim at detecting inconsistent states as early as possible. +-- +-- Whenever we make a choice, there are two things that need to happen: +-- +-- (1) We must check that the choice is consistent with the currently +-- active constraints. +-- +-- (2) The choice increases the set of active constraints. For the new +-- active constraints, we must check that they are consistent with +-- the current state. +-- +-- We can actually merge (1) and (2) by saying the the current choice is +-- a new active constraint, fixing the choice. +-- +-- If a test fails, we have detected an inconsistent state. We can +-- disable the current subtree and do not have to traverse it any further. +-- +-- We need a good way to represent the current state, i.e., the current +-- set of active constraints. Since the main situation where we have to +-- search in it is (1), it seems best to store the state by package: for +-- every package, we store which versions are still allowed. If for any +-- package, we have inconsistent active constraints, we can also stop. +-- This is a particular way to read task (2): +-- +-- (2, weak) We only check if the new constraints are consistent with +-- the choices we've already made, and add them to the active set. +-- +-- (2, strong) We check if the new constraints are consistent with the +-- choices we've already made, and the constraints we already have. +-- +-- It currently seems as if we're implementing the weak variant. However, +-- when used together with 'preferEasyGoalChoices', we will find an +-- inconsistent state in the very next step. +-- +-- What do we do about flags? +-- +-- Like for packages, we store the flag choices we have already made. +-- Now, regarding (1), we only have to test whether we've decided the +-- current flag before. Regarding (2), the interesting bit is in discovering +-- the new active constraints. To this end, we look up the constraints for +-- the package the flag belongs to, and traverse its flagged dependencies. +-- Wherever we find the flag in question, we start recording dependencies +-- underneath as new active dependencies. If we encounter other flags, we +-- check if we've chosen them already and either proceed or stop. + +-- | The state needed during validation. +data ValidateState = VS { + index :: Index, + saved :: Map QPN (FlaggedDeps QPN), -- saved, scoped, dependencies + pa :: PreAssignment +} + +type Validate = Reader ValidateState + +validate :: Tree (QGoalReasons, Scope) -> Validate (Tree QGoalReasons) +validate = cata go + where + go :: TreeF (QGoalReasons, Scope) (Validate (Tree QGoalReasons)) -> Validate (Tree QGoalReasons) + + 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) = + do + -- Flag choices may occur repeatedly (because they can introduce new constraints + -- in various places). However, subsequent choices must be consistent. We thereby + -- collapse repeated flag choice nodes. + PA _ pfa _ <- asks pa -- obtain current flag-preassignment + case M.lookup qfn pfa of + Just rb -> -- flag has already been assigned; collapse choice to the correct branch + case P.lookup rb ts of + Just t -> goF qfn gr rb t + Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn) + Nothing -> -- flag choice is new, follow both branches + FChoice qfn gr b m <$> sequence (P.mapWithKey (goF qfn gr) ts) + go (SChoiceF qsn (gr, _sc) b ts) = + do + -- Optional stanza choices are very similar to flag choices. + PA _ _ psa <- asks pa -- obtain current stanza-preassignment + case M.lookup qsn psa of + Just rb -> -- stanza choice has already been made; collapse choice to the correct branch + case P.lookup rb ts of + Just t -> goS qsn gr rb t + Nothing -> return $ Fail (toConflictSet (Goal (S qsn) gr)) (MalformedStanzaChoice qsn) + Nothing -> -- stanza choice is new, follow both branches + SChoice qsn gr b <$> sequence (P.mapWithKey (goS qsn gr) ts) + + -- We don't need to do anything for goal choices or failure nodes. + go (GoalChoiceF ts) = GoalChoice <$> sequence ts + go (DoneF rdm ) = pure (Done rdm) + go (FailF c fr ) = pure (Fail c fr) + + -- What to do for package nodes ... + goP :: QPN -> QGoalReasons -> Scope -> I -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons) + goP qpn@(Q _pp pn) gr sc 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 + -- the new active constraints are given by the instance we have chosen, + -- plus the dependency information we have for that instance + let goal = Goal (P qpn) gr + let newactives = Dep qpn (Fixed i goal) : L.map (resetGoal goal) (extractDeps pfa psa qdeps) + -- We now try to extend the partial assignment with the new active constraints. + let mnppa = extend (P qpn) ppa newactives + -- In case we continue, we save the scoped dependencies + let nsvd = M.insert qpn qdeps svd + case mfr of + Just fr -> -- The index marks this as an invalid choice. We can stop. + return (Fail (toConflictSet goal) fr) + _ -> case mnppa of + Left (c, d) -> -- We have an inconsistency. We can stop. + return (Fail c (Conflicting d)) + Right nppa -> -- We have an updated partial assignment for the recursive validation. + local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r + + -- What to do for flag nodes ... + goF :: QFN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons) + goF qfn@(FN (PI qpn _i) _f) gr b r = do + PA ppa pfa psa <- asks pa -- obtain current preassignment + svd <- asks saved -- obtain saved dependencies + -- Note that there should be saved dependencies for the package in question, + -- because while building, we do not choose flags before we see the packages + -- that define them. + let qdeps = svd ! qpn + -- We take the *saved* dependencies, because these have been qualified in the + -- correct scope. + -- + -- Extend the flag assignment + let npfa = M.insert qfn b pfa + -- We now try to get the new active dependencies we might learn about because + -- we have chosen a new flag. + let newactives = extractNewDeps (F qfn) gr b npfa psa qdeps + -- As in the package case, we try to extend the partial assignment. + case extend (F qfn) ppa newactives of + Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found + Right nppa -> local (\ s -> s { pa = PA nppa npfa psa }) r + + -- What to do for stanza nodes (similar to flag nodes) ... + goS :: QSN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons) + goS qsn@(SN (PI qpn _i) _f) gr b r = do + PA ppa pfa psa <- asks pa -- obtain current preassignment + svd <- asks saved -- obtain saved dependencies + -- Note that there should be saved dependencies for the package in question, + -- because while building, we do not choose flags before we see the packages + -- that define them. + let qdeps = svd ! qpn + -- We take the *saved* dependencies, because these have been qualified in the + -- correct scope. + -- + -- Extend the flag assignment + let npsa = M.insert qsn b psa + -- We now try to get the new active dependencies we might learn about because + -- we have chosen a new flag. + let newactives = extractNewDeps (S qsn) gr b pfa npsa qdeps + -- As in the package case, we try to extend the partial assignment. + case extend (S qsn) ppa newactives of + Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found + Right nppa -> local (\ s -> s { pa = PA nppa pfa npsa }) r + +-- | We try to extract as many concrete dependencies from the given flagged +-- dependencies as possible. We make use of all the flag knowledge we have +-- already acquired. +extractDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN] +extractDeps fa sa deps = do + d <- deps + case d of + Simple sd -> return sd + Flagged qfn _ td fd -> case M.lookup qfn fa of + Nothing -> mzero + Just True -> extractDeps fa sa td + Just False -> extractDeps fa sa fd + Stanza qsn td -> case M.lookup qsn sa of + Nothing -> mzero + Just True -> extractDeps fa sa td + Just False -> [] + +-- | We try to find new dependencies that become available due to the given +-- flag or stanza choice. We therefore look for the choice in question, and then call +-- 'extractDeps' for everything underneath. +extractNewDeps :: Var QPN -> QGoalReasons -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN] +extractNewDeps v gr b fa sa = go + where + go deps = do + d <- deps + case d of + Simple _ -> mzero + Flagged qfn' _ td fd + | v == F qfn' -> L.map (resetGoal (Goal v gr)) $ + if b then extractDeps fa sa td else extractDeps fa sa fd + | otherwise -> case M.lookup qfn' fa of + Nothing -> mzero + Just True -> go td + Just False -> go fd + Stanza qsn' td + | v == S qsn' -> L.map (resetGoal (Goal v gr)) $ + if b then extractDeps fa sa td else [] + | otherwise -> case M.lookup qsn' sa of + Nothing -> mzero + Just True -> go td + Just False -> [] + +-- | Interface. +validateTree :: Index -> Tree (QGoalReasons, Scope) -> Tree QGoalReasons +validateTree idx t = runReader (validate t) (VS idx M.empty (PA M.empty M.empty M.empty)) diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Modular/Version.hs b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Version.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Modular/Version.hs @@ -0,0 +1,43 @@ +module Distribution.Client.Dependency.Modular.Version where + +import qualified Distribution.Version as CV -- from Cabal +import Distribution.Text -- from Cabal + +-- | Preliminary type for versions. +type Ver = CV.Version + +-- | String representation of a version. +showVer :: Ver -> String +showVer = display + +-- | Version range. Consists of a lower and upper bound. +type VR = CV.VersionRange + +-- | String representation of a version range. +showVR :: VR -> String +showVR = display + +-- | Unconstrained version range. +anyVR :: VR +anyVR = CV.anyVersion + +-- | Version range fixing a single version. +eqVR :: Ver -> VR +eqVR = CV.thisVersion + +-- | Intersect two version ranges. +(.&&.) :: VR -> VR -> VR +(.&&.) = CV.intersectVersionRanges + +-- | Simplify a version range. +simplifyVR :: VR -> VR +simplifyVR = CV.simplifyVersionRange + +-- | Checking a version against a version range. +checkVR :: VR -> Ver -> Bool +checkVR = flip CV.withinRange + +-- | Make a version number. +mkV :: [Int] -> Ver +mkV xs = CV.Version xs [] + diff --git a/cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs b/cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs --- a/cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs +++ b/cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs @@ -18,11 +18,14 @@ 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(..) ) + ( SourcePackage(..), ConfiguredPackage(..), InstalledPackage(..) + , enableStanzas ) import Distribution.Client.Dependency.Types ( DependencyResolver, PackageConstraint(..) , PackagePreferences(..), InstalledPreference(..) @@ -106,8 +109,8 @@ where topSortNumber choice = case fst (head choice) of InstalledOnly (InstalledPackageEx _ i _) -> i - SourceOnly (UnconfiguredPackage _ i _) -> i - InstalledAndSource _ (UnconfiguredPackage _ i _) -> i + SourceOnly (UnconfiguredPackage _ i _ _) -> i + InstalledAndSource _ (UnconfiguredPackage _ i _ _) -> i bestByPref pkgname = case packageInstalledPreference of PreferLatest -> @@ -195,7 +198,7 @@ installedConstraints (InstalledPackageEx _ _ deps) = [ (thisPackageVersion dep, True) | dep <- deps ] - availableConstraints (SemiConfiguredPackage _ _ deps) = + availableConstraints (SemiConfiguredPackage _ _ _ deps) = [ (dep, False) | dep <- deps ] addDeps :: Constraints -> [PackageName] -> Constraints @@ -239,7 +242,11 @@ -- the standard 'DependencyResolver' interface. -- topDownResolver :: DependencyResolver -topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver' +topDownResolver platform comp installedPkgIndex sourcePkgIndex + preferences constraints targets = + mapMessages (topDownResolver' platform comp + (convert installedPkgIndex) sourcePkgIndex + preferences constraints targets) where mapMessages :: Progress Log Failure a -> Progress String String a mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done @@ -333,6 +340,9 @@ ConflictsWith conflicts -> Fail (TopLevelInstallConstraintConflict pkg SourceConstraint conflicts) +addTopLevelConstraints (PackageConstraintStanzas _ _ : deps) cs = + addTopLevelConstraints deps cs + -- | Add exclusion on available packages that cannot be configured. -- pruneBottomUp :: Platform -> CompilerId @@ -358,9 +368,9 @@ [ (dep, Constraints.conflicting cs dep) | dep <- missing ] - configure cs (UnconfiguredPackage (SourcePackage _ pkg _) _ flags) = + configure cs (UnconfiguredPackage (SourcePackage _ pkg _) _ flags stanzas) = finalizePackageDescription flags (dependencySatisfiable cs) - platform comp [] pkg + platform comp [] (enableStanzas stanzas pkg) dependencySatisfiable cs = not . null . PackageIndex.lookupDependency (Constraints.choices cs) @@ -372,8 +382,8 @@ . Constraints.choices topSortNumber (InstalledOnly (InstalledPackageEx _ i _)) = i - topSortNumber (SourceOnly (UnconfiguredPackage _ i _)) = i - topSortNumber (InstalledAndSource _ (UnconfiguredPackage _ i _)) = i + topSortNumber (SourceOnly (UnconfiguredPackage _ i _ _)) = i + topSortNumber (InstalledAndSource _ (UnconfiguredPackage _ i _ _)) = i getSourcePkg (InstalledOnly _ ) = Nothing getSourcePkg (SourceOnly spkg) = Just spkg @@ -387,12 +397,12 @@ InstalledAndSource ipkg apkg -> fmap (InstalledAndSource ipkg) (configure apkg) where - configure (UnconfiguredPackage apkg@(SourcePackage _ p _) _ flags) = + configure (UnconfiguredPackage apkg@(SourcePackage _ p _) _ flags stanzas) = case finalizePackageDescription flags dependencySatisfiable - platform comp [] p of + platform comp [] (enableStanzas stanzas p) of Left missing -> Left missing Right (pkg, flags') -> Right $ - SemiConfiguredPackage apkg flags' (externalBuildDepends pkg) + SemiConfiguredPackage apkg flags' stanzas (externalBuildDepends pkg) dependencySatisfiable = not . null . PackageIndex.lookupDependency available @@ -421,7 +431,7 @@ -> PackageIndex UnconfiguredPackage annotateSourcePackages constraints dfsNumber sourcePkgIndex = PackageIndex.fromList - [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name) + [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name) (stanzasFor name) | pkg <- PackageIndex.allPackages sourcePkgIndex , let name = packageName pkg ] where @@ -429,6 +439,10 @@ flagsMap = Map.fromList [ (name, flags) | PackageConstraintFlags name flags <- constraints ] + stanzasFor = fromMaybe [] . flip Map.lookup stanzasMap + stanzasMap = Map.fromListWith (++) + [ (name, stanzas) + | PackageConstraintStanzas name stanzas <- constraints ] -- | One of the heuristics we use when guessing which path to take in the -- search space is an ordering on the choices we make. It's generally better @@ -540,8 +554,8 @@ Just (InstalledAndSource _ _) -> finaliseSource (Just ipkg) apkg finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg - finaliseSource mipkg (SemiConfiguredPackage pkg flags deps) = - InstallPlan.Configured (ConfiguredPackage pkg flags deps') + finaliseSource mipkg (SemiConfiguredPackage pkg flags stanzas deps) = + InstallPlan.Configured (ConfiguredPackage pkg flags stanzas deps') where deps' = map (packageId . pickRemaining mipkg) deps diff --git a/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs b/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs --- a/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs +++ b/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs @@ -38,7 +38,7 @@ import Data.Monoid ( Monoid(mempty) ) import Data.Either - ( partitionEithers ) + ( partitionEithers ) import qualified Data.Map as Map import Data.Map (Map) import qualified Data.Set as Set @@ -71,8 +71,7 @@ -- Adding a new target package can fail if that package already has conflicting -- constraints. -- -data (Package installed, Package source) - => Constraints installed source reason +data Constraints installed source reason = Constraints -- | Targets that we know we need. This is the set for which we @@ -118,7 +117,7 @@ invariant :: (Package installed, Package source) => Constraints installed source a -> Bool invariant (Constraints targets available excluded _ original) = - + -- Relationship between available, excluded and original all check merged @@ -203,7 +202,7 @@ mergeBy (\a b -> packageId a `compare` packageId b) [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded ] [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded' ] - + lostAndGained mr rest = case mr of OnlyInLeft pkg -> Left pkg : rest InBoth (InstalledAndSource pkg _) @@ -314,7 +313,7 @@ -- package is simply completely unknown. | otherwise = Unsatisfiable - + where conflicts = [ (packageId pkg, reasons) @@ -403,8 +402,8 @@ maybeCons Nothing xs = xs maybeCons (Just x) xs = x:xs - + -- For the info about an available or excluded version of the package in -- question, update the info given the current constraint. -- @@ -425,14 +424,14 @@ Nothing AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, False)) -> - removeAvailable False + removeAvailable False (InstalledAndSource aiPkg asPkg) (PackageIndex.deletePackageId pkgid) (ExcludedPkg (InstalledAndSource aiPkg asPkg) [reason] [] []) Nothing AllAvailable (InstalledAndSource (aiPkg, True) (asPkg, False)) -> - removeAvailable True + removeAvailable True (SourceOnly asPkg) (PackageIndex.insert (InstalledOnly aiPkg)) (ExcludedPkg (SourceOnly asPkg) [] [] [reason]) diff --git a/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs b/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs --- a/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs +++ b/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs @@ -13,7 +13,7 @@ module Distribution.Client.Dependency.TopDown.Types where import Distribution.Client.Types - ( SourcePackage(..), InstalledPackage ) + ( SourcePackage(..), InstalledPackage, OptionalStanza ) import Distribution.Package ( PackageIdentifier, Dependency @@ -50,11 +50,13 @@ SourcePackage !TopologicalSortNumber FlagAssignment + [OptionalStanza] data SemiConfiguredPackage = SemiConfiguredPackage SourcePackage -- package info FlagAssignment -- total flag assignment for the package + [OptionalStanza] -- enabled optional stanzas [Dependency] -- dependencies we end up with when we apply -- the flag assignment @@ -65,10 +67,10 @@ depends (InstalledPackageEx _ _ deps) = deps instance Package UnconfiguredPackage where - packageId (UnconfiguredPackage p _ _) = packageId p + packageId (UnconfiguredPackage p _ _ _) = packageId p instance Package SemiConfiguredPackage where - packageId (SemiConfiguredPackage p _ _) = packageId p + packageId (SemiConfiguredPackage p _ _ _) = packageId p instance (Package installed, Package source) => Package (InstalledOrSource installed source) where diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Types.hs b/cabal/cabal-install/Distribution/Client/Dependency/Types.hs --- a/cabal/cabal-install/Distribution/Client/Dependency/Types.hs +++ b/cabal/cabal-install/Distribution/Client/Dependency/Types.hs @@ -11,35 +11,91 @@ -- Common types for dependency resolution. ----------------------------------------------------------------------------- module Distribution.Client.Dependency.Types ( + ExtDependency(..), + + PreSolver(..), + Solver(..), DependencyResolver, PackageConstraint(..), PackagePreferences(..), InstalledPreference(..), + PackagesPreferenceDefault(..), Progress(..), foldProgress, ) where +import Control.Applicative + ( Applicative(..), Alternative(..) ) + +import Data.Char + ( isAlpha, toLower ) +import Data.Monoid + ( Monoid(..) ) + import Distribution.Client.Types - ( SourcePackage(..), InstalledPackage ) + ( OptionalStanza, SourcePackage(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Compat.ReadP + ( (<++) ) + +import qualified Distribution.Compat.ReadP as Parse + ( pfail, munch1 ) import Distribution.PackageDescription ( FlagAssignment ) -import Distribution.Client.PackageIndex +import qualified Distribution.Client.PackageIndex as PackageIndex ( PackageIndex ) +import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex + ( PackageIndex ) import Distribution.Package - ( PackageName ) + ( Dependency, PackageName, InstalledPackageId ) import Distribution.Version ( VersionRange ) import Distribution.Compiler ( CompilerId ) import Distribution.System ( Platform ) +import Distribution.Text + ( Text(..) ) +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) + +-- | All the solvers that can be used. +data Solver = TopDown | Modular + deriving (Eq, Ord, Show, Bounded, Enum) + +instance Text PreSolver where + disp AlwaysTopDown = text "topdown" + disp AlwaysModular = text "modular" + disp Choose = text "choose" + parse = do + name <- Parse.munch1 isAlpha + case map toLower name of + "topdown" -> return AlwaysTopDown + "modular" -> return AlwaysModular + "choose" -> return Choose + _ -> Parse.pfail + -- | A dependency resolver is a function that works out an installation plan -- given the set of installed and available packages and a set of deps to -- solve for. @@ -50,8 +106,8 @@ -- type DependencyResolver = Platform -> CompilerId - -> PackageIndex InstalledPackage - -> PackageIndex SourcePackage + -> InstalledPackageIndex.PackageIndex + -> PackageIndex.PackageIndex SourcePackage -> (PackageName -> PackagePreferences) -> [PackageConstraint] -> [PackageName] @@ -67,6 +123,7 @@ | PackageConstraintInstalled PackageName | PackageConstraintSource PackageName | PackageConstraintFlags PackageName FlagAssignment + | PackageConstraintStanzas PackageName [OptionalStanza] deriving (Show,Eq) -- | A per-package preference on the version. It is a soft constraint that the @@ -86,6 +143,30 @@ -- data InstalledPreference = PreferInstalled | PreferLatest +-- | 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. +-- +data PackagesPreferenceDefault = + + -- | Always prefer the latest version irrespective of any existing + -- installed version. + -- + -- * This is the standard policy for upgrade. + -- + PreferAllLatest + + -- | Always prefer the installed versions over ones that would need to be + -- installed. Secondarily, prefer latest versions (eg the latest installed + -- version or if there are none then the latest source version). + | PreferAllInstalled + + -- | Prefer the latest version for packages that are explicitly requested + -- but prefers the installed version for any other packages. + -- + -- * This is the standard policy for install. + -- + | PreferLatestForSelected + -- | 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. @@ -114,3 +195,11 @@ instance Monad (Progress step fail) where return a = Done a p >>= f = foldProgress Step Fail f p + +instance Applicative (Progress step fail) where + pure a = Done a + p <*> x = foldProgress Step Fail (flip fmap x) p + +instance Monoid fail => Alternative (Progress step fail) where + empty = Fail mempty + p <|> q = foldProgress Step (const q) Done p diff --git a/cabal/cabal-install/Distribution/Client/Fetch.hs b/cabal/cabal-install/Distribution/Client/Fetch.hs --- a/cabal/cabal-install/Distribution/Client/Fetch.hs +++ b/cabal/cabal-install/Distribution/Client/Fetch.hs @@ -19,7 +19,6 @@ import Distribution.Client.Targets import Distribution.Client.FetchUtils hiding (fetchPackage) import Distribution.Client.Dependency -import Distribution.Client.PackageIndex (PackageIndex) import Distribution.Client.IndexUtils as IndexUtils ( getSourcePackages, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan @@ -30,6 +29,7 @@ ( packageId ) import Distribution.Simple.Compiler ( Compiler(compilerId), PackageDBStack ) +import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Simple.Program ( ProgramConfiguration ) import Distribution.Simple.Setup @@ -112,7 +112,7 @@ planPackages :: Verbosity -> Compiler -> FetchFlags - -> PackageIndex InstalledPackage + -> PackageIndex -> SourcePackageDb -> [PackageSpecifier SourcePackage] -> IO [SourcePackage] @@ -120,17 +120,19 @@ installedPkgIndex sourcePkgDb pkgSpecifiers | includeDependencies = do + solver <- chooseSolver verbosity (fromFlag (fetchSolver fetchFlags)) (compilerId comp) notice verbosity "Resolving dependencies..." installPlan <- foldProgress logMsg die return $ resolveDependencies buildPlatform (compilerId comp) + solver resolverParams -- The packages we want to fetch are those packages the 'InstallPlan' -- that are in the 'InstallPlan.Configured' state. return [ pkg - | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _)) + | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _ _)) <- InstallPlan.toList installPlan ] | otherwise = @@ -140,16 +142,30 @@ where resolverParams = + setMaxBackjumps (if maxBackjumps < 0 then Nothing + else Just maxBackjumps) + + . setIndependentGoals independentGoals + + . setReorderGoals reorderGoals + + . setShadowPkgs shadowPkgs + -- 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. Sicne we want to get the source packages of + -- already installed. Since we want to get the source packages of -- things we might have installed (but not have the sources for). - reinstallTargets + . reinstallTargets $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers includeDependencies = fromFlag (fetchDeps fetchFlags) logMsg message rest = debug verbosity message >> rest + + reorderGoals = fromFlag (fetchReorderGoals fetchFlags) + independentGoals = fromFlag (fetchIndependentGoals fetchFlags) + shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags) + maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags) checkTarget :: UserTarget -> IO () diff --git a/cabal/cabal-install/Distribution/Client/Haddock.hs b/cabal/cabal-install/Distribution/Client/Haddock.hs --- a/cabal/cabal-install/Distribution/Client/Haddock.hs +++ b/cabal/cabal-install/Distribution/Client/Haddock.hs @@ -10,7 +10,7 @@ -- Interfacing with Haddock -- ----------------------------------------------------------------------------- -module Distribution.Client.Haddock +module Distribution.Client.Haddock ( regenerateHaddockIndex ) @@ -22,30 +22,29 @@ import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile) import System.FilePath ((), splitFileName) -import Distribution.Package (Package(..)) +import Distribution.Package + ( Package(..), packageVersion ) import Distribution.Simple.Program (haddockProgram, ProgramConfiguration , rawSystemProgram, requireProgramVersion) import Distribution.Version (Version(Version), orLaterVersion) import Distribution.Verbosity (Verbosity) import Distribution.Text (display) -import Distribution.Client.PackageIndex(PackageIndex, allPackages, - allPackagesByName, fromList) +import Distribution.Simple.PackageIndex + ( PackageIndex, allPackagesByName ) import Distribution.Simple.Utils ( comparing, intercalate, debug , installDirectoryContents, withTempDirectory ) -import Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.InstalledPackageInfo as InstalledPackageInfo ( InstalledPackageInfo , InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) ) -import Distribution.Client.Types - ( InstalledPackage(..) ) -regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackage -> ProgramConfiguration -> FilePath -> IO () +regenerateHaddockIndex :: Verbosity -> PackageIndex -> ProgramConfiguration -> FilePath -> IO () regenerateHaddockIndex verbosity pkgs conf index = do (paths,warns) <- haddockPackagePaths pkgs' case warns of Nothing -> return () Just m -> debug verbosity m - + (confHaddock, _, _) <- requireProgramVersion verbosity haddockProgram (orLaterVersion (Version [0,6] [])) conf @@ -63,16 +62,13 @@ rawSystemProgram verbosity confHaddock flags renameFile (tempDir "index.html") (tempDir destFile) installDirectoryContents verbosity tempDir destDir - - where + + where (destDir,destFile) = splitFileName index - pkgs' = map (maximumBy $ comparing packageId) - . allPackagesByName - . fromList - . filter exposed - . map (\(InstalledPackage pkg _) -> pkg) - . allPackages - $ pkgs + pkgs' = [ maximumBy (comparing packageVersion) pkgvers' + | (_pname, pkgvers) <- allPackagesByName pkgs + , let pkgvers' = filter exposed pkgvers + , not (null pkgvers') ] haddockPackagePaths :: [InstalledPackageInfo] -> IO ([(FilePath, FilePath)], Maybe String) diff --git a/cabal/cabal-install/Distribution/Client/HttpUtils.hs b/cabal/cabal-install/Distribution/Client/HttpUtils.hs --- a/cabal/cabal-install/Distribution/Client/HttpUtils.hs +++ b/cabal/cabal-install/Distribution/Client/HttpUtils.hs @@ -5,6 +5,7 @@ module Distribution.Client.HttpUtils ( downloadURI, getHTTP, + cabalBrowse, proxy, isOldHackageURI ) where @@ -17,10 +18,10 @@ import Network.Stream ( Result, ConnError(..) ) import Network.Browser - ( Proxy (..), Authority (..), browse - , setOutHandler, setErrHandler, setProxy, request) + ( Proxy (..), Authority (..), BrowserAction, browse + , setOutHandler, setErrHandler, setProxy, setAuthorityGen, request) import Control.Monad - ( mplus, join, liftM2 ) + ( mplus, join, liftM, liftM2 ) import qualified Data.ByteString.Lazy.Char8 as ByteString import Data.ByteString.Lazy (ByteString) #ifdef WIN32 @@ -151,16 +152,23 @@ -- |Carry out a GET request, using the local proxy settings getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString)) -getHTTP verbosity uri = do - p <- proxy verbosity - let req = mkRequest uri - (_, resp) <- browse $ do - setErrHandler (warn verbosity . ("http error: "++)) - setOutHandler (debug verbosity) - setProxy p - request req - return (Right resp) +getHTTP verbosity uri = liftM (\(_, resp) -> Right resp) $ + cabalBrowse verbosity (return ()) (request (mkRequest uri)) +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 + downloadURI :: Verbosity -> URI -- ^ What to download -> FilePath -- ^ Where to put it @@ -182,7 +190,7 @@ Left err -> die $ "Failed to download " ++ show uri ++ " : " ++ show err Right body -> do info verbosity ("Downloaded to " ++ path) - writeFileAtomic path (ByteString.unpack body) + writeFileAtomic path body --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. diff --git a/cabal/cabal-install/Distribution/Client/Index.hs b/cabal/cabal-install/Distribution/Client/Index.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Index.hs @@ -0,0 +1,218 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Index +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Querying and modifying local build tree references in the package index. +----------------------------------------------------------------------------- + +module Distribution.Client.Index ( + index, + + createEmpty, + addBuildTreeRefs, + removeBuildTreeRefs, + listBuildTreeRefs, + + defaultIndexFileName + ) where + +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.IndexUtils ( getSourcePackages ) +import Distribution.Client.PackageIndex ( allPackages ) +import Distribution.Client.Setup ( IndexFlags(..) ) +import Distribution.Client.Types ( Repo(..), LocalRepo(..) + , SourcePackageDb(..) + , SourcePackage(..), PackageLocation(..) ) +import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString + , makeAbsoluteToCwd ) + +import Distribution.Simple.Setup ( fromFlagOrDefault ) +import Distribution.Simple.Utils ( die, debug, notice, findPackageDesc ) +import Distribution.Verbosity ( Verbosity ) + +import qualified Data.ByteString.Lazy as BS +import Control.Exception ( evaluate ) +import Control.Monad ( liftM, when, unless ) +import Data.List ( (\\), nub ) +import Data.Maybe ( catMaybes ) +import System.Directory ( canonicalizePath, createDirectoryIfMissing, + doesDirectoryExist, doesFileExist, + renameFile ) +import System.FilePath ( (), (<.>), takeDirectory, takeExtension ) +import System.IO ( IOMode(..), SeekMode(..) + , hSeek, withBinaryFile ) + +-- | A reference to a local build tree. +newtype BuildTreeRef = BuildTreeRef { + buildTreePath :: FilePath + } + +defaultIndexFileName :: FilePath +defaultIndexFileName = "00-index.tar" + +-- | Entry point for the 'cabal index' command. +index :: Verbosity -> IndexFlags -> FilePath -> IO () +index verbosity indexFlags path' = do + let runInit = fromFlagOrDefault False (indexInit indexFlags) + let refsToAdd = indexLinkSource indexFlags + let runLinkSource = not . null $ refsToAdd + let refsToRemove = indexRemoveSource indexFlags + let runRemoveSource = not . null $ refsToRemove + let runList = fromFlagOrDefault False (indexList indexFlags) + + unless (or [runInit, runLinkSource, runRemoveSource, runList]) $ do + die "no arguments passed to the 'index' command" + + path <- validateIndexPath path' + + when runInit $ do + createEmpty verbosity path + + when runLinkSource $ do + addBuildTreeRefs verbosity path refsToAdd + + when runRemoveSource $ do + removeBuildTreeRefs verbosity path refsToRemove + + when runList $ do + refs <- listBuildTreeRefs verbosity path + mapM_ putStrLn refs + +-- | Given a path, ensure that it refers to a local build tree. +buildTreeRefFromPath :: FilePath -> IO (Maybe BuildTreeRef) +buildTreeRefFromPath dir = do + dirExists <- doesDirectoryExist dir + when (not dirExists) $ do + die $ "directory '" ++ dir ++ "' does not exist" + _ <- findPackageDesc dir + return . Just $ BuildTreeRef { buildTreePath = dir } + +-- | Given a tar archive entry, try to parse it as a local build tree reference. +readBuildTreePath :: Tar.Entry -> Maybe FilePath +readBuildTreePath entry = case Tar.entryContent entry of + (Tar.OtherEntryType typeCode bs size) + | (typeCode == Tar.buildTreeRefTypeCode) + && (size == BS.length bs) -> Just $ byteStringToFilePath bs + | otherwise -> Nothing + _ -> Nothing + +-- | Given a sequence of tar archive entries, extract all references to local +-- build trees. +readBuildTreePaths :: Tar.Entries -> [FilePath] +readBuildTreePaths = + catMaybes + . Tar.foldrEntries (\e r -> (readBuildTreePath e):r) + [] error + +-- | Given a path to a tar archive, extract all references to local build trees. +readBuildTreePathsFromFile :: FilePath -> IO [FilePath] +readBuildTreePathsFromFile = liftM (readBuildTreePaths . Tar.read) + . BS.readFile + +-- | Given a local build tree, serialise it to a tar archive entry. +writeBuildTreeRef :: BuildTreeRef -> Tar.Entry +writeBuildTreeRef lbt = Tar.simpleEntry tarPath content + where + bs = filePathToByteString path + path = buildTreePath lbt + -- fromRight can't fail because the path is shorter than 255 characters. + tarPath = fromRight $ Tar.toTarPath True tarPath' + -- Provide a filename for tools that treat custom entries as ordinary files. + tarPath' = "local-build-tree-reference" + content = Tar.OtherEntryType Tar.buildTreeRefTypeCode bs (BS.length bs) + + -- TODO: Move this to D.C.Utils? + fromRight (Left err) = error err + fromRight (Right a) = a + +-- | Check that the provided path is either an existing directory, or a tar +-- archive in an existing directory. +validateIndexPath :: FilePath -> IO FilePath +validateIndexPath path' = do + path <- makeAbsoluteToCwd path' + if (== ".tar") . takeExtension $ path + then return path + else do dirExists <- doesDirectoryExist path + unless dirExists $ do + die $ "directory does not exist: '" ++ path ++ "'" + return $ path defaultIndexFileName + +-- | Create an empty index file. +createEmpty :: Verbosity -> FilePath -> IO () +createEmpty verbosity path = do + indexExists <- doesFileExist path + if indexExists + then debug verbosity $ "Package index already exists: " ++ path + else do + debug verbosity $ "Creating the index file '" ++ path ++ "'" + createDirectoryIfMissing True (takeDirectory path) + -- Equivalent to 'tar cvf empty.tar --files-from /dev/null'. + let zeros = BS.replicate (512*20) 0 + BS.writeFile path zeros + +-- | Add given local build tree references to the index. +addBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO () +addBuildTreeRefs _ _ [] = + error "Distribution.Client.Index.addBuildTreeRefs: unexpected" +addBuildTreeRefs verbosity path l' = do + checkIndexExists path + l <- liftM nub . mapM canonicalizePath $ l' + treesInIndex <- readBuildTreePathsFromFile path + -- Add only those paths that aren't already in the index. + treesToAdd <- mapM buildTreeRefFromPath (l \\ treesInIndex) + let entries = map writeBuildTreeRef (catMaybes treesToAdd) + when (not . null $ entries) $ do + offset <- + fmap (Tar.foldrEntries (\e acc -> Tar.entrySizeInBytes e + acc) 0 error + . Tar.read) $ BS.readFile path + _ <- evaluate offset + debug verbosity $ "Writing at offset: " ++ show offset + withBinaryFile path ReadWriteMode $ \h -> do + hSeek h AbsoluteSeek (fromIntegral offset) + BS.hPut h (Tar.write entries) + debug verbosity $ "Successfully appended to '" ++ path ++ "'" + +-- | Remove given local build tree references from the index. +removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO () +removeBuildTreeRefs _ _ [] = + error "Distribution.Client.Index.removeBuildTreeRefs: unexpected" +removeBuildTreeRefs verbosity path l' = do + checkIndexExists path + l <- mapM canonicalizePath l' + let tmpFile = path <.> "tmp" + -- Performance note: on my system, it takes 'index --remove-source' + -- approx. 3,5s to filter a 65M file. Real-life indices are expected to be + -- 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 ++ "'" + where + p l entry = case readBuildTreePath entry of + Nothing -> True + (Just pth) -> not $ any (== pth) l + +-- | List the local build trees that are referred to from the index. +listBuildTreeRefs :: Verbosity -> FilePath -> IO [FilePath] +listBuildTreeRefs verbosity path = do + checkIndexExists path + let repo = Repo { repoKind = Right LocalRepo + , repoLocalDir = takeDirectory path } + pkgIndex <- fmap packageIndex . getSourcePackages verbosity $ [repo] + let buildTreeRefs = [ pkgPath | (LocalUnpackedPackage pkgPath) <- + map packageSource . allPackages $ pkgIndex ] + when (null buildTreeRefs) $ do + notice verbosity $ "Index file '" ++ path + ++ "' has no references to local build trees." + return buildTreeRefs + +-- | Check that the package index file exists and exit with error if it does not. +checkIndexExists :: FilePath -> IO () +checkIndexExists path = do + indexExists <- doesFileExist path + when (not indexExists) $ do + die $ "index does not exist: '" ++ path ++ "'" diff --git a/cabal/cabal-install/Distribution/Client/IndexUtils.hs b/cabal/cabal-install/Distribution/Client/IndexUtils.hs --- a/cabal/cabal-install/Distribution/Client/IndexUtils.hs +++ b/cabal/cabal-install/Distribution/Client/IndexUtils.hs @@ -13,9 +13,12 @@ module Distribution.Client.IndexUtils ( getInstalledPackages, getSourcePackages, + convert, readPackageIndexFile, - parseRepoIndex, + parsePackageIndex, + readRepoIndex, + updateRepoIndexCache, ) where import qualified Distribution.Client.Tar as Tar @@ -23,12 +26,13 @@ import Distribution.Package ( PackageId, PackageIdentifier(..), PackageName(..) - , Package(..), packageVersion + , Package(..), packageVersion, packageName , Dependency(Dependency), InstalledPackageId(..) ) 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 qualified Distribution.PackageDescription.Parse as PackageDesc.Parse import Distribution.PackageDescription ( GenericPackageDescription ) import Distribution.PackageDescription.Parse @@ -44,53 +48,57 @@ import Distribution.Version ( Version(Version), intersectVersionRanges ) import Distribution.Text - ( simpleParse ) + ( display, simpleParse ) import Distribution.Verbosity - ( Verbosity, lessVerbose ) + ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils - ( warn, info, fromUTF8, equating ) + ( die, warn, info, fromUTF8, findPackageDesc ) +import Data.Char (isAlphaNum) import Data.Maybe (catMaybes, fromMaybe) -import Data.List (isPrefixOf, groupBy) +import Data.List (isPrefixOf) import Data.Monoid (Monoid(..)) import qualified Data.Map as Map -import Control.Monad (MonadPlus(mplus), when) +import Control.Monad (MonadPlus(mplus), when, unless, 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 System.FilePath ((), takeExtension, splitDirectories, normalise) import System.FilePath.Posix as FilePath.Posix ( takeFileName ) +import System.IO +import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError) +import Distribution.Compat.Exception (catchIO) import System.Directory - ( getModificationTime ) -import System.Time - ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) ) + ( getModificationTime, doesFileExist ) +import Distribution.Compat.Time + getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration - -> IO (PackageIndex InstalledPackage) + -> IO InstalledPackageIndex.PackageIndex getInstalledPackages verbosity comp packageDbs conf = - fmap convert (Configure.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.allPackagesByName 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) - | ipkgs <- InstalledPackageIndex.allPackagesByName index - , (ipkg:_) <- groupBy (equating packageVersion) ipkgs ] - +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 @@ -109,6 +117,10 @@ brokenPackageId (InstalledPackageId str) = PackageIdentifier (PackageName (str ++ "-broken")) (Version [] []) +------------------------------------------------------------------------ +-- Reading the source package index +-- + -- | Read a repository index from disk, from the local files specified by -- a list of 'Repo's. -- @@ -147,42 +159,29 @@ -- readRepoIndex :: Verbosity -> Repo -> IO (PackageIndex SourcePackage, [Dependency]) -readRepoIndex verbosity repo = handleNotFound $ do +readRepoIndex verbosity repo = let indexFile = repoLocalDir repo "00-index.tar" - (pkgs, prefs) <- either fail return - . foldlTarball extract ([], []) - =<< BS.readFile indexFile + cacheFile = repoLocalDir repo "00-index.cache" + in handleNotFound $ do + warnIfIndexIsOld indexFile + whenCacheOutOfDate indexFile cacheFile $ do + info verbosity $ "Updating the index cache file..." + updatePackageIndexCacheFile indexFile cacheFile + readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile - pkgIndex <- evaluate $ PackageIndex.fromList - [ SourcePackage { + where + mkAvailablePackage pkgEntry = + SourcePackage { packageInfoId = pkgid, - packageDescription = pkg, - packageSource = RepoTarballPackage repo pkgid Nothing + packageDescription = packageDesc pkgEntry, + packageSource = case pkgEntry of + NormalPackage _ _ _ -> RepoTarballPackage repo pkgid Nothing + BuildTreeRef _ path _ _ -> LocalUnpackedPackage path } - | (pkgid, pkg) <- pkgs] - - warnIfIndexIsOld indexFile - return (pkgIndex, prefs) - - where - extract (pkgs, prefs) entry = fromMaybe (pkgs, prefs) $ - (do pkg <- extractPkg entry; return (pkg:pkgs, prefs)) - `mplus` (do prefs' <- extractPrefs entry; return (pkgs, prefs'++prefs)) - - extractPrefs :: Tar.Entry -> Maybe [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 - -} - _ -> Nothing + where + pkgid = packageId pkgEntry - handleNotFound action = catch action $ \e -> if isDoesNotExistError e + handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e then do case repoKind repo of Left remoteRepo -> warn verbosity $ @@ -196,22 +195,56 @@ isOldThreshold = 15 --days warnIfIndexIsOld indexFile = do - indexTime <- getModificationTime indexFile - currentTime <- getClockTime - let diff = normalizeTimeDiff (diffClockTimes currentTime indexTime) - when (tdDay diff >= isOldThreshold) $ case repoKind repo of + dt <- getFileAge indexFile + when (dt >= isOldThreshold) $ case repoKind repo of Left remoteRepo -> warn verbosity $ "The package list for '" ++ remoteRepoName remoteRepo - ++ "' is " ++ show (tdDay diff) ++ " days old.\nRun " + ++ "' is " ++ show dt ++ " days old.\nRun " ++ "'hackport update' to get the latest list of available packages." Right _localRepo -> return () -parsePreferredVersions :: String -> [Dependency] -parsePreferredVersions = catMaybes - . map simpleParse - . filter (not . isPrefixOf "--") - . lines +-- | 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 + where + indexFile = repoLocalDir repo "00-index.tar" + cacheFile = repoLocalDir repo "00-index.cache" +whenCacheOutOfDate :: FilePath-> FilePath -> IO () -> IO () +whenCacheOutOfDate origFile cacheFile action = do + exists <- doesFileExist cacheFile + if not exists + then action + else do + origTime <- getModificationTime origFile + cacheTime <- getModificationTime cacheFile + unless (cacheTime >= origTime) action + + +------------------------------------------------------------------------ +-- Reading the index file +-- + +-- | An index entry is either a normal package, or a local build tree reference. +data PackageEntry = NormalPackage PackageId GenericPackageDescription BlockNo + | BuildTreeRef PackageId FilePath GenericPackageDescription + BlockNo + +type MkPackageEntry = IO PackageEntry + +instance Package PackageEntry where + packageId (NormalPackage pkgid _ _ ) = pkgid + packageId (BuildTreeRef pkgid _ _ _ ) = pkgid + +packageDesc :: PackageEntry -> GenericPackageDescription +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 @@ -222,31 +255,54 @@ -- case you can just use @\_ p -> p@ here. -- readPackageIndexFile :: Package pkg - => (PackageId -> GenericPackageDescription -> pkg) - -> FilePath -> IO (PackageIndex pkg) + => (PackageEntry -> pkg) + -> FilePath + -> IO (PackageIndex pkg, [Dependency]) readPackageIndexFile mkPkg indexFile = do - pkgs <- either fail return - . parseRepoIndex - . maybeDecompress - =<< BS.readFile indexFile - - evaluate $ PackageIndex.fromList - [ mkPkg pkgid pkg | (pkgid, pkg) <- pkgs] + (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'. -- -parseRepoIndex :: ByteString - -> Either String [(PackageId, GenericPackageDescription)] -parseRepoIndex = foldlTarball (\pkgs -> maybe pkgs (:pkgs) . extractPkg) [] +parsePackageIndex :: ByteString + -> Either String ([MkPackageEntry], [Dependency]) +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' + where + (pkgs', prefs') = extract blockNo pkgs prefs e + blockNo' = blockNo + Tar.entrySizeInBlocks e -extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription) -extractPkg entry = case Tar.entryContent entry of + extract blockNo pkgs prefs entry = + fromMaybe (pkgs, prefs) $ + tryExtractPkg + `mplus` tryExtractPrefs + where + tryExtractPkg = do + mkPkgEntry <- extractPkg entry blockNo + return (mkPkgEntry:pkgs, prefs) + + tryExtractPrefs = do + prefs' <- extractPrefs entry + return (pkgs, prefs'++prefs) + +extractPkg :: Tar.Entry -> BlockNo -> Maybe MkPackageEntry +extractPkg entry blockNo = case Tar.entryContent entry of Tar.NormalFile content _ | takeExtension fileName == ".cabal" -> case splitDirectories (normalise fileName) of [pkgname,vers,_] -> case simpleParse vers of - Just ver -> Just (pkgid, descr) + Just ver -> Just $ return (NormalPackage pkgid descr blockNo) where pkgid = PackageIdentifier (PackageName pkgname) ver parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack @@ -257,14 +313,202 @@ ++ show fileName _ -> Nothing _ -> Nothing + + Tar.OtherEntryType typeCode content _ + | typeCode == Tar.buildTreeRefTypeCode -> + Just $ do + let path = byteStringToFilePath content + cabalFile <- findPackageDesc path + descr <- PackageDesc.Parse.readPackageDescription normal cabalFile + return $ BuildTreeRef (packageId descr) path descr blockNo + _ -> Nothing + where fileName = Tar.entryPath entry -foldlTarball :: (a -> Tar.Entry -> a) -> a - -> ByteString -> Either String a -foldlTarball f z = either Left (Right . foldl f z) . check [] . Tar.read +extractPrefs :: Tar.Entry -> Maybe [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 +-} + _ -> Nothing + +parsePreferredVersions :: String -> [Dependency] +parsePreferredVersions = catMaybes + . map simpleParse + . filter (not . isPrefixOf "--") + . lines + +------------------------------------------------------------------------ +-- 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 + writeFile cacheFile (showIndexCache cache) where - check _ (Tar.Fail err) = Left err - check ok Tar.Done = Right ok - check ok (Tar.Next e es) = check (e:ok) es + mkCache pkgs prefs = + [ CachePreference pref | pref <- prefs ] + ++ [ CachePackageId pkgid blockNo + | (NormalPackage pkgid _ blockNo) <- pkgs ] + ++ [ CacheBuildTreeRef blockNo + | (BuildTreeRef _ _ _ blockNo) <- pkgs] + +readPackageIndexCacheFile :: Package pkg + => (PackageEntry -> pkg) + -> FilePath + -> FilePath + -> IO (PackageIndex pkg, [Dependency]) +readPackageIndexCacheFile mkPkg indexFile cacheFile = do + indexHnd <- openFile indexFile ReadMode + cache <- liftM readIndexCache (BSS.readFile cacheFile) + packageIndexFromCache mkPkg indexHnd cache + + +packageIndexFromCache :: Package pkg + => (PackageEntry -> pkg) + -> Handle + -> [IndexCacheEntry] + -> IO (PackageIndex pkg, [Dependency]) +packageIndexFromCache mkPkg hnd = accum mempty [] + where + accum srcpkgs prefs [] = do + -- Have to reverse entries, since in a tar file, later entries mask + -- earlier ones, and PackageIndex.fromList does the same, but we + -- accumulate the list of entries in reverse order, so need to reverse. + pkgIndex <- evaluate $ PackageIndex.fromList (reverse srcpkgs) + return (pkgIndex, prefs) + + accum srcpkgs prefs (CachePackageId pkgid blockno : entries) = do + -- Given the cache entry, make a package index entry. + -- The magic here is that we use lazy IO to read the .cabal file + -- from the index tarball if it turns out that we need it. + -- Most of the time we only need the package id. + pkg <- unsafeInterleaveIO $ do + getEntryContent blockno >>= readPackageDescription + let srcpkg = mkPkg (NormalPackage pkgid pkg blockno) + accum (srcpkg:srcpkgs) prefs entries + + accum srcpkgs prefs (CacheBuildTreeRef blockno : entries) = do + -- We have to read the .cabal file eagerly here because we can't cache the + -- package id for build tree references - the user might edit the .cabal + -- file after the reference was added to the index. + path <- liftM byteStringToFilePath . getEntryContent $ blockno + pkg <- do cabalFile <- findPackageDesc path + PackageDesc.Parse.readPackageDescription normal cabalFile + let srcpkg = mkPkg (BuildTreeRef (packageId pkg) path pkg blockno) + accum (srcpkg:srcpkgs) prefs entries + + accum srcpkgs prefs (CachePreference pref : entries) = + accum srcpkgs (pref:prefs) entries + + getEntryContent :: BlockNo -> IO ByteString + getEntryContent blockno = do + hSeek hnd AbsoluteSeek (fromIntegral (blockno * 512)) + header <- BS.hGet hnd 512 + size <- getEntrySize header + BS.hGet hnd (fromIntegral size) + + getEntrySize :: ByteString -> IO Tar.FileSize + getEntrySize header = + case Tar.read header of + Tar.Next e _ -> + case Tar.entryContent e of + Tar.NormalFile _ size -> return size + Tar.OtherEntryType typecode _ size + | typecode == Tar.buildTreeRefTypeCode + -> return size + _ -> interror "unexpected tar entry type" + _ -> interror "could not read tar file entry" + + readPackageDescription :: ByteString -> IO GenericPackageDescription + readPackageDescription content = + case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of + ParseOk _ d -> return d + _ -> interror "failed to parse .cabal file" + + interror msg = die $ "internal error when reading package index: " ++ msg + ++ "The package index or index cache is probably " + ++ "corrupt. Running 'hackport update' might fix it." + +------------------------------------------------------------------------ +-- Index cache data structure +-- + +-- | Tar files are block structured with 512 byte blocks. Every header and file +-- content starts on a block boundary. +-- +type BlockNo = Int + +data IndexCacheEntry = CachePackageId PackageId BlockNo + | CacheBuildTreeRef BlockNo + | CachePreference Dependency + deriving (Eq, Show) + +readIndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry +readIndexCacheEntry = \line -> + case BSS.words line of + [key, pkgnamestr, pkgverstr, sep, blocknostr] + | key == packageKey && sep == blocknoKey -> + case (parseName pkgnamestr, parseVer pkgverstr [], + parseBlockNo blocknostr) of + (Just pkgname, Just pkgver, Just blockno) + -> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno) + _ -> Nothing + [key, blocknostr] | key == buildTreeRefKey -> + case parseBlockNo blocknostr of + Just blockno -> Just (CacheBuildTreeRef blockno) + _ -> Nothing + (key: remainder) | key == 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)) + | otherwise = Nothing + + parseVer str vs = + case BSS.readInt str of + Nothing -> Nothing + Just (v, str') -> case BSS.uncons str' of + Just ('.', str'') -> parseVer str'' (v:vs) + Just _ -> Nothing + Nothing -> Just (Version (reverse (v:vs)) []) + + parseBlockNo str = + case BSS.readInt str of + Just (blockno, remainder) | BSS.null remainder -> Just blockno + _ -> Nothing + +showIndexCacheEntry :: IndexCacheEntry -> String +showIndexCacheEntry entry = case entry of + CachePackageId pkgid b -> "pkg: " ++ display (packageName pkgid) + ++ " " ++ display (packageVersion pkgid) + ++ " b# " ++ show b + CacheBuildTreeRef b -> "build-tree-ref: " ++ show b + CachePreference dep -> "pref-ver: " ++ display dep + +readIndexCache :: BSS.ByteString -> [IndexCacheEntry] +readIndexCache = catMaybes . map readIndexCacheEntry . BSS.lines + +showIndexCache :: [IndexCacheEntry] -> String +showIndexCache = unlines . map showIndexCacheEntry diff --git a/cabal/cabal-install/Distribution/Client/Init.hs b/cabal/cabal-install/Distribution/Client/Init.hs --- a/cabal/cabal-install/Distribution/Client/Init.hs +++ b/cabal/cabal-install/Distribution/Client/Init.hs @@ -24,34 +24,51 @@ import System.IO ( hSetBuffering, stdout, BufferMode(..) ) import System.Directory - ( getCurrentDirectory ) + ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile ) +import System.FilePath + ( (), (<.>) ) import Data.Time ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) import Data.List - ( intersperse, (\\) ) + ( intersperse, intercalate, nub, groupBy, (\\) ) import Data.Maybe - ( fromMaybe, isJust ) + ( fromMaybe, isJust, catMaybes ) +import Data.Function + ( on ) +import qualified Data.Map as M import Data.Traversable ( traverse ) +import Control.Applicative + ( (<$>) ) import Control.Monad - ( when ) + ( when, unless ) #if MIN_VERSION_base(3,0,0) import Control.Monad ( (>=>), join ) #endif +import Control.Arrow + ( (&&&) ) -import Text.PrettyPrint.HughesPJ hiding (mode, cat) +import Text.PrettyPrint hiding (mode, cat) import Data.Version ( Version(..) ) import Distribution.Version - ( orLaterVersion ) + ( orLaterVersion, withinVersion, VersionRange ) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.ModuleName + ( ModuleName, fromString ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo, sourcePackageId, exposed ) +import qualified Distribution.Package as P +import Language.Haskell.Extension ( Language(..) ) import Distribution.Client.Init.Types ( InitFlags(..), PackageType(..), Category(..) ) import Distribution.Client.Init.Licenses - ( bsd3, gplv2, gplv3, lgpl2, lgpl3 ) + ( bsd3, gplv2, gplv3, lgpl2, lgpl3, apache20 ) import Distribution.Client.Init.Heuristics ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms ) @@ -64,14 +81,30 @@ ( runReadE, readP_to_E ) import Distribution.Simple.Setup ( Flag(..), flagToMaybe ) +import Distribution.Simple.Configure + ( getInstalledPackages ) +import Distribution.Simple.Compiler + ( PackageDBStack, Compiler ) +import Distribution.Simple.Program + ( ProgramConfiguration ) +import Distribution.Simple.PackageIndex + ( PackageIndex, moduleNameIndex ) import Distribution.Text ( display, Text(..) ) -initCabal :: InitFlags -> IO () -initCabal initFlags = do +initCabal :: Verbosity + -> PackageDBStack + -> Compiler + -> ProgramConfiguration + -> InitFlags + -> IO () +initCabal verbosity packageDBs comp conf initFlags = do + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf + hSetBuffering stdout NoBuffering - initFlags' <- extendFlags initFlags + initFlags' <- extendFlags installedPkgIndex initFlags writeLicense initFlags' writeSetupFile initFlags' @@ -85,18 +118,20 @@ -- | Fill in more details by guessing, discovering, or prompting the -- user. -extendFlags :: InitFlags -> IO InitFlags -extendFlags = getPackageName - >=> getVersion - >=> getLicense - >=> getAuthorInfo - >=> getHomepage - >=> getSynopsis - >=> getCategory - >=> getLibOrExec - >=> getGenComments - >=> getSrcDir - >=> getModulesAndBuildTools +extendFlags :: PackageIndex -> InitFlags -> IO InitFlags +extendFlags pkgIx = + getPackageName + >=> getVersion + >=> getLicense + >=> getAuthorInfo + >=> getHomepage + >=> getSynopsis + >=> getCategory + >=> getLibOrExec + >=> getLanguage + >=> getGenComments + >=> getSrcDir + >=> getModulesBuildToolsAndDeps pkgIx -- | Combine two actions which may return a value, preferring the first. That -- is, run the second action only if the first doesn't return a value. @@ -125,11 +160,11 @@ return $ flags { packageName = maybeToFlag pkgName' } --- | Package version: use 0.1 as a last resort, but try prompting the user if --- possible. +-- | 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], versionTags = [] } + let v = Just $ Version { versionBranch = [0,1,0,0], versionTags = [] } v' <- return (flagToMaybe $ version flags) ?>> maybePrompt flags (prompt "Package version" v) ?>> return v @@ -145,7 +180,7 @@ return $ flags { license = maybeToFlag lic } where listedLicenses = - knownLicenses \\ [GPL Nothing, LGPL Nothing, OtherLicense] + knownLicenses \\ [GPL Nothing, LGPL Nothing, Apache Nothing, OtherLicense] -- | The author's name and email. Prompt, or try to guess from an existing -- darcs repo. @@ -169,7 +204,7 @@ getHomepage flags = do hp <- queryHomepage hp' <- return (flagToMaybe $ homepage flags) - ?>> maybePrompt flags (promptStr "Project homepage/repo URL" hp) + ?>> maybePrompt flags (promptStr "Project homepage URL" hp) ?>> return hp return $ flags { homepage = maybeToFlag hp' } @@ -209,47 +244,141 @@ return $ flags { packageType = maybeToFlag isLib } --- | Ask whether to generate explanitory comments. +-- | Ask for the base language of the package. +getLanguage :: InitFlags -> IO InitFlags +getLanguage flags = do + lang <- return (flagToMaybe $ language flags) + ?>> maybePrompt flags + (either UnknownLanguage id `fmap` + (promptList "What base language is the package written in" + [Haskell2010, Haskell98] + (Just Haskell2010) + display + True + ) + ) + ?>> return (Just Haskell2010) + + return $ flags { language = maybeToFlag lang } + +-- | Ask whether to generate explanatory comments. getGenComments :: InitFlags -> IO InitFlags getGenComments flags = do - genComments <- return (flagToMaybe $ noComments flags) + genComments <- return (not <$> (flagToMaybe $ noComments flags)) ?>> maybePrompt flags (promptYesNo promptMsg (Just False)) ?>> return (Just False) return $ flags { noComments = maybeToFlag (fmap not genComments) } where - promptMsg = "Include documentation on what each field means y/n" + promptMsg = "Include documentation on what each field means (y/n)" -- | Try to guess the source root directory (don't prompt the user). getSrcDir :: InitFlags -> IO InitFlags getSrcDir flags = do srcDirs <- return (sourceDirs flags) - ?>> guessSourceDirs + ?>> Just `fmap` (guessSourceDirs flags) return $ flags { sourceDirs = srcDirs } --- XXX --- | Try to guess source directories. -guessSourceDirs :: IO (Maybe [String]) -guessSourceDirs = return Nothing +-- | Try to guess source directories. Could try harder; for the +-- moment just looks to see whether there is a directory called 'src'. +guessSourceDirs :: InitFlags -> IO [String] +guessSourceDirs flags = do + dir <- fromMaybe getCurrentDirectory + (fmap return . flagToMaybe $ packageDir flags) + srcIsDir <- doesDirectoryExist (dir "src") + if srcIsDir + then return ["src"] + else return [] -- | Get the list of exposed modules and extra tools needed to build them. -getModulesAndBuildTools :: InitFlags -> IO InitFlags -getModulesAndBuildTools flags = do +getModulesBuildToolsAndDeps :: PackageIndex -> InitFlags -> IO InitFlags +getModulesBuildToolsAndDeps pkgIx flags = do dir <- fromMaybe getCurrentDirectory (fmap return . flagToMaybe $ packageDir flags) -- XXX really should use guessed source roots. sourceFiles <- scanForModules dir - mods <- return (exposedModules flags) + Just mods <- return (exposedModules flags) ?>> (return . Just . map moduleName $ sourceFiles) tools <- return (buildTools flags) ?>> (return . Just . neededBuildPrograms $ sourceFiles) - return $ flags { exposedModules = mods - , buildTools = tools } + deps <- return (dependencies flags) + ?>> Just <$> importsToDeps flags + (fromString "Prelude" : -- to ensure we get base as a dep + ( nub -- only need to consider each imported package once + . filter (`notElem` mods) -- don't consider modules from + -- this package itself + . concatMap imports + $ sourceFiles + ) + ) + pkgIx + return $ flags { exposedModules = Just mods + , buildTools = tools + , dependencies = deps + } + +importsToDeps :: InitFlags -> [ModuleName] -> PackageIndex -> IO [P.Dependency] +importsToDeps flags mods pkgIx = do + + let modMap :: M.Map ModuleName [InstalledPackageInfo] + modMap = M.map (filter exposed) $ moduleNameIndex pkgIx + + modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])] + modDeps = map (id &&& flip M.lookup modMap) mods + + message flags "\nGuessing dependencies..." + nub . catMaybes <$> mapM (chooseDep flags) modDeps + +-- Given a module and a list of installed packages providing it, +-- choose a dependency (i.e. package + version range) to use for that +-- module. +chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo]) + -> IO (Maybe P.Dependency) + +chooseDep flags (m, Nothing) + = message flags ("\nWarning: no package found providing " ++ display m ++ ".") + >> return Nothing + +chooseDep flags (m, Just []) + = message flags ("\nWarning: no package found providing " ++ display m ++ ".") + >> return Nothing + + -- We found some packages: group them by name. +chooseDep flags (m, Just ps) + = case pkgGroups of + -- if there's only one group, i.e. multiple versions of a single package, + -- we make it into a dependency, choosing the latest-ish version (see toDep). + [grp] -> Just <$> toDep grp + -- otherwise, we refuse to choose between different packages and make the user + -- do it. + grps -> do message flags ("\nWarning: multiple packages found providing " + ++ display m + ++ ": " ++ intercalate ", " (map (display . P.pkgName . head) grps)) + message flags ("You will need to pick one and manually add it to the Build-depends: field.") + return Nothing + where + pkgGroups = groupBy ((==) `on` P.pkgName) (map sourcePackageId ps) + + -- Given a list of available versions of the same package, pick a dependency. + toDep :: [P.PackageIdentifier] -> IO P.Dependency + + -- If only one version, easy. We change e.g. 0.4.2 into 0.4.* + toDep [pid] = return $ P.Dependency (P.pkgName pid) (pvpize . P.pkgVersion $ pid) + + -- Otherwise, choose the latest version and issue a warning. + toDep pids = do + message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.") + return $ P.Dependency (P.pkgName . head $ pids) + (pvpize . maximum . map P.pkgVersion $ pids) + + pvpize :: Version -> VersionRange + pvpize v = withinVersion $ v { versionBranch = take 2 (versionBranch v) } + --------------------------------------------------------------------------- -- Prompting/user interaction ------------------------------------------- --------------------------------------------------------------------------- @@ -370,7 +499,7 @@ writeLicense :: InitFlags -> IO () writeLicense flags = do - message flags "Generating LICENSE..." + message flags "\nGenerating LICENSE..." year <- getYear let licenseFile = case license flags of @@ -392,10 +521,13 @@ Flag (LGPL (Just (Version {versionBranch = [3]}))) -> Just lgpl3 + Flag (Apache (Just (Version {versionBranch = [2, 0]}))) + -> Just apache20 + _ -> Nothing case licenseFile of - Just licenseText -> writeFile "LICENSE" licenseText + Just licenseText -> writeFileSafe flags "LICENSE" licenseText Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself." getYear :: IO Integer @@ -409,13 +541,15 @@ writeSetupFile :: InitFlags -> IO () writeSetupFile flags = do message flags "Generating Setup.hs..." - writeFile "Setup.hs" setupFile + writeFileSafe flags "Setup.hs" setupFile where setupFile = unlines [ "import Distribution.Simple" , "main = defaultMain" ] +-- XXX ought to do something sensible if a .cabal file already exists, +-- instead of overwriting. writeCabalFile :: InitFlags -> IO Bool writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do message flags "Error: no package name provided." @@ -423,9 +557,36 @@ writeCabalFile flags@(InitFlags{packageName = Flag p}) = do let cabalFileName = p ++ ".cabal" message flags $ "Generating " ++ cabalFileName ++ "..." - writeFile cabalFileName (generateCabalFile cabalFileName flags) + writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags) return True +-- | Write a file \"safely\", backing up any existing version (unless +-- the overwrite flag is set). +writeFileSafe :: InitFlags -> FilePath -> String -> IO () +writeFileSafe flags fileName content = do + moveExistingFile flags fileName + writeFile fileName content + +-- | Move an existing file, if there is one, and the overwrite flag is +-- not set. +moveExistingFile :: InitFlags -> FilePath -> IO () +moveExistingFile flags fileName = + unless (overwrite flags == Flag True) $ do + e <- doesFileExist fileName + when e $ do + newName <- findNewName fileName + message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName + copyFile fileName newName + +findNewName :: FilePath -> IO FilePath +findNewName oldName = findNewName' 0 + where + findNewName' :: Integer -> IO FilePath + findNewName' n = do + let newName = oldName <.> ("save" ++ show n) + e <- doesFileExist newName + if e then findNewName' (n+1) else return newName + -- | Generate a .cabal file from an InitFlags structure. NOTE: this -- is rather ad-hoc! What we would REALLY like is to have a -- standard low-level AST type representing .cabal files, which @@ -449,7 +610,10 @@ True , field "version" (version c) - (Just "The package version. See the Haskell package versioning policy (http://www.haskell.org/haskellwiki/Package_versioning_policy) for standards guiding when and how versions should be incremented.") + (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" + ++ "PVP summary: +-+------- breaking API changes\n" + ++ " | | +----- non-breaking API additions\n" + ++ " | | | +--- code changes with no API change") True , fieldS "synopsis" (synopsis c) @@ -500,7 +664,7 @@ (Just "Extra files to be distributed with the package, such as examples or a README.") False - , field "cabal-version" (Flag $ orLaterVersion (Version [1,8] [])) + , field "cabal-version" (Flag $ orLaterVersion (Version [1,10] [])) (Just "Constraint on the version of Cabal needed to build this package.") False @@ -540,6 +704,10 @@ , fieldS "build-tools" (listFieldS (buildTools c')) (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.") False + + , field "default-language" (language c') + (Just "Base language which the package is written in.") + True ] listField :: Text s => Maybe [s] -> Flag String @@ -578,8 +746,16 @@ lineLength = 76, ribbonsPerLine = 1.05 } - . fsep . map text . words $ t + . vcat + . map (fcat . map text . breakLine) + . lines + $ t showComment Nothing = text "" + + breakLine [] = [] + breakLine cs = case break (==' ') cs of (w,cs') -> w : breakLine' cs' + breakLine' [] = [] + breakLine' cs = case span (==' ') cs of (w,cs') -> w : breakLine cs' -- | Generate warnings for missing fields etc. generateWarnings :: InitFlags -> IO () diff --git a/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs b/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs --- a/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs +++ b/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs @@ -19,8 +19,10 @@ guessAuthorNameMail, knownCategories, ) where -import Distribution.Simple.Setup(Flag(..)) -import Distribution.ModuleName ( ModuleName, fromString ) +import Distribution.Text (simpleParse) +import Distribution.Simple.Setup (Flag(..)) +import Distribution.ModuleName + ( ModuleName, fromString, toFilePath ) import Distribution.Client.PackageIndex ( allPackagesByName ) import qualified Distribution.PackageDescription as PD @@ -34,6 +36,7 @@ #if MIN_VERSION_base(3,0,3) import Data.Either ( partitionEithers ) #endif +import Data.List ( isPrefixOf ) import Data.Maybe ( catMaybes ) import Data.Monoid ( mempty, mappend ) import qualified Data.Set as Set ( fromList, toList ) @@ -41,7 +44,7 @@ getHomeDirectory, canonicalizePath ) import System.Environment ( getEnvironment ) import System.FilePath ( takeExtension, takeBaseName, dropExtension, - (), splitDirectories, makeRelative ) + (), (<.>), splitDirectories, makeRelative ) -- |Guess the package name based on the given root directory guessPackageName :: FilePath -> IO String @@ -50,10 +53,15 @@ -- |Data type of source files found in the working directory data SourceFileEntry = SourceFileEntry { relativeSourcePath :: FilePath - , moduleName :: ModuleName - , fileExtension :: String + , moduleName :: ModuleName + , fileExtension :: String + , imports :: [ModuleName] } deriving Show +sfToFileName :: FilePath -> SourceFileEntry -> FilePath +sfToFileName projectRoot (SourceFileEntry relPath m ext _) + = projectRoot relPath toFilePath m <.> ext + -- |Search for source files in the given directory -- and return pairs of guessed haskell source path and -- module names. @@ -69,14 +77,15 @@ let modules = catMaybes [ guessModuleName hierarchy file | file <- files , isUpper (head file) ] + modules' <- mapM (findImports projectRoot) modules recMods <- mapM (scanRecursive dir hierarchy) dirs - return $ concat (modules : recMods) + return $ concat (modules' : recMods) tagIsDir parent entry = do isDir <- doesDirectoryExist (parent entry) return $ (if isDir then Right else Left) entry guessModuleName hierarchy entry | takeBaseName entry == "Setup" = Nothing - | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext + | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext [] | otherwise = Nothing where relRoot = makeRelative projectRoot srcRoot @@ -90,6 +99,35 @@ | otherwise = return [] ignoreDir ('.':_) = True ignoreDir dir = dir `elem` ["dist", "_darcs"] + +findImports :: FilePath -> SourceFileEntry -> IO SourceFileEntry +findImports projectRoot sf = do + s <- readFile (sfToFileName projectRoot sf) + + let modules = catMaybes + . map ( getModName + . drop 1 + . filter (not . null) + . dropWhile (/= "import") + . words + ) + . filter (not . ("--" `isPrefixOf`)) -- poor man's comment filtering + . lines + $ s + + -- XXX 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. + + return sf { imports = modules } + + where getModName :: [String] -> Maybe ModuleName + getModName [] = Nothing + getModName ("qualified":ws) = getModName ws + getModName (ms:_) = simpleParse ms + + -- Unfortunately we cannot use the version exported by Distribution.Simple.Program knownSuffixHandlers :: [(String,String)] diff --git a/cabal/cabal-install/Distribution/Client/Init/Licenses.hs b/cabal/cabal-install/Distribution/Client/Init/Licenses.hs --- a/cabal/cabal-install/Distribution/Client/Init/Licenses.hs +++ b/cabal/cabal-install/Distribution/Client/Init/Licenses.hs @@ -5,6 +5,7 @@ , gplv3 , lgpl2 , lgpl3 + , apache20 ) where @@ -1720,3 +1721,208 @@ , "Library." ] +apache20 :: License +apache20 = unlines + [ "" + , " Apache License" + , " Version 2.0, January 2004" + , " http://www.apache.org/licenses/" + , "" + , " TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION" + , "" + , " 1. Definitions." + , "" + , " \"License\" shall mean the terms and conditions for use, reproduction," + , " and distribution as defined by Sections 1 through 9 of this document." + , "" + , " \"Licensor\" shall mean the copyright owner or entity authorized by" + , " the copyright owner that is granting the License." + , "" + , " \"Legal Entity\" shall mean the union of the acting entity and all" + , " other entities that control, are controlled by, or are under common" + , " control with that entity. For the purposes of this definition," + , " \"control\" means (i) the power, direct or indirect, to cause the" + , " direction or management of such entity, whether by contract or" + , " otherwise, or (ii) ownership of fifty percent (50%) or more of the" + , " outstanding shares, or (iii) beneficial ownership of such entity." + , "" + , " \"You\" (or \"Your\") shall mean an individual or Legal Entity" + , " exercising permissions granted by this License." + , "" + , " \"Source\" form shall mean the preferred form for making modifications," + , " including but not limited to software source code, documentation" + , " source, and configuration files." + , "" + , " \"Object\" form shall mean any form resulting from mechanical" + , " transformation or translation of a Source form, including but" + , " not limited to compiled object code, generated documentation," + , " and conversions to other media types." + , "" + , " \"Work\" shall mean the work of authorship, whether in Source or" + , " Object form, made available under the License, as indicated by a" + , " copyright notice that is included in or attached to the work" + , " (an example is provided in the Appendix below)." + , "" + , " \"Derivative Works\" shall mean any work, whether in Source or Object" + , " form, that is based on (or derived from) the Work and for which the" + , " editorial revisions, annotations, elaborations, or other modifications" + , " represent, as a whole, an original work of authorship. For the purposes" + , " of this License, Derivative Works shall not include works that remain" + , " separable from, or merely link (or bind by name) to the interfaces of," + , " the Work and Derivative Works thereof." + , "" + , " \"Contribution\" shall mean any work of authorship, including" + , " the original version of the Work and any modifications or additions" + , " to that Work or Derivative Works thereof, that is intentionally" + , " submitted to Licensor for inclusion in the Work by the copyright owner" + , " or by an individual or Legal Entity authorized to submit on behalf of" + , " the copyright owner. For the purposes of this definition, \"submitted\"" + , " means any form of electronic, verbal, or written communication sent" + , " to the Licensor or its representatives, including but not limited to" + , " communication on electronic mailing lists, source code control systems," + , " and issue tracking systems that are managed by, or on behalf of, the" + , " Licensor for the purpose of discussing and improving the Work, but" + , " excluding communication that is conspicuously marked or otherwise" + , " designated in writing by the copyright owner as \"Not a Contribution.\"" + , "" + , " \"Contributor\" shall mean Licensor and any individual or Legal Entity" + , " on behalf of whom a Contribution has been received by Licensor and" + , " subsequently incorporated within the Work." + , "" + , " 2. Grant of Copyright License. Subject to the terms and conditions of" + , " this License, each Contributor hereby grants to You a perpetual," + , " worldwide, non-exclusive, no-charge, royalty-free, irrevocable" + , " copyright license to reproduce, prepare Derivative Works of," + , " publicly display, publicly perform, sublicense, and distribute the" + , " Work and such Derivative Works in Source or Object form." + , "" + , " 3. Grant of Patent License. Subject to the terms and conditions of" + , " this License, each Contributor hereby grants to You a perpetual," + , " worldwide, non-exclusive, no-charge, royalty-free, irrevocable" + , " (except as stated in this section) patent license to make, have made," + , " use, offer to sell, sell, import, and otherwise transfer the Work," + , " where such license applies only to those patent claims licensable" + , " by such Contributor that are necessarily infringed by their" + , " Contribution(s) alone or by combination of their Contribution(s)" + , " with the Work to which such Contribution(s) was submitted. If You" + , " institute patent litigation against any entity (including a" + , " cross-claim or counterclaim in a lawsuit) alleging that the Work" + , " or a Contribution incorporated within the Work constitutes direct" + , " or contributory patent infringement, then any patent licenses" + , " granted to You under this License for that Work shall terminate" + , " as of the date such litigation is filed." + , "" + , " 4. Redistribution. You may reproduce and distribute copies of the" + , " Work or Derivative Works thereof in any medium, with or without" + , " modifications, and in Source or Object form, provided that You" + , " meet the following conditions:" + , "" + , " (a) You must give any other recipients of the Work or" + , " Derivative Works a copy of this License; and" + , "" + , " (b) You must cause any modified files to carry prominent notices" + , " stating that You changed the files; and" + , "" + , " (c) You must retain, in the Source form of any Derivative Works" + , " that You distribute, all copyright, patent, trademark, and" + , " attribution notices from the Source form of the Work," + , " excluding those notices that do not pertain to any part of" + , " the Derivative Works; and" + , "" + , " (d) If the Work includes a \"NOTICE\" text file as part of its" + , " distribution, then any Derivative Works that You distribute must" + , " include a readable copy of the attribution notices contained" + , " within such NOTICE file, excluding those notices that do not" + , " pertain to any part of the Derivative Works, in at least one" + , " of the following places: within a NOTICE text file distributed" + , " as part of the Derivative Works; within the Source form or" + , " documentation, if provided along with the Derivative Works; or," + , " within a display generated by the Derivative Works, if and" + , " wherever such third-party notices normally appear. The contents" + , " of the NOTICE file are for informational purposes only and" + , " do not modify the License. You may add Your own attribution" + , " notices within Derivative Works that You distribute, alongside" + , " or as an addendum to the NOTICE text from the Work, provided" + , " that such additional attribution notices cannot be construed" + , " as modifying the License." + , "" + , " You may add Your own copyright statement to Your modifications and" + , " may provide additional or different license terms and conditions" + , " for use, reproduction, or distribution of Your modifications, or" + , " for any such Derivative Works as a whole, provided Your use," + , " reproduction, and distribution of the Work otherwise complies with" + , " the conditions stated in this License." + , "" + , " 5. Submission of Contributions. Unless You explicitly state otherwise," + , " any Contribution intentionally submitted for inclusion in the Work" + , " by You to the Licensor shall be under the terms and conditions of" + , " this License, without any additional terms or conditions." + , " Notwithstanding the above, nothing herein shall supersede or modify" + , " the terms of any separate license agreement you may have executed" + , " with Licensor regarding such Contributions." + , "" + , " 6. Trademarks. This License does not grant permission to use the trade" + , " names, trademarks, service marks, or product names of the Licensor," + , " except as required for reasonable and customary use in describing the" + , " origin of the Work and reproducing the content of the NOTICE file." + , "" + , " 7. Disclaimer of Warranty. Unless required by applicable law or" + , " agreed to in writing, Licensor provides the Work (and each" + , " Contributor provides its Contributions) on an \"AS IS\" BASIS," + , " WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or" + , " implied, including, without limitation, any warranties or conditions" + , " of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A" + , " PARTICULAR PURPOSE. You are solely responsible for determining the" + , " appropriateness of using or redistributing the Work and assume any" + , " risks associated with Your exercise of permissions under this License." + , "" + , " 8. Limitation of Liability. In no event and under no legal theory," + , " whether in tort (including negligence), contract, or otherwise," + , " unless required by applicable law (such as deliberate and grossly" + , " negligent acts) or agreed to in writing, shall any Contributor be" + , " liable to You for damages, including any direct, indirect, special," + , " incidental, or consequential damages of any character arising as a" + , " result of this License or out of the use or inability to use the" + , " Work (including but not limited to damages for loss of goodwill," + , " work stoppage, computer failure or malfunction, or any and all" + , " other commercial damages or losses), even if such Contributor" + , " has been advised of the possibility of such damages." + , "" + , " 9. Accepting Warranty or Additional Liability. While redistributing" + , " the Work or Derivative Works thereof, You may choose to offer," + , " and charge a fee for, acceptance of support, warranty, indemnity," + , " or other liability obligations and/or rights consistent with this" + , " License. However, in accepting such obligations, You may act only" + , " on Your own behalf and on Your sole responsibility, not on behalf" + , " of any other Contributor, and only if You agree to indemnify," + , " defend, and hold each Contributor harmless for any liability" + , " incurred by, or claims asserted against, such Contributor by reason" + , " of your accepting any such warranty or additional liability." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " APPENDIX: How to apply the Apache License to your work." + , "" + , " To apply the Apache License to your work, attach the following" + , " boilerplate notice, with the fields enclosed by brackets \"[]\"" + , " replaced with your own identifying information. (Don't include" + , " the brackets!) The text should be enclosed in the appropriate" + , " comment syntax for the file format. We also recommend that a" + , " file or class name and description of purpose be included on the" + , " same \"printed page\" as the copyright notice for easier" + , " identification within third-party archives." + , "" + , " Copyright [yyyy] [name of copyright owner]" + , "" + , " Licensed under the Apache License, Version 2.0 (the \"License\");" + , " you may not use this file except in compliance with the License." + , " You may obtain a copy of the License at" + , "" + , " http://www.apache.org/licenses/LICENSE-2.0" + , "" + , " Unless required by applicable law or agreed to in writing, software" + , " distributed under the License is distributed on an \"AS IS\" BASIS," + , " 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." + ] diff --git a/cabal/cabal-install/Distribution/Client/Init/Types.hs b/cabal/cabal-install/Distribution/Client/Init/Types.hs --- a/cabal/cabal-install/Distribution/Client/Init/Types.hs +++ b/cabal/cabal-install/Distribution/Client/Init/Types.hs @@ -18,9 +18,11 @@ ( Flag(..) ) import Distribution.Version +import Distribution.Verbosity import qualified Distribution.Package as P import Distribution.License import Distribution.ModuleName +import Language.Haskell.Extension ( Language(..) ) import qualified Text.PrettyPrint as Disp import qualified Distribution.Compat.ReadP as Parse @@ -52,6 +54,7 @@ , category :: Flag (Either String Category) , packageType :: Flag PackageType + , language :: Flag Language , exposedModules :: Maybe [ModuleName] , otherModules :: Maybe [ModuleName] @@ -59,6 +62,9 @@ , dependencies :: Maybe [P.Dependency] , sourceDirs :: Maybe [String] , buildTools :: Maybe [String] + + , initVerbosity :: Flag Verbosity + , overwrite :: Flag Bool } deriving (Show) @@ -86,11 +92,14 @@ , synopsis = mempty , category = mempty , packageType = mempty + , language = mempty , exposedModules = mempty , otherModules = mempty , dependencies = mempty , sourceDirs = mempty , buildTools = mempty + , initVerbosity = mempty + , overwrite = mempty } mappend a b = InitFlags { nonInteractive = combine nonInteractive @@ -108,11 +117,14 @@ , synopsis = combine synopsis , category = combine category , packageType = combine packageType + , language = combine language , exposedModules = combine exposedModules , otherModules = combine otherModules , dependencies = combine dependencies , sourceDirs = combine sourceDirs , buildTools = combine buildTools + , initVerbosity = combine initVerbosity + , overwrite = combine overwrite } where combine field = field a `mappend` field b diff --git a/cabal/cabal-install/Distribution/Client/Install.hs b/cabal/cabal-install/Distribution/Client/Install.hs --- a/cabal/cabal-install/Distribution/Client/Install.hs +++ b/cabal/cabal-install/Distribution/Client/Install.hs @@ -19,11 +19,11 @@ ) where import Data.List - ( unfoldr, find, nub, sort ) + ( unfoldr, nub, sort, (\\) ) import Data.Maybe - ( isJust, fromMaybe ) + ( isJust, fromMaybe, maybeToList ) import Control.Exception as Exception - ( handleJust ) + ( bracket, handleJust ) #if MIN_VERSION_base(4,0,0) import Control.Exception as Exception ( Exception(toException), catches, Handler(Handler), IOException ) @@ -42,12 +42,14 @@ import System.FilePath ( (), (<.>), takeDirectory ) import System.IO - ( openFile, IOMode(AppendMode) ) + ( openFile, IOMode(AppendMode), stdout, hFlush, hClose ) import System.IO.Error ( isDoesNotExistError, ioeGetFileName ) import Distribution.Client.Targets import Distribution.Client.Dependency +import Distribution.Client.Dependency.Types + ( Solver(..) ) import Distribution.Client.FetchUtils import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) -- import qualified Distribution.Client.Info as Info @@ -72,49 +74,54 @@ ( storeAnonymous, storeLocal, fromInstallPlan ) import qualified Distribution.Client.InstallSymlink as InstallSymlink ( symlinkBinaries ) +import qualified Distribution.Client.PackageIndex as SourcePackageIndex import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.World as World +import qualified Distribution.InstalledPackageInfo as Installed import Paths_cabal_install (getBinDir) +import Distribution.Client.JobControl import Distribution.Simple.Compiler ( CompilerId(..), Compiler(compilerId), compilerFlavor , PackageDB(..), PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration) import qualified Distribution.Simple.InstallDirs as InstallDirs -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Simple.Setup - ( haddockCommand, HaddockFlags(..), emptyHaddockFlags + ( haddockCommand, HaddockFlags(..) , buildCommand, BuildFlags(..), emptyBuildFlags , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.Setup as Cabal - ( installCommand, InstallFlags(..), emptyInstallFlags ) + ( installCommand, InstallFlags(..), emptyInstallFlags + , emptyTestFlags, testCommand, Flag(..) ) import Distribution.Simple.Utils ( rawSystemExit, comparing ) import Distribution.Simple.InstallDirs as InstallDirs ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate , initialPathTemplateEnv, installDirsTemplateEnv ) import Distribution.Package - ( PackageIdentifier, packageName, packageVersion + ( PackageIdentifier, PackageId, packageName, packageVersion , Package(..), PackageFixedDeps(..) - , Dependency(..), thisPackageVersion ) + , Dependency(..), thisPackageVersion, InstalledPackageId ) import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription - ( PackageDescription, GenericPackageDescription(..), TestSuite(..) ) + ( PackageDescription, GenericPackageDescription(..), Flag(..) + , FlagName(..), FlagAssignment ) import Distribution.PackageDescription.Configuration - ( finalizePackageDescription, mapTreeData ) + ( finalizePackageDescription ) import Distribution.Version ( Version, anyVersion, thisVersion ) import Distribution.Simple.Utils as Utils - ( notice, info, debug, warn, die, intercalate, withTempDirectory ) + ( notice, info, warn, die, intercalate, withTempDirectory ) import Distribution.Client.Utils - ( inDir, mergeBy, MergeResult(..) ) + ( numberOfProcessors, inDir, mergeBy, MergeResult(..) ) import Distribution.System ( Platform, buildPlatform, OS(Windows), buildOS ) import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity - ( Verbosity, showForCabal, verbose ) + ( Verbosity, showForCabal, verbose, deafening ) import Distribution.Simple.BuildPaths ( exeExtension ) --TODO: @@ -145,14 +152,17 @@ -> ConfigFlags -> ConfigExFlags -> InstallFlags + -> HaddockFlags -> [UserTarget] -> IO () install verbosity packageDBs repos comp conf - globalFlags configFlags configExFlags installFlags userTargets0 = do + globalFlags configFlags configExFlags installFlags haddockFlags userTargets0 = do installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf sourcePkgDb <- getSourcePackages verbosity repos + solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags)) (compilerId comp) + let -- For install, if no target is given it means we use the -- current directory as the single target userTargets | null userTargets0 = [UserTargetLocalDir "."] @@ -166,10 +176,11 @@ notice verbosity "Resolving dependencies..." installPlan <- foldProgress logMsg die return $ planPackages - comp configFlags configExFlags installFlags + comp solver configFlags configExFlags installFlags installedPkgIndex sourcePkgDb pkgSpecifiers - printPlanMessages verbosity installedPkgIndex installPlan dryRun + checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb + installFlags pkgSpecifiers unless dryRun $ do installPlan' <- performInstallations verbosity @@ -179,13 +190,16 @@ where context :: InstallContext context = (packageDBs, repos, comp, conf, - globalFlags, configFlags, configExFlags, installFlags) + globalFlags, configFlags, configExFlags, installFlags, haddockFlags) dryRun = fromFlag (installDryRun installFlags) - logMsg message rest = debug verbosity message >> rest - + logMsg message rest = debugNoWrap message >> rest + -- Solver debug output really looks better without automatic + -- line wrapping. TODO: This should probably be moved into + -- the utilities module. + debugNoWrap xs = when (verbosity >= deafening) (putStrLn xs >> hFlush stdout) -upgrade _ _ _ _ _ _ _ _ _ _ = die $ +upgrade _ _ _ _ _ _ _ _ _ _ _ = die $ "Use the 'cabal install' command instead of 'cabal upgrade'.\n" ++ "You can install the latest version of a package using 'cabal install'. " ++ "The 'cabal upgrade' command has been removed because people found it " @@ -205,25 +219,28 @@ , GlobalFlags , ConfigFlags , ConfigExFlags - , InstallFlags ) + , InstallFlags + , HaddockFlags ) -- ------------------------------------------------------------ -- * Installation planning -- ------------------------------------------------------------ planPackages :: Compiler + -> Solver -> ConfigFlags -> ConfigExFlags -> InstallFlags - -> PackageIndex InstalledPackage + -> PackageIndex -> SourcePackageDb -> [PackageSpecifier SourcePackage] -> Progress String String InstallPlan -planPackages comp configFlags configExFlags installFlags +planPackages comp solver configFlags configExFlags installFlags installedPkgIndex sourcePkgDb pkgSpecifiers = resolveDependencies buildPlatform (compilerId comp) + solver resolverParams >>= if onlyDeps then adjustPlanOnlyDeps else return @@ -231,7 +248,18 @@ where resolverParams = - setPreferenceDefault (if upgradeDeps then PreferAllLatest + setMaxBackjumps (if maxBackjumps < 0 then Nothing + else Just maxBackjumps) + + . setIndependentGoals independentGoals + + . setReorderGoals reorderGoals + + . setAvoidReinstalls avoidReinstalls + + . setShadowPkgs shadowPkgs + + . setPreferenceDefault (if upgradeDeps then PreferAllLatest else PreferLatestForSelected) . addPreferences @@ -249,24 +277,22 @@ [ PackageConstraintFlags (pkgSpecifierTarget pkgSpecifier) flags | let flags = configConfigurationsFlags configFlags , not (null flags) - , pkgSpecifier <- pkgSpecifiers' ] + , pkgSpecifier <- pkgSpecifiers ] + . addConstraints + [ PackageConstraintStanzas (pkgSpecifierTarget pkgSpecifier) stanzas + | pkgSpecifier <- pkgSpecifiers ] + . (if reinstall then reinstallTargets else id) - $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers' + $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers - -- Mark test suites as enabled if invoked with '--enable-tests'. This - -- ensures that test suite dependencies are included. - pkgSpecifiers' = map enableTests pkgSpecifiers + stanzas = concat + [ if testsEnabled then [TestStanzas] else [] + , if benchmarksEnabled then [BenchStanzas] else [] + ] testsEnabled = fromFlagOrDefault False $ configTests configFlags - enableTests (SpecificSourcePackage pkg) = - let pkgDescr = Source.packageDescription pkg - suites = condTestSuites pkgDescr - enable = mapTreeData (\t -> t { testEnabled = testsEnabled }) - in SpecificSourcePackage $ pkg { Source.packageDescription = pkgDescr - { condTestSuites = map (\(n, t) -> (n, enable t)) suites } } - enableTests x = x - + benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags --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 @@ -274,11 +300,8 @@ adjustPlanOnlyDeps :: InstallPlan -> Progress String String InstallPlan adjustPlanOnlyDeps = either (Fail . explain) Done - . InstallPlan.remove isTarget + . InstallPlan.remove (isTarget pkgSpecifiers) where - isTarget pkg = packageName pkg `elem` targetnames - targetnames = map pkgSpecifierTarget pkgSpecifiers - explain :: [InstallPlan.PlanProblem] -> String explain problems = "Cannot select only the dependencies (as requested by the " @@ -295,75 +318,238 @@ , depid <- depids , packageName depid `elem` targetnames ] - reinstall = fromFlag (installReinstall installFlags) - upgradeDeps = fromFlag (installUpgradeDeps installFlags) - onlyDeps = fromFlag (installOnlyDeps installFlags) + targetnames = map pkgSpecifierTarget pkgSpecifiers + + reinstall = fromFlag (installReinstall installFlags) + reorderGoals = fromFlag (installReorderGoals installFlags) + independentGoals = fromFlag (installIndependentGoals installFlags) + avoidReinstalls = fromFlag (installAvoidReinstalls installFlags) + shadowPkgs = fromFlag (installShadowPkgs installFlags) + maxBackjumps = fromFlag (installMaxBackjumps installFlags) + upgradeDeps = fromFlag (installUpgradeDeps installFlags) + onlyDeps = fromFlag (installOnlyDeps installFlags) + -- ------------------------------------------------------------ -- * Informational messages -- ------------------------------------------------------------ -printPlanMessages :: Verbosity - -> PackageIndex InstalledPackage - -> InstallPlan - -> Bool - -> IO () -printPlanMessages verbosity installed installPlan dryRun = do +-- | Perform post-solver checks of the install plan and print it if +-- either requested or needed. +checkPrintPlan :: Verbosity + -> PackageIndex + -> InstallPlan + -> SourcePackageDb + -> InstallFlags + -> [PackageSpecifier SourcePackage] + -> IO () +checkPrintPlan verbosity installed installPlan sourcePkgDb + installFlags pkgSpecifiers = do + -- User targets that are already installed. + let preExistingTargets = + [ p | let tgts = map pkgSpecifierTarget pkgSpecifiers, + InstallPlan.PreExisting p <- InstallPlan.toList installPlan, + packageName p `elem` tgts ] + + -- If there's nothing to install, we print the already existing + -- target packages as an explanation. when nothingToInstall $ - notice verbosity $ - "No packages to be installed. All the requested packages are " - ++ "already installed.\n If you want to reinstall anyway then use " - ++ "the --reinstall flag." + notice verbosity $ unlines $ + "All the requested packages are already installed:" + : map (display . packageId) preExistingTargets + ++ ["Use --reinstall if you want to reinstall anyway."] - when (dryRun || verbosity >= verbose) $ - printDryRun verbosity installed installPlan + let lPlan = linearizeInstallPlan installed installPlan + -- Are any packages classified as reinstalls? + let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan + -- Packages that are already broken. + let oldBrokenPkgs = + map Installed.installedPackageId + . PackageIndex.reverseDependencyClosure installed + . map (Installed.installedPackageId . fst) + . PackageIndex.brokenPackages + $ installed + let excluded = reinstalledPkgs ++ oldBrokenPkgs + -- Packages that are reverse dependencies of replaced packages are very + -- likely to be broken. We exclude packages that are already broken. + let newBrokenPkgs = + filter (\ p -> not (Installed.installedPackageId p `elem` excluded)) + (PackageIndex.reverseDependencyClosure installed reinstalledPkgs) + let containsReinstalls = not (null reinstalledPkgs) + let breaksPkgs = not (null newBrokenPkgs) + let adaptedVerbosity + | containsReinstalls && not overrideReinstall = verbosity `max` verbose + | otherwise = verbosity + + -- We print the install plan if we are in a dry-run or if we are confronted + -- with a dangerous install plan. + when (dryRun || containsReinstalls && not overrideReinstall) $ + printPlan (dryRun || breaksPkgs && not overrideReinstall) + adaptedVerbosity lPlan sourcePkgDb + + -- If the install plan is dangerous, we print various warning messages. In + -- particular, if we can see that packages are likely to be broken, we even + -- bail out (unless installation has been forced with --force-reinstalls). + when containsReinstalls $ do + if breaksPkgs + then do + (if dryRun || overrideReinstall then warn verbosity else die) $ unlines $ + "The following packages are likely to be broken by the reinstalls:" + : map (display . Installed.sourcePackageId) newBrokenPkgs + ++ if overrideReinstall + then if dryRun then [] else + ["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..." + where nothingToInstall = null (InstallPlan.ready installPlan) + dryRun = fromFlag (installDryRun installFlags) + overrideReinstall = fromFlag (installOverrideReinstall installFlags) -printDryRun :: Verbosity - -> PackageIndex InstalledPackage - -> InstallPlan - -> IO () -printDryRun verbosity installedPkgIndex plan = case unfoldr next plan of +linearizeInstallPlan :: PackageIndex + -> InstallPlan + -> [(ConfiguredPackage, PackageStatus)] +linearizeInstallPlan installedPkgIndex plan = + unfoldr next plan + where + next plan' = case InstallPlan.ready plan' of + [] -> Nothing + (pkg:_) -> Just ((pkg, status), plan'') + where + pkgid = packageId pkg + status = packageStatus installedPkgIndex pkg + plan'' = InstallPlan.completed pkgid + (BuildOk DocsNotTried TestsNotTried) + (InstallPlan.processing [pkg] plan') + --FIXME: This is a bit of a hack, + -- pretending that each package is installed + +data PackageStatus = NewPackage + | NewVersion [Version] + | Reinstall [InstalledPackageId] [PackageChange] + +type PackageChange = MergeResult PackageIdentifier PackageIdentifier + +isTarget :: Package pkg => [PackageSpecifier SourcePackage] -> pkg -> Bool +isTarget pkgSpecifiers pkg = packageName pkg `elem` targetnames + where + targetnames = map pkgSpecifierTarget pkgSpecifiers + +extractReinstalls :: PackageStatus -> [InstalledPackageId] +extractReinstalls (Reinstall ipids _) = ipids +extractReinstalls _ = [] + +packageStatus :: PackageIndex -> ConfiguredPackage -> PackageStatus +packageStatus installedPkgIndex cpkg = + case PackageIndex.lookupPackageName installedPkgIndex + (packageName cpkg) of + [] -> NewPackage + ps -> case filter ((==packageId cpkg) . Installed.sourcePackageId) (concatMap snd ps) of + [] -> NewVersion (map fst ps) + pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs) + (changes pkg cpkg) + + where + + changes :: Installed.InstalledPackageInfo + -> ConfiguredPackage + -> [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') + + changed (InBoth pkgid pkgid') = pkgid /= pkgid' + changed _ = True + +printPlan :: Bool -- is dry run + -> Verbosity + -> [(ConfiguredPackage, PackageStatus)] + -> SourcePackageDb + -> IO () +printPlan dryRun verbosity plan sourcePkgDb = case plan of [] -> return () pkgs | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ - "In order, the following would be installed:" + ("In order, the following " ++ wouldWill ++ " be installed:") : map showPkgAndReason pkgs | otherwise -> notice verbosity $ unlines $ - "In order, the following would be installed (use -v for more details):" - : map (display . packageId) pkgs + ("In order, the following " ++ wouldWill ++ " be installed (use -v for more details):") + : map showPkg pkgs where - next plan' = case InstallPlan.ready plan' of - [] -> Nothing - (pkg:_) -> Just (pkg, InstallPlan.completed pkgid result plan') - where pkgid = packageId pkg - result = BuildOk DocsNotTried TestsNotTried - --FIXME: This is a bit of a hack, - -- pretending that each package is installed + wouldWill | dryRun = "would" + | otherwise = "will" - showPkgAndReason pkg' = display (packageId pkg') ++ " " ++ - case PackageIndex.lookupPackageName installedPkgIndex - (packageName pkg') of - [] -> "(new package)" - ps -> case find ((==packageId pkg') . packageId) ps of - Nothing -> "(new version)" - Just pkg -> "(reinstall)" ++ case changes pkg pkg' of + showPkg (pkg, _) = display (packageId pkg) ++ + showLatest (pkg) + + showPkgAndReason (pkg', pr) = display (packageId pkg') ++ + showLatest pkg' ++ + showFlagAssignment (nonDefaultFlags pkg') ++ + showStanzas (stanzas pkg') ++ " " ++ + case pr of + NewPackage -> "(new package)" + NewVersion _ -> "(new version)" + Reinstall _ cs -> "(reinstall)" ++ case cs of [] -> "" - diff -> " changes: " ++ intercalate ", " diff - changes pkg pkg' = map change . filter changed - $ mergeBy (comparing packageName) - (nub . sort . depends $ pkg) - (nub . sort . depends $ pkg') + diff -> " changes: " ++ intercalate ", " (map change diff) + + showLatest :: ConfiguredPackage -> String + showLatest pkg = case mLatestVersion of + Just latestVersion -> + if pkgVersion /= latestVersion + then (" (latest: " ++ display latestVersion ++ ")") + else "" + Nothing -> "" + where + pkgVersion = packageVersion pkg + mLatestVersion :: Maybe Version + mLatestVersion = case SourcePackageIndex.lookupPackageName + (packageIndex sourcePkgDb) + (packageName pkg) of + [] -> Nothing + x -> Just $ packageVersion $ last x + + toFlagAssignment :: [Flag] -> FlagAssignment + toFlagAssignment = map (\ f -> (flagName f, flagDefault f)) + + nonDefaultFlags :: ConfiguredPackage -> FlagAssignment + nonDefaultFlags (ConfiguredPackage spkg fa _ _) = + let defaultAssignment = + toFlagAssignment + (genPackageFlags (Source.packageDescription spkg)) + in fa \\ defaultAssignment + + stanzas :: ConfiguredPackage -> [OptionalStanza] + stanzas (ConfiguredPackage _ _ sts _) = sts + + showStanzas :: [OptionalStanza] -> String + showStanzas = concatMap ((' ' :) . showStanza) + showStanza TestStanzas = "*test" + showStanza BenchStanzas = "*bench" + + -- FIXME: this should be a proper function in a proper place + showFlagAssignment :: FlagAssignment -> String + showFlagAssignment = concatMap ((' ' :) . showFlagValue) + showFlagValue (f, True) = '+' : showFlagName f + showFlagValue (f, False) = '-' : showFlagName f + showFlagName (FlagName f) = f + change (OnlyInLeft pkgid) = display pkgid ++ " removed" change (InBoth pkgid pkgid') = display pkgid ++ " -> " ++ display (packageVersion pkgid') change (OnlyInRight pkgid') = display pkgid' ++ " added" - changed (InBoth pkgid pkgid') = pkgid /= pkgid' - changed _ = True -- ------------------------------------------------------------ -- * Post installation stuff @@ -384,7 +570,7 @@ -> InstallPlan -> IO () postInstallActions verbosity - (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags) + (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags, _) targets installPlan = do unless oneShot $ @@ -557,6 +743,8 @@ ++ " The exception was:\n " ++ show e BuildFailed e -> " failed during the building phase." ++ " The exception was:\n " ++ show e + TestsFailed e -> " failed during the tests phase." + ++ " The exception was:\n " ++ show e InstallFailed e -> " failed during the final install step." ++ " The exception was:\n " ++ show e @@ -570,31 +758,49 @@ libVersion :: Maybe Version } +-- | If logging is enabled, contains location of the log file and the verbosity +-- level for logging. +type UseLogFile = Maybe (PackageIdentifier -> FilePath, Verbosity) + performInstallations :: Verbosity -> InstallContext - -> PackageIndex InstalledPackage + -> PackageIndex -> InstallPlan -> IO InstallPlan performInstallations verbosity (packageDBs, _, comp, conf, - globalFlags, configFlags, configExFlags, installFlags) + globalFlags, configFlags, configExFlags, installFlags, haddockFlags) installedPkgIndex installPlan = do - executeInstallPlan installPlan $ \cpkg -> + jobControl <- if parallelBuild then newParallelJobControl + else newSerialJobControl + buildLimit <- newJobLimit numJobs + fetchLimit <- newJobLimit (min numJobs numFetchJobs) + installLock <- newLock -- serialise installation + cacheLock <- newLock -- serialise access to setup exe cache + + executeInstallPlan verbosity jobControl useLogFile installPlan $ \cpkg -> installConfiguredPackage platform compid configFlags cpkg $ \configFlags' src pkg -> - fetchSourcePackage verbosity src $ \src' -> - installLocalPackage verbosity (packageId pkg) src' $ \mpath -> - installUnpackedPackage verbosity - (setupScriptOptions installedPkgIndex) - miscOptions configFlags' installFlags + fetchSourcePackage verbosity fetchLimit src $ \src' -> + installLocalPackage verbosity buildLimit (packageId pkg) src' $ \mpath -> + installUnpackedPackage verbosity buildLimit installLock numJobs + (setupScriptOptions installedPkgIndex cacheLock) + miscOptions configFlags' installFlags haddockFlags compid pkg mpath useLogFile where platform = InstallPlan.planPlatform installPlan compid = InstallPlan.planCompiler installPlan - setupScriptOptions index = SetupScriptOptions { + numJobs = case installNumJobs installFlags of + Cabal.NoFlag -> 1 + Cabal.Flag Nothing -> numberOfProcessors + Cabal.Flag (Just n) -> n + numFetchJobs = 2 + parallelBuild = numJobs >= 2 + + setupScriptOptions index lock = SetupScriptOptions { useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions), useCompiler = Just comp, -- Hack: we typically want to allow the UserPackageDB for finding the @@ -614,23 +820,56 @@ (useDistPref defaultSetupScriptOptions) (configDistPref configFlags), useLoggingHandle = Nothing, - useWorkingDir = Nothing + useWorkingDir = Nothing, + forceExternalSetupMethod = parallelBuild, + setupCacheLock = Just lock } reportingLevel = fromFlag (installBuildReports installFlags) logsDir = fromFlag (globalLogsDir globalFlags) - useLogFile :: Maybe (PackageIdentifier -> FilePath) - useLogFile = fmap substLogFileName logFileTemplate + + -- Should the build output be written to a log file instead of stdout? + useLogFile :: UseLogFile + useLogFile = fmap ((\f -> (f, loggingVerbosity)) . substLogFileName) + logFileTemplate where + installLogFile' = flagToMaybe $ installLogFile installFlags + defaultTemplate = toPathTemplate $ logsDir "$pkgid" <.> "log" + + -- If the user has specified --remote-build-reporting=detailed, use the + -- default log file location. If the --build-log option is set, use the + -- provided location. Otherwise don't use logging, unless building in + -- parallel (in which case the default location is used). logFileTemplate :: Maybe PathTemplate - logFileTemplate --TODO: separate policy from mechanism - | reportingLevel == DetailedReports - = Just $ toPathTemplate $ logsDir "$pkgid" <.> "log" - | otherwise - = flagToMaybe (installLogFile installFlags) + logFileTemplate + | useDefaultTemplate = Just defaultTemplate + | otherwise = installLogFile' + + -- If the user has specified --remote-build-reporting=detailed or + -- --build-log, use more verbose logging. + loggingVerbosity :: Verbosity + loggingVerbosity | overrideVerbosity = max Verbosity.verbose verbosity + | otherwise = verbosity + + useDefaultTemplate :: Bool + useDefaultTemplate + | reportingLevel == DetailedReports = True + | isJust installLogFile' = False + | parallelBuild = True + | otherwise = False + + overrideVerbosity :: Bool + overrideVerbosity + | reportingLevel == DetailedReports = True + | isJust installLogFile' = True + | parallelBuild = False + | otherwise = False + + substLogFileName :: PathTemplate -> PackageIdentifier -> FilePath substLogFileName template pkg = fromPathTemplate . substPathTemplate env $ template where env = initialPathTemplateEnv (packageId pkg) (compilerId comp) + miscOptions = InstallMisc { rootCmd = if fromFlag (configUserInstall configFlags) then Nothing -- ignore --root-cmd if --user. @@ -639,16 +878,41 @@ } -executeInstallPlan :: Monad m - => InstallPlan - -> (ConfiguredPackage -> m BuildResult) - -> m InstallPlan -executeInstallPlan plan installPkg = case InstallPlan.ready plan of - [] -> return plan - (pkg: _) -> do buildResult <- installPkg pkg - let plan' = updatePlan (packageId pkg) buildResult plan - executeInstallPlan plan' installPkg +executeInstallPlan :: Verbosity + -> JobControl IO (PackageId, BuildResult) + -> UseLogFile + -> InstallPlan + -> (ConfiguredPackage -> IO BuildResult) + -> IO InstallPlan +executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg = + tryNewTasks 0 plan0 where + tryNewTasks taskCount plan = do + case InstallPlan.ready plan of + [] | taskCount == 0 -> return plan + | otherwise -> waitForTasks taskCount plan + pkgs -> do + sequence_ + [ do info verbosity $ "Ready to install " ++ display pkgid + spawnJob jobCtl $ do + buildResult <- installPkg pkg + return (packageId pkg, buildResult) + | pkg <- pkgs + , let pkgid = packageId pkg] + + let taskCount' = taskCount + length pkgs + plan' = InstallPlan.processing pkgs plan + waitForTasks taskCount' plan' + + waitForTasks taskCount plan = do + info verbosity $ "Waiting for install task to finish..." + (pkgid, buildResult) <- collectJob jobCtl + printBuildResult pkgid 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 @@ -661,7 +925,28 @@ -- 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 + (Right _) -> notice verbosity $ "Installed " ++ display pkgid + (Left _) -> do + notice verbosity $ "Failed to install " ++ display pkgid + case useLogFile of + Nothing -> return () + Just (mkLogFileName, _) -> do + let (logName, n) = (mkLogFileName pkgid, 10) + notice verbosity $ "Last " ++ (show n) + ++ " lines of the build log ( " ++ logName ++ " ):" + printLastNLines logName n + 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_ (notice verbosity) (drop toDrop lns) + -- | Call an installer for an 'SourcePackage' but override the configure -- flags with the ones given by the 'ConfiguredPackage'. In particular the -- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly @@ -674,113 +959,144 @@ -> PackageDescription -> a) -> a installConfiguredPackage platform comp configFlags - (ConfiguredPackage (SourcePackage _ gpkg source) flags deps) + (ConfiguredPackage (SourcePackage _ gpkg source) flags stanzas deps) installPkg = installPkg configFlags { configConfigurationsFlags = flags, - configConstraints = map thisPackageVersion deps + configConstraints = map thisPackageVersion deps, + configBenchmarks = toFlag False, + configTests = toFlag (TestStanzas `elem` stanzas) } source pkg where pkg = case finalizePackageDescription flags (const True) - platform comp [] gpkg of + platform comp [] (enableStanzas stanzas gpkg) of Left _ -> error "finalizePackageDescription ConfiguredPackage failed" Right (desc, _) -> desc fetchSourcePackage :: Verbosity + -> JobLimit -> PackageLocation (Maybe FilePath) -> (PackageLocation FilePath -> IO BuildResult) -> IO BuildResult -fetchSourcePackage verbosity src installPkg = do +fetchSourcePackage verbosity fetchLimit src installPkg = do fetched <- checkFetched src case fetched of Just src' -> installPkg src' - Nothing -> onFailure DownloadFailed $ - fetchPackage verbosity src >>= installPkg + Nothing -> onFailure DownloadFailed $ do + loc <- withJobLimit fetchLimit $ + fetchPackage verbosity src + installPkg loc installLocalPackage - :: Verbosity -> PackageIdentifier -> PackageLocation FilePath + :: Verbosity + -> JobLimit + -> PackageIdentifier -> PackageLocation FilePath -> (Maybe FilePath -> IO BuildResult) -> IO BuildResult -installLocalPackage verbosity pkgid location installPkg = case location of +installLocalPackage verbosity jobLimit pkgid location installPkg = + case location of + LocalUnpackedPackage dir -> installPkg (Just dir) LocalTarballPackage tarballPath -> - installLocalTarballPackage verbosity pkgid tarballPath installPkg + installLocalTarballPackage verbosity jobLimit + pkgid tarballPath installPkg RemoteTarballPackage _ tarballPath -> - installLocalTarballPackage verbosity pkgid tarballPath installPkg + installLocalTarballPackage verbosity jobLimit + pkgid tarballPath installPkg RepoTarballPackage _ _ tarballPath -> - installLocalTarballPackage verbosity pkgid tarballPath installPkg + installLocalTarballPackage verbosity jobLimit + pkgid tarballPath installPkg installLocalTarballPackage - :: Verbosity -> PackageIdentifier -> FilePath + :: Verbosity + -> JobLimit + -> PackageIdentifier -> FilePath -> (Maybe FilePath -> IO BuildResult) -> IO BuildResult -installLocalTarballPackage verbosity pkgid tarballPath installPkg = do +installLocalTarballPackage verbosity jobLimit pkgid tarballPath installPkg = do tmp <- getTemporaryDirectory withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> onFailure UnpackFailed $ do - info verbosity $ "Extracting " ++ tarballPath - ++ " to " ++ tmpDirPath ++ "..." let relUnpackedPath = display pkgid absUnpackedPath = tmpDirPath relUnpackedPath descFilePath = absUnpackedPath display (packageName pkgid) <.> "cabal" - extractTarGzFile tmpDirPath relUnpackedPath tarballPath - exists <- doesFileExist descFilePath - when (not exists) $ - die $ "Package .cabal file not found: " ++ show descFilePath + withJobLimit jobLimit $ do + info verbosity $ "Extracting " ++ tarballPath + ++ " to " ++ tmpDirPath ++ "..." + extractTarGzFile tmpDirPath relUnpackedPath tarballPath + exists <- doesFileExist descFilePath + when (not exists) $ + die $ "Package .cabal file not found: " ++ show descFilePath installPkg (Just absUnpackedPath) -installUnpackedPackage :: Verbosity - -> SetupScriptOptions - -> InstallMisc - -> ConfigFlags - -> InstallFlags - -> CompilerId - -> PackageDescription - -> Maybe FilePath -- ^ Directory to change to before starting the installation. - -> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any) - -> IO BuildResult -installUnpackedPackage verbosity scriptOptions miscOptions - configFlags installConfigFlags +installUnpackedPackage + :: Verbosity + -> JobLimit + -> Lock + -> Int + -> SetupScriptOptions + -> InstallMisc + -> ConfigFlags + -> InstallFlags + -> HaddockFlags + -> CompilerId + -> PackageDescription + -> Maybe FilePath -- ^ Directory to change to before starting the installation. + -> UseLogFile -- ^ File to log output to (if any) + -> IO BuildResult +installUnpackedPackage verbosity buildLimit installLock numJobs + scriptOptions miscOptions + configFlags installConfigFlags haddockFlags compid pkg workingDir useLogFile = -- Configure phase - onFailure ConfigureFailed $ do + onFailure ConfigureFailed $ withJobLimit buildLimit $ do + when (numJobs > 1) $ notice verbosity $ + "Configuring " ++ display pkgid ++ "..." setup configureCommand configureFlags -- Build phase onFailure BuildFailed $ do + when (numJobs > 1) $ notice verbosity $ + "Building " ++ display pkgid ++ "..." setup buildCommand' buildFlags -- Doc generation phase docsResult <- if shouldHaddock - then (do setup haddockCommand haddockFlags + then (do setup haddockCommand haddockFlags' return DocsOk) `catchIO` (\_ -> return DocsFailed) `catchExit` (\_ -> return DocsFailed) else return DocsNotTried -- Tests phase - testsResult <- return TestsNotTried --TODO: add optional tests + onFailure TestsFailed $ do + when (testsEnabled && PackageDescription.hasTests pkg) $ + setup Cabal.testCommand testFlags - -- Install phase - onFailure InstallFailed $ - withWin32SelfUpgrade verbosity configFlags compid pkg $ do - case rootCmd miscOptions of - (Just cmd) -> reexec cmd - Nothing -> setup Cabal.installCommand installFlags - return (Right (BuildOk docsResult testsResult)) + let testsResult | testsEnabled = TestsOk + | otherwise = TestsNotTried + -- Install phase + onFailure InstallFailed $ criticalSection installLock $ + withWin32SelfUpgrade verbosity configFlags compid pkg $ do + case rootCmd miscOptions of + (Just cmd) -> reexec cmd + Nothing -> setup Cabal.installCommand installFlags + return (Right (BuildOk docsResult testsResult)) + where + pkgid = packageId pkg configureFlags = filterConfigureFlags configFlags { configVerbosity = toFlag verbosity' } @@ -790,31 +1106,36 @@ buildVerbosity = toFlag verbosity' } shouldHaddock = fromFlag (installDocumentation installConfigFlags) - haddockFlags _ = emptyHaddockFlags { - haddockDistPref = configDistPref configFlags, + haddockFlags' _ = haddockFlags { haddockVerbosity = toFlag verbosity' } + testsEnabled = fromFlag (configTests configFlags) + testFlags _ = Cabal.emptyTestFlags installFlags _ = Cabal.emptyInstallFlags { Cabal.installDistPref = configDistPref configFlags, Cabal.installVerbosity = toFlag verbosity' } - verbosity' | isJust useLogFile = max Verbosity.verbose verbosity - | otherwise = verbosity - setup cmd flags = do - logFileHandle <- case useLogFile of - Nothing -> return Nothing - Just mkLogFileName -> do - let logFileName = mkLogFileName (packageId pkg) - logDir = takeDirectory logFileName - unless (null logDir) $ createDirectoryIfMissing True logDir - logFile <- openFile logFileName AppendMode - return (Just logFile) + verbosity' = maybe verbosity snd useLogFile - setupWrapper verbosity - scriptOptions { useLoggingHandle = logFileHandle - , useWorkingDir = workingDir } - (Just pkg) - cmd flags [] + setup cmd flags = do + Exception.bracket + (case useLogFile of + Nothing -> return Nothing + Just (mkLogFileName, _) -> do + let logFileName = mkLogFileName (packageId pkg) + logDir = takeDirectory logFileName + unless (null logDir) $ createDirectoryIfMissing True logDir + logFile <- openFile logFileName AppendMode + return (Just logFile)) + (\mHandle -> case mHandle of + Just handle -> hClose handle + Nothing -> return ()) + (\logFileHandle -> + setupWrapper verbosity + scriptOptions { useLoggingHandle = logFileHandle + , useWorkingDir = workingDir } + (Just pkg) + cmd flags []) reexec cmd = do -- look for our on executable file and re-exec ourselves using -- a helper program like sudo to elevate priviledges: diff --git a/cabal/cabal-install/Distribution/Client/InstallPlan.hs b/cabal/cabal-install/Distribution/Client/InstallPlan.hs --- a/cabal/cabal-install/Distribution/Client/InstallPlan.hs +++ b/cabal/cabal-install/Distribution/Client/InstallPlan.hs @@ -20,6 +20,7 @@ new, toList, ready, + processing, completed, failed, remove, @@ -28,7 +29,7 @@ planPlatform, planCompiler, - -- * Checking valididy of plans + -- * Checking validity of plans valid, closed, consistent, @@ -46,8 +47,7 @@ import Distribution.Client.Types ( SourcePackage(packageDescription), ConfiguredPackage(..) - , InstalledPackage - , BuildFailure, BuildSuccess ) + , InstalledPackage, BuildFailure, BuildSuccess, enableStanzas ) import Distribution.Package ( PackageIdentifier(..), PackageName(..), Package(..), packageName , PackageFixedDeps(..), Dependency(..) ) @@ -93,7 +93,7 @@ -- -- Installed packages have fixed dependencies. They have already been built and -- we know exactly what packages they were built against, including their exact --- versions. +-- versions. -- -- Source package have somewhat flexible dependencies. They are specified as -- version ranges, though really they're predicates. To make matters worse they @@ -121,24 +121,27 @@ -- Note that plans do not necessarily compose. You might have a valid plan for -- package A and a valid plan for package B. That does not mean the composition --- is simultaniously valid for A and B. In particular you're most likely to +-- is simultaneously valid for A and B. In particular you're most likely to -- have problems with inconsistent dependencies. -- On the other hand it is true that every closed sub plan is valid. data PlanPackage = PreExisting InstalledPackage | Configured ConfiguredPackage + | Processing ConfiguredPackage | Installed ConfiguredPackage BuildSuccess | Failed ConfiguredPackage BuildFailure 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 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 @@ -204,13 +207,16 @@ ready :: InstallPlan -> [ConfiguredPackage] ready plan = assert check readyPackages where - check = if null readyPackages then null configuredPackages else True - configuredPackages = - [ pkg | Configured pkg <- PackageIndex.allPackages (planIndex plan) ] + check = if null readyPackages && null processingPackages + then null configuredPackages + else True + configuredPackages = [ pkg | Configured pkg <- toList plan ] + processingPackages = [ pkg | Processing pkg <- toList plan] readyPackages = filter (all isInstalled . depends) configuredPackages isInstalled pkg = case PackageIndex.lookupPackageId (planIndex plan) pkg of Just (Configured _) -> False + Just (Processing _) -> False Just (Failed _ _) -> internalError depOnFailed Just (PreExisting _) -> True Just (Installed _ _) -> True @@ -218,10 +224,22 @@ incomplete = "install plan is not closed" depOnFailed = "configured package depends on failed package" +-- | Marks packages in the graph as currently processing (e.g. building). +-- +-- * The package must exist in the graph and be in the configured state. +-- +processing :: [ConfiguredPackage] -> InstallPlan -> InstallPlan +processing pkgs plan = assert (invariant plan') plan' + where + plan' = plan { + planIndex = PackageIndex.merge (planIndex plan) processingPkgs + } + processingPkgs = PackageIndex.fromList [Processing pkg | pkg <- pkgs] + -- | Marks a package in the graph as completed. Also saves the build result for -- the completed package in the plan. -- --- * The package must exist in the graph. +-- * The package must exist in the graph and be in the processing state. -- * The package must have had no uninstalled dependent packages. -- completed :: PackageIdentifier @@ -232,12 +250,13 @@ plan' = plan { planIndex = PackageIndex.insert installed (planIndex plan) } - installed = Installed (lookupConfiguredPackage plan pkgid) buildResult + installed = Installed (lookupProcessingPackage plan pkgid) buildResult -- | Marks a package in the graph as having failed. It also marks all the -- packages that depended on it as having failed. -- --- * The package must exist in the graph and be in the configured state. +-- * 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 @@ -249,14 +268,14 @@ plan' = plan { planIndex = PackageIndex.merge (planIndex plan) failures } - pkg = lookupConfiguredPackage plan pkgid + pkg = lookupProcessingPackage plan pkgid failures = PackageIndex.fromList $ Failed pkg buildResult : [ Failed pkg' buildResult' | Just pkg' <- map checkConfiguredPackage $ packagesThatDependOn plan pkgid ] --- | lookup the reachable packages in the reverse dependency graph +-- | Lookup the reachable packages in the reverse dependency graph. -- packagesThatDependOn :: InstallPlan -> PackageIdentifier -> [PlanPackage] @@ -265,16 +284,16 @@ . Graph.reachable (planGraphRev plan) . planVertexOf plan --- | lookup a package that we expect to be in the configured state +-- | Lookup a package that we expect to be in the processing state. -- -lookupConfiguredPackage :: InstallPlan +lookupProcessingPackage :: InstallPlan -> PackageIdentifier -> ConfiguredPackage -lookupConfiguredPackage plan pkgid = +lookupProcessingPackage plan pkgid = case PackageIndex.lookupPackageId (planIndex plan) pkgid of - Just (Configured pkg) -> pkg - _ -> internalError $ "not configured or no such pkg " ++ display pkgid + Just (Processing pkg) -> pkg + _ -> internalError $ "not in processing state or no such pkg " ++ display pkgid --- | check a package that we expect to be in the configured or failed state +-- | Check a package that we expect to be in the configured or failed state. -- checkConfiguredPackage :: PlanPackage -> Maybe ConfiguredPackage checkConfiguredPackage (Configured pkg) = Just pkg @@ -335,6 +354,7 @@ where showPlanState (PreExisting _) = "pre-existing" showPlanState (Configured _) = "configured" + showPlanState (Processing _) = "processing" showPlanState (Installed _ _) = "installed" showPlanState (Failed _ _) = "failed" @@ -410,8 +430,12 @@ stateDependencyRelation (Configured _) (PreExisting _) = True stateDependencyRelation (Configured _) (Configured _) = True +stateDependencyRelation (Configured _) (Processing _) = True stateDependencyRelation (Configured _) (Installed _ _) = True +stateDependencyRelation (Processing _) (PreExisting _) = True +stateDependencyRelation (Processing _) (Installed _ _) = True + stateDependencyRelation (Installed _ _) (PreExisting _) = True stateDependencyRelation (Installed _ _) (Installed _ _) = True @@ -420,6 +444,7 @@ -- 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 @@ -472,7 +497,7 @@ configuredPackageProblems :: Platform -> CompilerId -> ConfiguredPackage -> [PackageProblem] configuredPackageProblems platform comp - (ConfiguredPackage pkg specifiedFlags specifiedDeps) = + (ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps) = [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ] ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] @@ -506,6 +531,6 @@ (const True) platform comp [] - (packageDescription pkg) of + (enableStanzas stanzas $ packageDescription pkg) of Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg Left _ -> error "configuredPackageInvalidDeps internal error" diff --git a/cabal/cabal-install/Distribution/Client/InstallSymlink.hs b/cabal/cabal-install/Distribution/Client/InstallSymlink.hs --- a/cabal/cabal-install/Distribution/Client/InstallSymlink.hs +++ b/cabal/cabal-install/Distribution/Client/InstallSymlink.hs @@ -40,7 +40,7 @@ #else import Distribution.Client.Types - ( SourcePackage(..), ConfiguredPackage(..) ) + ( SourcePackage(..), ConfiguredPackage(..), enableStanzas ) import Distribution.Client.Setup ( InstallFlags(installSymlinkBinDir) ) import qualified Distribution.Client.InstallPlan as InstallPlan @@ -67,9 +67,10 @@ import System.FilePath ( (), splitPath, joinPath, isAbsolute ) -import Prelude hiding (catch, ioError) +import Prelude hiding (ioError) import System.IO.Error - ( catch, isDoesNotExistError, ioError ) + ( isDoesNotExistError, ioError ) +import Distribution.Compat.Exception ( catchIO ) import Control.Exception ( assert ) import Data.Maybe @@ -132,10 +133,10 @@ , PackageDescription.buildable (PackageDescription.buildInfo exe) ] pkgDescription :: ConfiguredPackage -> PackageDescription - pkgDescription (ConfiguredPackage (SourcePackage _ pkg _) flags _) = + pkgDescription (ConfiguredPackage (SourcePackage _ pkg _) flags stanzas _) = case finalizePackageDescription flags (const True) - platform compilerId [] pkg of + platform compilerId [] (enableStanzas stanzas pkg) of Left _ -> error "finalizePackageDescription ConfiguredPackage failed" Right (desc, _) -> desc @@ -209,7 +210,7 @@ else return NotOurFile where - handleNotExist action = catch action $ \ioexception -> + handleNotExist action = catchIO action $ \ioexception -> -- If the target doesn't exist then there's no problem overwriting it! if isDoesNotExistError ioexception then return NotExists diff --git a/cabal/cabal-install/Distribution/Client/JobControl.hs b/cabal/cabal-install/Distribution/Client/JobControl.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/JobControl.hs @@ -0,0 +1,89 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.JobControl +-- Copyright : (c) Duncan Coutts 2012 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A job control concurrency abstraction +----------------------------------------------------------------------------- +module Distribution.Client.JobControl ( + JobControl, + newSerialJobControl, + newParallelJobControl, + spawnJob, + collectJob, + + JobLimit, + newJobLimit, + withJobLimit, + + Lock, + newLock, + criticalSection + ) where + +import Control.Monad +import Control.Concurrent +import Control.Exception + +data JobControl m a = JobControl { + spawnJob :: m a -> m (), + collectJob :: m a + } + + +newSerialJobControl :: IO (JobControl IO a) +newSerialJobControl = do + queue <- newChan + return JobControl { + spawnJob = spawn queue, + collectJob = collect queue + } + where + spawn :: Chan (IO a) -> IO a -> IO () + spawn = writeChan + + collect :: Chan (IO a) -> IO a + collect = join . readChan + +newParallelJobControl :: IO (JobControl IO a) +newParallelJobControl = do + resultVar <- newEmptyMVar + return JobControl { + spawnJob = spawn resultVar, + collectJob = collect resultVar + } + where + spawn :: MVar (Either SomeException a) -> IO a -> IO () + spawn resultVar job = + mask $ \restore -> + forkIO (do res <- try (restore job) + putMVar resultVar res) + >> return () + + collect :: MVar (Either SomeException a) -> IO a + collect resultVar = + takeMVar resultVar >>= either throw return + + +data JobLimit = JobLimit QSem + +newJobLimit :: Int -> IO JobLimit +newJobLimit n = + fmap JobLimit (newQSem n) + +withJobLimit :: JobLimit -> IO a -> IO a +withJobLimit (JobLimit sem) = + bracket_ (waitQSem sem) (signalQSem sem) + +newtype Lock = Lock (MVar ()) + +newLock :: IO Lock +newLock = fmap Lock $ newMVar () + +criticalSection :: Lock -> IO a -> IO a +criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act diff --git a/cabal/cabal-install/Distribution/Client/List.hs b/cabal/cabal-install/Distribution/Client/List.hs --- a/cabal/cabal-install/Distribution/Client/List.hs +++ b/cabal/cabal-install/Distribution/Client/List.hs @@ -15,7 +15,7 @@ import Distribution.Package ( PackageName(..), Package(..), packageName, packageVersion - , Dependency(..), thisPackageVersion, depends, simplifyDependency ) + , Dependency(..), simplifyDependency ) import Distribution.ModuleName (ModuleName) import Distribution.License (License) import qualified Distribution.InstalledPackageInfo as Installed @@ -31,6 +31,7 @@ import Distribution.Simple.Utils ( equating, comparing, die, notice ) import Distribution.Simple.Setup (fromFlag) +import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Version ( Version(..), VersionRange, withinRange, anyVersion @@ -40,10 +41,9 @@ ( Text(disp), display ) import Distribution.Client.Types - ( SourcePackage(..), Repo, SourcePackageDb(..) - , InstalledPackage(..) ) + ( SourcePackage(..), Repo, SourcePackageDb(..) ) import Distribution.Client.Dependency.Types - ( PackageConstraint(..) ) + ( PackageConstraint(..), ExtDependency(..) ) import Distribution.Client.Targets ( UserTarget, resolveUserTargets, PackageSpecifier(..) ) import Distribution.Client.Setup @@ -65,7 +65,7 @@ ( MonadPlus(mplus), join ) import Control.Exception ( assert ) -import Text.PrettyPrint.HughesPJ as Disp +import Text.PrettyPrint as Disp import System.Directory ( doesDirectoryExist ) @@ -87,15 +87,15 @@ prefs name = fromMaybe anyVersion (Map.lookup name (packagePreferences sourcePkgDb)) - pkgsInfo :: [(PackageName, [InstalledPackage], [SourcePackage])] + pkgsInfo :: [(PackageName, [Installed.InstalledPackageInfo], [SourcePackage])] pkgsInfo -- gather info for all packages - | null pats = mergePackages (PackageIndex.allPackages installedPkgIndex) - (PackageIndex.allPackages sourcePkgIndex) + | null pats = mergePackages (InstalledPackageIndex.allPackages installedPkgIndex) + ( PackageIndex.allPackages sourcePkgIndex) -- gather info for packages matching search term - | otherwise = mergePackages (matchingPackages installedPkgIndex) - (matchingPackages sourcePkgIndex) + | otherwise = mergePackages (matchingPackages InstalledPackageIndex.searchByNameSubstring installedPkgIndex) + (matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchByNameSubstring idx n)) sourcePkgIndex) matches :: [PackageDisplayInfo] matches = [ mergePackageInfo pref @@ -124,11 +124,10 @@ onlyInstalled = fromFlag (listInstalled listFlags) simpleOutput = fromFlag (listSimpleOutput listFlags) - matchingPackages index = + matchingPackages search index = [ pkg | pat <- pats - , (_, pkgs) <- PackageIndex.searchByNameSubstring index pat - , pkg <- pkgs ] + , pkg <- search index pat ] info :: Verbosity -> PackageDBStack @@ -152,8 +151,8 @@ -- just available source packages, so we must resolve targets using -- the combination of installed and source packages. let sourcePkgs' = PackageIndex.fromList - $ map packageId (PackageIndex.allPackages installedPkgIndex) - ++ map packageId (PackageIndex.allPackages sourcePkgIndex) + $ map packageId (InstalledPackageIndex.allPackages installedPkgIndex) + ++ map packageId ( PackageIndex.allPackages sourcePkgIndex) pkgSpecifiers <- resolveUserTargets verbosity (fromFlag $ globalWorldFile globalFlags) sourcePkgs' userTargets @@ -169,6 +168,11 @@ putStr $ unlines (map showPackageDetailedInfo pkgsinfo) where + gatherPkgInfo :: (PackageName -> VersionRange) -> + InstalledPackageIndex.PackageIndex -> + PackageIndex.PackageIndex SourcePackage -> + PackageSpecifier SourcePackage -> + Either String PackageDisplayInfo gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (NamedPackage name constraints) | null (selectedInstalledPkgs) && null (selectedSourcePkgs) = Left $ "There is no available version of " ++ display name @@ -177,18 +181,18 @@ | otherwise = Right $ mergePackageInfo pref installedPkgs - sourcePkgs selectedSourcePkg + sourcePkgs selectedSourcePkg' showPkgVersion where pref = prefs name - installedPkgs = PackageIndex.lookupPackageName installedPkgIndex name - sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name + installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name) + sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name - selectedInstalledPkgs = PackageIndex.lookupDependency installedPkgIndex + selectedInstalledPkgs = InstalledPackageIndex.lookupDependency installedPkgIndex (Dependency name verConstraint) - selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex + selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex (Dependency name verConstraint) - selectedSourcePkg = latestWithPref pref selectedSourcePkgs + selectedSourcePkg' = latestWithPref pref selectedSourcePkgs -- display a specific package version if the user -- supplied a non-trivial version constraint @@ -202,8 +206,8 @@ where name = packageName pkg pref = prefs name - installedPkgs = PackageIndex.lookupPackageName installedPkgIndex name - sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name + installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name) + sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name selectedPkg = Just pkg @@ -226,7 +230,7 @@ license :: License, author :: String, maintainer :: String, - dependencies :: [Dependency], + dependencies :: [ExtDependency], flags :: [Flag], hasLib :: Bool, hasExe :: Bool, @@ -353,7 +357,7 @@ -- package name. -- mergePackageInfo :: VersionRange - -> [InstalledPackage] + -> [Installed.InstalledPackageInfo] -> [SourcePackage] -> Maybe SourcePackage -> Bool @@ -400,9 +404,8 @@ modules = combine Installed.exposedModules installed (maybe [] Source.exposedModules . Source.library) source, - dependencies = map simplifyDependency - $ combine Source.buildDepends source - (map thisPackageVersion . depends) installed', + dependencies = combine (map (SourceDependency . simplifyDependency) . Source.buildDepends) source + (map InstalledDependency . Installed.depends) installed, haddockHtml = fromMaybe "" . join . fmap (listToMaybe . Installed.haddockHTMLs) $ installed, @@ -410,8 +413,8 @@ } where combine f x g y = fromJust (fmap f x `mplus` fmap g y) - installed' = latestWithPref versionPref installedPkgs - installed = fmap (\(InstalledPackage p _) -> p) installed' + installed :: Maybe Installed.InstalledPackageInfo + installed = latestWithPref versionPref installedPkgs sourceSelected | isJust selectedPkg = selectedPkg @@ -450,10 +453,10 @@ -- same package by name. In the result pairs, the lists are guaranteed to not -- both be empty. -- -mergePackages :: [InstalledPackage] +mergePackages :: [Installed.InstalledPackageInfo] -> [SourcePackage] -> [( PackageName - , [InstalledPackage] + , [Installed.InstalledPackageInfo] , [SourcePackage] )] mergePackages installedPkgs sourcePkgs = map collect diff --git a/cabal/cabal-install/Distribution/Client/PackageEnvironment.hs b/cabal/cabal-install/Distribution/Client/PackageEnvironment.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/PackageEnvironment.hs @@ -0,0 +1,380 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.PackageEnvironment +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Utilities for working with the package environment file. Patterned after +-- Distribution.Client.Config. +----------------------------------------------------------------------------- + +module Distribution.Client.PackageEnvironment ( + PackageEnvironment(..) + , loadOrCreatePackageEnvironment + , tryLoadPackageEnvironment + , readPackageEnvironmentFile + , showPackageEnvironment + , showPackageEnvironmentWithComments + + , basePackageEnvironment + , initialPackageEnvironment + , commentPackageEnvironment + , defaultPackageEnvironmentFileName + ) where + +import Distribution.Client.Config ( SavedConfig(..), commentSavedConfig, + initialSavedConfig, loadConfig, + configFieldDescriptions, + installDirsFields, defaultCompiler ) +import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) +import Distribution.Client.Setup ( GlobalFlags(..), ConfigExFlags(..) + , InstallFlags(..) ) +import Distribution.Simple.Compiler ( Compiler, PackageDB(..) + , showCompilerId ) +import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate, + toPathTemplate ) +import Distribution.Simple.Setup ( Flag(..), ConfigFlags(..), + fromFlagOrDefault, toFlag ) +import Distribution.Simple.Utils ( die, notice, warn, lowercase ) +import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..), + commaListField, + liftField, lineNo, locatedErrorMsg, + parseFilePathQ, readFields, + showPWarning, simpleField, warning ) +import Distribution.Verbosity ( Verbosity, normal ) +import Control.Monad ( foldM, when ) +import Data.List ( partition ) +import Data.Monoid ( Monoid(..) ) +import Distribution.Compat.Exception ( catchIO ) +import System.Directory ( renameFile ) +import System.FilePath ( (<.>), () ) +import System.IO.Error ( isDoesNotExistError ) +import Text.PrettyPrint ( ($+$) ) + +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.ParseUtils as ParseUtils ( Field(..) ) +import qualified Distribution.Text as Text + +-- +-- * Configuration saved in the package environment file +-- + +-- TODO: would be nice to remove duplication between D.C.PackageEnvironment and +-- D.C.Config. +data PackageEnvironment = PackageEnvironment { + pkgEnvInherit :: Flag FilePath, + pkgEnvSavedConfig :: SavedConfig +} + +instance Monoid PackageEnvironment where + mempty = PackageEnvironment { + pkgEnvInherit = mempty, + pkgEnvSavedConfig = mempty + } + + mappend a b = PackageEnvironment { + pkgEnvInherit = combine pkgEnvInherit, + pkgEnvSavedConfig = combine pkgEnvSavedConfig + } + where + combine f = f a `mappend` f b + +defaultPackageEnvironmentFileName :: FilePath +defaultPackageEnvironmentFileName = "pkgenv" + +-- | Defaults common to 'initialPackageEnvironment' and +-- 'commentPackageEnvironment'. +commonPackageEnvironmentConfig :: FilePath -> SavedConfig +commonPackageEnvironmentConfig pkgEnvDir = + mempty { + savedConfigureFlags = mempty { + configUserInstall = toFlag False, + configInstallDirs = sandboxInstallDirs + }, + savedUserInstallDirs = sandboxInstallDirs, + savedGlobalInstallDirs = sandboxInstallDirs, + savedGlobalFlags = mempty { + globalLogsDir = toFlag $ pkgEnvDir "logs", + -- Is this right? cabal-dev uses the global world file. + globalWorldFile = toFlag $ pkgEnvDir "world" + } + } + where + sandboxInstallDirs = mempty { prefix = toFlag (toPathTemplate pkgEnvDir) } + +-- | These are the absolute basic defaults, the fields that must be +-- initialised. When we load the package environment from the file we layer the +-- loaded values over these ones. +basePackageEnvironment :: FilePath -> PackageEnvironment +basePackageEnvironment pkgEnvDir = do + let baseConf = commonPackageEnvironmentConfig pkgEnvDir in + mempty { + pkgEnvSavedConfig = baseConf { + savedConfigureFlags = (savedConfigureFlags baseConf) { + configHcFlavor = toFlag defaultCompiler, + configVerbosity = toFlag normal + } + } + } + +-- | Initial configuration that we write out to the package environment file if +-- it does not exist. When the package environment gets loaded it gets layered +-- on top of 'basePackageEnvironment'. +initialPackageEnvironment :: FilePath -> Compiler -> IO PackageEnvironment +initialPackageEnvironment pkgEnvDir compiler = do + initialConf' <- initialSavedConfig + let baseConf = commonPackageEnvironmentConfig pkgEnvDir + let initialConf = initialConf' `mappend` baseConf + return $ mempty { + pkgEnvSavedConfig = initialConf { + savedGlobalFlags = (savedGlobalFlags initialConf) { + globalLocalRepos = [pkgEnvDir "packages"] + }, + savedConfigureFlags = setPackageDB pkgEnvDir compiler + (savedConfigureFlags initialConf), + savedInstallFlags = (savedInstallFlags initialConf) { + installSummaryFile = [toPathTemplate (pkgEnvDir + "logs" "build.log")] + } + } + } + +-- | Use the package DB location specific for this compiler. +setPackageDB :: FilePath -> Compiler -> ConfigFlags -> ConfigFlags +setPackageDB pkgEnvDir compiler configFlags = + configFlags { + configPackageDBs = [Just (SpecificPackageDB $ pkgEnvDir + (showCompilerId compiler ++ + "-packages.conf.d"))] + } + +-- | Default values that get used if no value is given. Used here to include in +-- comments when we write out the initial package environment. +commentPackageEnvironment :: FilePath -> IO PackageEnvironment +commentPackageEnvironment pkgEnvDir = do + commentConf <- commentSavedConfig + let baseConf = commonPackageEnvironmentConfig pkgEnvDir + return $ mempty { + pkgEnvSavedConfig = commentConf `mappend` baseConf + } + +-- | Given a package environment loaded from a file, layer it on top of the base +-- package environment. +addBasePkgEnv :: Verbosity -> FilePath -> PackageEnvironment + -> IO PackageEnvironment +addBasePkgEnv verbosity pkgEnvDir extra = do + let base = basePackageEnvironment pkgEnvDir + baseConf = pkgEnvSavedConfig base + -- Does this package environment inherit from some config file? + case pkgEnvInherit extra of + NoFlag -> + return $ base `mappend` extra + (Flag confPath) -> do + conf <- loadConfig verbosity (Flag confPath) NoFlag + let conf' = baseConf `mappend` conf `mappend` (pkgEnvSavedConfig extra) + return $ extra { pkgEnvSavedConfig = conf' } + +-- | Try to load a package environment file, exiting with error if it doesn't +-- exist. +tryLoadPackageEnvironment :: Verbosity -> FilePath -> IO PackageEnvironment +tryLoadPackageEnvironment verbosity pkgEnvDir = do + let path = pkgEnvDir defaultPackageEnvironmentFileName + minp <- readPackageEnvironmentFile mempty path + pkgEnv <- case minp of + Nothing -> die $ + "The package environment file '" ++ path ++ "' doesn't exist" + Just (ParseOk warns parseResult) -> do + when (not $ null warns) $ warn verbosity $ + unlines (map (showPWarning path) warns) + return parseResult + Just (ParseFailed err) -> do + let (line, msg) = locatedErrorMsg err + die $ "Error parsing package environment file " ++ path + ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg + addBasePkgEnv verbosity pkgEnvDir pkgEnv + +-- | Load a package environment file, creating one if it doesn't exist. Note +-- that the path parameter should be a name of an existing directory. +loadOrCreatePackageEnvironment :: Verbosity -> FilePath + -> ConfigFlags -> Compiler + -> IO PackageEnvironment +loadOrCreatePackageEnvironment verbosity pkgEnvDir configFlags compiler = do + let path = pkgEnvDir defaultPackageEnvironmentFileName + minp <- readPackageEnvironmentFile mempty path + pkgEnv <- case minp of + Nothing -> do + notice verbosity $ "Writing default package environment to " ++ path + commentPkgEnv <- commentPackageEnvironment pkgEnvDir + initialPkgEnv <- initialPackageEnvironment pkgEnvDir compiler + let pkgEnv = updateConfigFlags initialPkgEnv + (\flags -> flags `mappend` configFlags) + writePackageEnvironmentFile path commentPkgEnv pkgEnv + return initialPkgEnv + Just (ParseOk warns parseResult) -> do + when (not $ null warns) $ warn verbosity $ + unlines (map (showPWarning path) warns) + + -- Update the package environment file in case the user has changed some + -- settings via the command-line (otherwise 'configure -w compiler-B' will + -- fail for a sandbox already configured to use compiler-A). + notice verbosity $ "Writing the updated package environment to " ++ path + commentPkgEnv <- commentPackageEnvironment pkgEnvDir + let pkgEnv = updateConfigFlags parseResult + (\flags -> + setPackageDB pkgEnvDir compiler flags + `mappend` configFlags) + writePackageEnvironmentFile path commentPkgEnv pkgEnv + + return pkgEnv + Just (ParseFailed err) -> do + let (line, msg) = locatedErrorMsg err + warn verbosity $ + "Error parsing package environment file " ++ path + ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg + warn verbosity $ "Using default package environment." + initialPackageEnvironment pkgEnvDir compiler + addBasePkgEnv verbosity pkgEnvDir pkgEnv + + where + updateConfigFlags :: PackageEnvironment -> (ConfigFlags -> ConfigFlags) + -> PackageEnvironment + updateConfigFlags pkgEnv f = + let pkgEnvConfig = pkgEnvSavedConfig pkgEnv + pkgEnvConfigFlags = savedConfigureFlags pkgEnvConfig + in pkgEnv { + pkgEnvSavedConfig = pkgEnvConfig { + savedConfigureFlags = f pkgEnvConfigFlags + } + } + +-- | Descriptions of all fields in the package environment file. +pkgEnvFieldDescrs :: [FieldDescr PackageEnvironment] +pkgEnvFieldDescrs = [ + 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 + (configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig) + (\v pkgEnv -> updateConfigureExFlags pkgEnv + (\flags -> flags { configExConstraints = v })) + + , commaListField "preferences" + Text.disp Text.parse + (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig) + (\v pkgEnv -> updateConfigureExFlags pkgEnv + (\flags -> flags { configPreferences = v })) + ] + ++ map toPkgEnv configFieldDescriptions' + where + optional = Parse.option mempty . fmap toFlag + + configFieldDescriptions' :: [FieldDescr SavedConfig] + configFieldDescriptions' = filter + (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint") + configFieldDescriptions + + toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment + toPkgEnv fieldDescr = + liftField pkgEnvSavedConfig + (\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig}) + fieldDescr + + updateConfigureExFlags :: PackageEnvironment + -> (ConfigExFlags -> ConfigExFlags) + -> PackageEnvironment + updateConfigureExFlags pkgEnv f = pkgEnv { + pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) { + savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig + $ pkgEnv + } + } + +-- | Read the package environment file. +readPackageEnvironmentFile :: PackageEnvironment -> FilePath + -> IO (Maybe (ParseResult PackageEnvironment)) +readPackageEnvironmentFile initial file = + handleNotExists $ + fmap (Just . parsePackageEnvironment initial) (readFile file) + where + handleNotExists action = catchIO action $ \ioe -> + if isDoesNotExistError ioe + then return Nothing + else ioError ioe + +-- | Parse the package environment file. +parsePackageEnvironment :: PackageEnvironment -> String + -> ParseResult PackageEnvironment +parsePackageEnvironment 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 + return pkgEnv { + pkgEnvSavedConfig = config { + savedUserInstallDirs = installDirs, + savedGlobalInstallDirs = installDirs + } + } + + where + isKnownSection :: ParseUtils.Field -> Bool + isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True + isKnownSection _ = False + + parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment + parse = parseFields pkgEnvFieldDescrs initial + + parseSection :: InstallDirs (Flag PathTemplate) + -> ParseUtils.Field + -> ParseResult (InstallDirs (Flag PathTemplate)) + parseSection accum (ParseUtils.Section _ "install-dirs" name fs) + | name' == "" = do accum' <- parseFields installDirsFields accum fs + return accum' + | otherwise = do warning "The install-dirs section should be unnamed" + return accum + where name' = lowercase name + parseSection accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +-- | Write out the package environment file. +writePackageEnvironmentFile :: FilePath -> PackageEnvironment + -> PackageEnvironment -> IO () +writePackageEnvironmentFile path comments pkgEnv = do + let tmpPath = (path <.> "tmp") + writeFile tmpPath $ explanation + ++ showPackageEnvironmentWithComments comments pkgEnv ++ "\n" + renameFile tmpPath path + where + explanation = unlines + ["-- This is a Cabal package environment file." + ,"" + ,"-- The available configuration options are listed below." + ,"-- Some of them have default values listed." + ,"" + ,"-- Lines (like this one) beginning with '--' are comments." + ,"-- Be careful with spaces and indentation because they are" + ,"-- used to indicate layout for nested sections." + ,"","" + ] + +-- | Pretty-print the package environment data. +showPackageEnvironment :: PackageEnvironment -> String +showPackageEnvironment = showPackageEnvironmentWithComments mempty + +showPackageEnvironmentWithComments :: PackageEnvironment -> PackageEnvironment + -> String +showPackageEnvironmentWithComments defPkgEnv pkgEnv = Disp.render $ + ppFields pkgEnvFieldDescrs defPkgEnv pkgEnv + $+$ Disp.text "" + $+$ ppSection "install-dirs" "" installDirsFields + (field defPkgEnv) (field pkgEnv) + where + field = savedUserInstallDirs . pkgEnvSavedConfig diff --git a/cabal/cabal-install/Distribution/Client/PackageIndex.hs b/cabal/cabal-install/Distribution/Client/PackageIndex.hs --- a/cabal/cabal-install/Distribution/Client/PackageIndex.hs +++ b/cabal/cabal-install/Distribution/Client/PackageIndex.hs @@ -78,7 +78,7 @@ -- -- It can be searched effeciently by package name and version. -- -newtype Package pkg => PackageIndex pkg = PackageIndex +newtype PackageIndex pkg = PackageIndex -- This index package names to all the package records matching that package -- name case-sensitively. It includes all versions. -- diff --git a/cabal/cabal-install/Distribution/Client/ParseUtils.hs b/cabal/cabal-install/Distribution/Client/ParseUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/ParseUtils.hs @@ -0,0 +1,55 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.ParseUtils +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Parsing utilities. +----------------------------------------------------------------------------- + +module Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) + where + +import Distribution.ParseUtils + ( FieldDescr(..), ParseResult(..), warning, lineNo ) +import qualified Distribution.ParseUtils as ParseUtils + ( Field(..) ) + +import Control.Monad ( foldM ) +import Text.PrettyPrint ( (<>), (<+>), ($$) ) +import qualified Data.Map as Map +import qualified Text.PrettyPrint as Disp + ( Doc, text, colon, vcat, isEmpty, nest ) + +--FIXME: replace this with something better +parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a +parseFields fields initial = foldM setField initial + where + fieldMap = Map.fromList + [ (name, f) | f@(FieldDescr name _ _) <- fields ] + setField accum (ParseUtils.F line name value) = + case Map.lookup name fieldMap of + Just (FieldDescr _ _ set) -> set line value accum + Nothing -> do + warning $ "Unrecognized field " ++ name ++ " on line " ++ show line + return accum + setField accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +-- | This is a customised version of the function from Cabal that also prints +-- default values for empty fields as comments. +-- +ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc +ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur) + | FieldDescr name getter _ <- fields] + +ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc +ppField name def cur + | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def + | otherwise = Disp.text name <> Disp.colon <+> cur + +ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc +ppSection name arg fields def cur = + Disp.text name <+> Disp.text arg + $$ Disp.nest 2 (ppFields fields def cur) diff --git a/cabal/cabal-install/Distribution/Client/Sandbox.hs b/cabal/cabal-install/Distribution/Client/Sandbox.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Sandbox.hs @@ -0,0 +1,215 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Sandbox +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- UI for the sandboxing functionality. +----------------------------------------------------------------------------- + +module Distribution.Client.Sandbox ( + dumpPackageEnvironment, + + sandboxAddSource, + sandboxConfigure, + sandboxBuild, + sandboxInstall + ) where + +import Distribution.Client.Setup + ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), GlobalFlags(..) + , InstallFlags(..), globalRepos + , defaultInstallFlags, defaultConfigExFlags, defaultSandboxLocation + , installCommand ) +import Distribution.Client.Config ( SavedConfig(..), loadConfig ) +import Distribution.Client.Configure ( configure ) +import Distribution.Client.Install ( install ) +import Distribution.Client.PackageEnvironment + ( PackageEnvironment(..) + , loadOrCreatePackageEnvironment, tryLoadPackageEnvironment + , commentPackageEnvironment + , showPackageEnvironmentWithComments, readPackageEnvironmentFile + , basePackageEnvironment, defaultPackageEnvironmentFileName ) +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Client.Targets ( readUserTargets ) +import Distribution.Simple.Compiler ( Compiler + , PackageDB(..), PackageDBStack ) +import Distribution.Simple.Configure ( configCompilerAux + , interpretPackageDbFlags ) +import Distribution.Simple.Program ( ProgramConfiguration + , defaultProgramConfiguration ) +import Distribution.Simple.Setup ( Flag(..), toFlag + , BuildFlags(..), HaddockFlags(..) + , buildCommand, fromFlagOrDefault ) +import Distribution.Simple.Utils ( die, notice + , createDirectoryIfMissingVerbose ) +import Distribution.ParseUtils ( ParseResult(..) ) +import Distribution.Verbosity ( Verbosity, lessVerbose ) +import qualified Distribution.Client.Index as Index +import qualified Distribution.Simple.Register as Register +import Control.Monad ( unless, when ) +import Data.Monoid ( mappend, mempty ) +import System.Directory ( canonicalizePath + , doesDirectoryExist + , doesFileExist ) +import System.FilePath ( () ) + + +-- | Given a 'SandboxFlags' record, return a canonical path to the +-- sandbox. Exits with error if the sandbox directory does not exist or is not +-- properly initialised. +getSandboxLocation :: Verbosity -> SandboxFlags -> IO FilePath +getSandboxLocation verbosity sandboxFlags = do + let sandboxDir' = fromFlagOrDefault defaultSandboxLocation + (sandboxLocation sandboxFlags) + sandboxDir <- canonicalizePath sandboxDir' + dirExists <- doesDirectoryExist sandboxDir + pkgEnvExists <- doesFileExist $ + sandboxDir defaultPackageEnvironmentFileName + unless (dirExists && pkgEnvExists) $ + die ("No sandbox exists at " ++ sandboxDir) + notice verbosity $ "Using a sandbox located at " ++ sandboxDir + return sandboxDir + +-- | Return the name of the package index file for this package environment. +getIndexFilePath :: PackageEnvironment -> IO FilePath +getIndexFilePath pkgEnv = do + let paths = globalLocalRepos . savedGlobalFlags . pkgEnvSavedConfig $ pkgEnv + case paths of + [] -> die $ "Distribution.Client.Sandbox.getIndexFilePath: " ++ + "no local repos found" + [p] -> return $ p Index.defaultIndexFileName + _ -> die $ "Distribution.Client.Sandbox.getIndexFilePath: " ++ + "too many local repos found" + +-- | Entry point for the 'cabal dump-pkgenv' command. +dumpPackageEnvironment :: Verbosity -> SandboxFlags -> IO () +dumpPackageEnvironment verbosity sandboxFlags = do + pkgEnvDir <- getSandboxLocation verbosity sandboxFlags + + pkgEnv <- tryLoadPackageEnvironment verbosity pkgEnvDir + commentPkgEnv <- commentPackageEnvironment pkgEnvDir + putStrLn . showPackageEnvironmentWithComments commentPkgEnv $ pkgEnv + +-- | Entry point for the 'cabal sandbox-configure' command. +sandboxConfigure :: Verbosity -> SandboxFlags -> ConfigFlags -> ConfigExFlags + -> [String] -> GlobalFlags -> IO () +sandboxConfigure verbosity + sandboxFlags configFlags configExFlags extraArgs globalFlags = do + let sandboxDir' = fromFlagOrDefault defaultSandboxLocation + (sandboxLocation sandboxFlags) + createDirectoryIfMissingVerbose verbosity True sandboxDir' + sandboxDir <- canonicalizePath sandboxDir' + (comp, conf) <- configCompilerSandbox sandboxDir + notice verbosity $ "Using a sandbox located at " ++ sandboxDir + + pkgEnv <- loadOrCreatePackageEnvironment verbosity sandboxDir configFlags comp + + let config = pkgEnvSavedConfig pkgEnv + configFlags' = savedConfigureFlags config `mappend` configFlags + configExFlags' = savedConfigureExFlags config `mappend` configExFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + [Just (SpecificPackageDB dbPath)] + = configPackageDBs configFlags' + + indexFile <- getIndexFilePath pkgEnv + Index.createEmpty verbosity indexFile + packageDBExists <- doesDirectoryExist dbPath + unless packageDBExists $ + Register.initPackageDB verbosity comp conf dbPath + when packageDBExists $ + notice verbosity $ "The package database already exists: " ++ dbPath + configure verbosity + (configPackageDB' configFlags') (globalRepos globalFlags') + comp conf configFlags' configExFlags' extraArgs + where + -- We need to know the compiler version so that the correct package DB is + -- used. We try to read it from the package environment file, which might + -- not exist. + configCompilerSandbox :: FilePath -> IO (Compiler, ProgramConfiguration) + configCompilerSandbox sandboxDir = do + -- Build a ConfigFlags record... + let basePkgEnv = basePackageEnvironment sandboxDir + userConfig <- loadConfig verbosity NoFlag NoFlag + mPkgEnv <- readPackageEnvironmentFile mempty + (sandboxDir defaultPackageEnvironmentFileName) + let pkgEnv = case mPkgEnv of + Just (ParseOk _warns parseResult) -> parseResult + _ -> mempty + let basePkgEnvConfig = pkgEnvSavedConfig basePkgEnv + pkgEnvConfig = pkgEnvSavedConfig pkgEnv + configFlags' = savedConfigureFlags basePkgEnvConfig + `mappend` savedConfigureFlags userConfig + `mappend` savedConfigureFlags pkgEnvConfig + `mappend` configFlags + -- ...and pass it to configCompilerAux. + configCompilerAux configFlags' + +-- | Entry point for the 'cabal sandbox-add-source' command. +sandboxAddSource :: Verbosity -> SandboxFlags -> [FilePath] -> IO () +sandboxAddSource verbosity sandboxFlags buildTreeRefs = do + sandboxDir <- getSandboxLocation verbosity sandboxFlags + pkgEnv <- tryLoadPackageEnvironment verbosity sandboxDir + indexFile <- getIndexFilePath pkgEnv + Index.addBuildTreeRefs verbosity indexFile buildTreeRefs + +-- | Entry point for the 'cabal sandbox-build' command. +sandboxBuild :: Verbosity -> SandboxFlags -> BuildFlags -> [String] -> IO () +sandboxBuild verbosity sandboxFlags buildFlags' extraArgs = do + -- Check that the sandbox exists. + _ <- getSandboxLocation verbosity sandboxFlags + + let setupScriptOptions = defaultSetupScriptOptions { + useDistPref = fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (buildDistPref buildFlags) + } + buildFlags = buildFlags' { + buildVerbosity = toFlag verbosity + } + setupWrapper verbosity setupScriptOptions Nothing + (buildCommand defaultProgramConfiguration) (const buildFlags) extraArgs + +-- | Entry point for the 'cabal sandbox-install' command. +sandboxInstall :: Verbosity -> SandboxFlags -> ConfigFlags -> ConfigExFlags + -> InstallFlags -> HaddockFlags -> [String] -> GlobalFlags + -> IO () +sandboxInstall verbosity _sandboxFlags _configFlags _configExFlags + installFlags _haddockFlags _extraArgs _globalFlags + | fromFlagOrDefault False (installOnly installFlags) + = setupWrapper verbosity defaultSetupScriptOptions Nothing + installCommand (const mempty) [] + +sandboxInstall verbosity sandboxFlags configFlags configExFlags + installFlags haddockFlags extraArgs globalFlags = do + sandboxDir <- getSandboxLocation verbosity sandboxFlags + + pkgEnv <- tryLoadPackageEnvironment verbosity sandboxDir + targets <- readUserTargets verbosity extraArgs + let config = pkgEnvSavedConfig pkgEnv + configFlags' = savedConfigureFlags config `mappend` configFlags + configExFlags' = defaultConfigExFlags `mappend` + savedConfigureExFlags config `mappend` configExFlags + installFlags' = defaultInstallFlags `mappend` + savedInstallFlags config `mappend` installFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux' configFlags' + install verbosity + (configPackageDB' configFlags') (globalRepos globalFlags') + comp conf + globalFlags' configFlags' configExFlags' installFlags' haddockFlags + targets + +configPackageDB' :: ConfigFlags -> PackageDBStack +configPackageDB' cfg = + interpretPackageDbFlags userInstall (configPackageDBs cfg) + where + userInstall = fromFlagOrDefault True (configUserInstall cfg) + +configCompilerAux' :: ConfigFlags + -> IO (Compiler, ProgramConfiguration) +configCompilerAux' configFlags = + configCompilerAux configFlags + --FIXME: make configCompilerAux use a sensible verbosity + { configVerbosity = fmap lessVerbose (configVerbosity configFlags) } diff --git a/cabal/cabal-install/Distribution/Client/Setup.hs b/cabal/cabal-install/Distribution/Client/Setup.hs --- a/cabal/cabal-install/Distribution/Client/Setup.hs +++ b/cabal/cabal-install/Distribution/Client/Setup.hs @@ -15,6 +15,7 @@ , configureCommand, ConfigFlags(..), filterConfigureFlags , configureExCommand, ConfigExFlags(..), defaultConfigExFlags , configureExOptions + , buildCommand, BuildFlags(..) , installCommand, InstallFlags(..), installOptions, defaultInstallFlags , listCommand, ListFlags(..) , updateCommand @@ -26,6 +27,12 @@ , reportCommand, ReportFlags(..) , unpackCommand, UnpackFlags(..) , initCommand, IT.InitFlags(..) + , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) + , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..) + , indexCommand, IndexFlags(..) + , dumpPkgEnvCommand, sandboxConfigureCommand, sandboxAddSourceCommand + , sandboxBuildCommand, sandboxInstallCommand, defaultSandboxLocation + , SandboxFlags(..) , parsePackageArgs --TODO: stop exporting these: @@ -37,6 +44,8 @@ ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) +import Distribution.Client.Dependency.Types + ( PreSolver(..) ) import qualified Distribution.Client.Init.Types as IT ( InitFlags(..), PackageType(..) ) import Distribution.Client.Targets @@ -45,14 +54,14 @@ import Distribution.Simple.Program ( defaultProgramConfiguration ) import Distribution.Simple.Command hiding (boolOpt) -import qualified Distribution.Simple.Command as Command import qualified Distribution.Simple.Setup as Cabal - ( configureCommand ) + ( configureCommand, buildCommand, sdistCommand, haddockCommand + , buildOptions, defaultBuildFlags ) import Distribution.Simple.Setup - ( ConfigFlags(..) ) + ( ConfigFlags(..), BuildFlags(..), SDistFlags(..), HaddockFlags(..) ) import Distribution.Simple.Setup - ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe - , optionVerbosity, trueArg, falseArg ) + ( Flag(..), toFlag, fromFlag, flagToMaybe, flagToList + , optionVerbosity, boolOpt, trueArg, falseArg ) import Distribution.Simple.InstallDirs ( PathTemplate, toPathTemplate, fromPathTemplate ) import Distribution.Version @@ -60,11 +69,11 @@ import Distribution.Package ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) import Distribution.Text - ( Text(parse), display ) + ( Text(..), display ) import Distribution.ReadE ( ReadE(..), readP_to_E, succeedReadE ) import qualified Distribution.Compat.ReadP as Parse - ( ReadP, readP_to_S, char, munch1, pfail, (+++) ) + ( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, (+++) ) import Distribution.Verbosity ( Verbosity, normal ) import Distribution.Simple.Utils @@ -72,6 +81,8 @@ import Data.Char ( isSpace, isAlphaNum ) +import Data.List + ( intercalate ) import Data.Maybe ( listToMaybe, maybeToList, fromMaybe ) import Data.Monoid @@ -224,7 +235,6 @@ -- older Cabal does not grok the constraints flag: | otherwise = flags { configConstraints = [] } - -- ------------------------------------------------------------ -- * Config extra flags -- ------------------------------------------------------------ @@ -234,11 +244,12 @@ data ConfigExFlags = ConfigExFlags { configCabalVersion :: Flag Version, configExConstraints:: [UserConstraint], - configPreferences :: [Dependency] + configPreferences :: [Dependency], + configSolver :: Flag PreSolver } defaultConfigExFlags :: ConfigExFlags -defaultConfigExFlags = mempty +defaultConfigExFlags = mempty { configSolver = Flag defaultSolver } configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) configureExCommand = configureCommand { @@ -275,22 +286,35 @@ (readP_to_E (const "dependency expected") (fmap (\x -> [x]) parse)) (map display)) + + , optionSolver configSolver (\v flags -> flags { configSolver = v }) ] instance Monoid ConfigExFlags where mempty = ConfigExFlags { configCabalVersion = mempty, configExConstraints= mempty, - configPreferences = mempty + configPreferences = mempty, + configSolver = mempty } mappend a b = ConfigExFlags { configCabalVersion = combine configCabalVersion, configExConstraints= combine configExConstraints, - configPreferences = combine configPreferences + configPreferences = combine configPreferences, + configSolver = combine configSolver } where combine field = field a `mappend` field b -- ------------------------------------------------------------ +-- * Build flags +-- ------------------------------------------------------------ + +buildCommand :: CommandUI BuildFlags +buildCommand = (Cabal.buildCommand defaultProgramConfiguration) { + commandDefaultFlags = mempty + } + +-- ------------------------------------------------------------ -- * Fetch command -- ------------------------------------------------------------ @@ -298,6 +322,11 @@ -- fetchOutput :: Flag FilePath, fetchDeps :: Flag Bool, fetchDryRun :: Flag Bool, + fetchSolver :: Flag PreSolver, + fetchMaxBackjumps :: Flag Int, + fetchReorderGoals :: Flag Bool, + fetchIndependentGoals :: Flag Bool, + fetchShadowPkgs :: Flag Bool, fetchVerbosity :: Flag Verbosity } @@ -306,6 +335,11 @@ -- fetchOutput = mempty, fetchDeps = toFlag True, fetchDryRun = toFlag False, + fetchSolver = Flag defaultSolver, + fetchMaxBackjumps = Flag defaultMaxBackjumps, + fetchReorderGoals = Flag False, + fetchIndependentGoals = Flag False, + fetchShadowPkgs = Flag False, fetchVerbosity = toFlag normal } @@ -316,7 +350,7 @@ commandDescription = Nothing, commandUsage = usagePackages "fetch", commandDefaultFlags = defaultFetchFlags, - commandOptions = \_ -> [ + commandOptions = \ showOrParseArgs -> [ optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v }) -- , option "o" ["output"] @@ -338,7 +372,16 @@ "Do not install anything, only print what would be installed." fetchDryRun (\v flags -> flags { fetchDryRun = v }) trueArg - ] + + ] ++ + + optionSolver fetchSolver (\v flags -> flags { fetchSolver = v }) : + optionSolverFlags showOrParseArgs + fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v }) + fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v }) + fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) + fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v }) + } -- ------------------------------------------------------------ @@ -355,13 +398,13 @@ commandOptions = \_ -> [optionVerbosity id const] } -upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags) +upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) upgradeCommand = configureCommand { commandName = "upgrade", commandSynopsis = "(command disabled, use install instead)", commandDescription = Nothing, commandUsage = usagePackages "upgrade", - commandDefaultFlags = (mempty, mempty, mempty), + commandDefaultFlags = (mempty, mempty, mempty, mempty), commandOptions = commandOptions installCommand } @@ -570,41 +613,64 @@ -- | Install takes the same flags as configure along with a few extras. -- data InstallFlags = InstallFlags { - installDocumentation:: Flag Bool, - installHaddockIndex :: Flag PathTemplate, - installDryRun :: Flag Bool, - installReinstall :: Flag Bool, - installUpgradeDeps :: Flag Bool, - installOnly :: Flag Bool, - installOnlyDeps :: Flag Bool, - installRootCmd :: Flag String, - installSummaryFile :: [PathTemplate], - installLogFile :: Flag PathTemplate, - installBuildReports :: Flag ReportLevel, - installSymlinkBinDir:: Flag FilePath, - installOneShot :: Flag Bool + installDocumentation :: Flag Bool, + installHaddockIndex :: Flag PathTemplate, + installDryRun :: Flag Bool, + installMaxBackjumps :: Flag Int, + installReorderGoals :: Flag Bool, + installIndependentGoals :: Flag Bool, + installShadowPkgs :: Flag Bool, + installReinstall :: Flag Bool, + installAvoidReinstalls :: Flag Bool, + installOverrideReinstall :: Flag Bool, + installUpgradeDeps :: Flag Bool, + installOnly :: Flag Bool, + installOnlyDeps :: Flag Bool, + installRootCmd :: Flag String, + installSummaryFile :: [PathTemplate], + installLogFile :: Flag PathTemplate, + installBuildReports :: Flag ReportLevel, + installSymlinkBinDir :: Flag FilePath, + installOneShot :: Flag Bool, + installNumJobs :: Flag (Maybe Int) } defaultInstallFlags :: InstallFlags defaultInstallFlags = InstallFlags { - installDocumentation= Flag False, - installHaddockIndex = Flag docIndexFile, - installDryRun = Flag False, - installReinstall = Flag False, - installUpgradeDeps = Flag False, - installOnly = Flag False, - installOnlyDeps = Flag False, - installRootCmd = mempty, - installSummaryFile = mempty, - installLogFile = mempty, - installBuildReports = Flag NoReports, - installSymlinkBinDir= mempty, - installOneShot = Flag False + installDocumentation = Flag False, + installHaddockIndex = Flag docIndexFile, + installDryRun = Flag False, + installMaxBackjumps = Flag defaultMaxBackjumps, + installReorderGoals = Flag False, + installIndependentGoals= Flag False, + installShadowPkgs = Flag False, + installReinstall = Flag False, + installAvoidReinstalls = Flag False, + installOverrideReinstall = Flag False, + installUpgradeDeps = Flag False, + installOnly = Flag False, + installOnlyDeps = Flag False, + installRootCmd = mempty, + installSummaryFile = mempty, + installLogFile = mempty, + installBuildReports = Flag NoReports, + installSymlinkBinDir = mempty, + installOneShot = Flag False, + installNumJobs = mempty } where docIndexFile = toPathTemplate ("$datadir" "doc" "index.html") -installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags) +defaultMaxBackjumps :: Int +defaultMaxBackjumps = 200 + +defaultSolver :: PreSolver +defaultSolver = Choose + +allSolvers :: String +allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [PreSolver])) + +installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) installCommand = CommandUI { commandName = "install", commandSynopsis = "Installs a list of packages.", @@ -623,18 +689,39 @@ ++ " Specific version of a package\n" ++ " " ++ pname ++ " install 'foo < 2' " ++ " Constrained package version\n", - commandDefaultFlags = (mempty, mempty, mempty), + commandDefaultFlags = (mempty, mempty, mempty, mempty), commandOptions = \showOrParseArgs -> liftOptions get1 set1 (filter ((/="constraint") . optionName) $ configureOptions showOrParseArgs) ++ liftOptions get2 set2 (configureExOptions showOrParseArgs) ++ liftOptions get3 set3 (installOptions showOrParseArgs) + ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) } where - get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c) - get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c) - get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) + get1 (a,_,_,_) = a; set1 a (_,b,c,d) = (a,b,c,d) + get2 (_,b,_,_) = b; set2 b (a,_,c,d) = (a,b,c,d) + get3 (_,_,c,_) = c; set3 c (a,b,_,d) = (a,b,c,d) + get4 (_,_,_,d) = d; set4 d (a,b,c,_) = (a,b,c,d) +haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] +haddockOptions showOrParseArgs + = [ opt { optionName = "haddock-" ++ name, + optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr + | 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"] + ] + where + fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a + fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w + fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w + fmapOptFlags modify (ChoiceOpt xs) = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs] + fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w + installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] installOptions showOrParseArgs = [ option "" ["documentation"] @@ -652,23 +739,38 @@ "Do not install anything, only print what would be installed." installDryRun (\v flags -> flags { installDryRun = v }) trueArg + ] ++ - , option [] ["reinstall"] + optionSolverFlags showOrParseArgs + installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v }) + installReorderGoals (\v flags -> flags { installReorderGoals = v }) + installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) + installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) ++ + + [ option [] ["reinstall"] "Install even if it means installing the same version again." installReinstall (\v flags -> flags { installReinstall = v }) - trueArg + (yesNoOpt showOrParseArgs) + , option [] ["avoid-reinstalls"] + "Do not select versions that would destructively overwrite installed packages." + installAvoidReinstalls (\v flags -> flags { installAvoidReinstalls = v }) + (yesNoOpt showOrParseArgs) + + , option [] ["force-reinstalls"] + "Reinstall packages even if they will most likely break other installed packages." + installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v }) + (yesNoOpt showOrParseArgs) + , option [] ["upgrade-dependencies"] "Pick the latest version for all dependencies, rather than trying to pick an installed version." installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v }) - trueArg - + (yesNoOpt showOrParseArgs) , option [] ["only-dependencies"] "Install only the dependencies necessary to build the given packages" installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) - trueArg - + (yesNoOpt showOrParseArgs) , option [] ["root-cmd"] "Command used to gain root privileges, when installing with --global." @@ -702,7 +804,16 @@ , option [] ["one-shot"] "Do not record the packages in the world file." installOneShot (\v flags -> flags { installOneShot = v }) - trueArg + (yesNoOpt showOrParseArgs) + + , option "j" ["jobs"] + "Run NUM jobs simultaneously." + installNumJobs (\v flags -> flags { installNumJobs = v }) + (optArg "NUM" (readP_to_E (\_ -> "jobs should be a number") + (fmap (toFlag . Just) + (Parse.readS_to_P reads))) + (Flag Nothing) + (map (fmap show) . flagToList)) ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" avoids ParseArgs -> option [] ["only"] @@ -714,34 +825,48 @@ instance Monoid InstallFlags where mempty = InstallFlags { - installDocumentation= mempty, - installHaddockIndex = mempty, - installDryRun = mempty, - installReinstall = mempty, - installUpgradeDeps = mempty, - installOnly = mempty, - installOnlyDeps = mempty, - installRootCmd = mempty, - installSummaryFile = mempty, - installLogFile = mempty, - installBuildReports = mempty, - installSymlinkBinDir= mempty, - installOneShot = mempty + installDocumentation = mempty, + installHaddockIndex = mempty, + installDryRun = mempty, + installReinstall = mempty, + installAvoidReinstalls = mempty, + installOverrideReinstall = mempty, + installMaxBackjumps = mempty, + installUpgradeDeps = mempty, + installReorderGoals = mempty, + installIndependentGoals= mempty, + installShadowPkgs = mempty, + installOnly = mempty, + installOnlyDeps = mempty, + installRootCmd = mempty, + installSummaryFile = mempty, + installLogFile = mempty, + installBuildReports = mempty, + installSymlinkBinDir = mempty, + installOneShot = mempty, + installNumJobs = mempty } mappend a b = InstallFlags { - installDocumentation= combine installDocumentation, - installHaddockIndex = combine installHaddockIndex, - installDryRun = combine installDryRun, - installReinstall = combine installReinstall, - installUpgradeDeps = combine installUpgradeDeps, - installOnly = combine installOnly, - installOnlyDeps = combine installOnlyDeps, - installRootCmd = combine installRootCmd, - installSummaryFile = combine installSummaryFile, - installLogFile = combine installLogFile, - installBuildReports = combine installBuildReports, - installSymlinkBinDir= combine installSymlinkBinDir, - installOneShot = combine installOneShot + installDocumentation = combine installDocumentation, + installHaddockIndex = combine installHaddockIndex, + installDryRun = combine installDryRun, + installReinstall = combine installReinstall, + installAvoidReinstalls = combine installAvoidReinstalls, + installOverrideReinstall = combine installOverrideReinstall, + installMaxBackjumps = combine installMaxBackjumps, + installUpgradeDeps = combine installUpgradeDeps, + installReorderGoals = combine installReorderGoals, + installIndependentGoals= combine installIndependentGoals, + installShadowPkgs = combine installShadowPkgs, + installOnly = combine installOnly, + installOnlyDeps = combine installOnlyDeps, + installRootCmd = combine installRootCmd, + installSummaryFile = combine installSummaryFile, + installLogFile = combine installLogFile, + installBuildReports = combine installBuildReports, + installSymlinkBinDir = combine installSymlinkBinDir, + installOneShot = combine installOneShot, + installNumJobs = combine installNumJobs } where combine field = field a `mappend` field b @@ -819,7 +944,7 @@ emptyInitFlags = mempty defaultInitFlags :: IT.InitFlags -defaultInitFlags = emptyInitFlags +defaultInitFlags = emptyInitFlags { IT.initVerbosity = toFlag normal } initCommand :: CommandUI IT.InitFlags initCommand = CommandUI { @@ -859,6 +984,11 @@ IT.minimal (\v flags -> flags { IT.minimal = v }) trueArg + , option [] ["overwrite"] + "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning." + IT.overwrite (\v flags -> flags { IT.overwrite = v }) + trueArg + , option [] ["package-dir"] "Root directory of the package (default = current directory)." IT.packageDir (\v flags -> flags { IT.packageDir = v }) @@ -927,6 +1057,14 @@ (\v flags -> flags { IT.packageType = v }) (noArg (Flag IT.Executable)) + , option [] ["language"] + "Specify the default language." + IT.language + (\v flags -> flags { IT.language = v }) + (reqArg "LANGUAGE" (readP_to_E ("Cannot parse language: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) + , option ['o'] ["expose-module"] "Export a module from the package." IT.exposedModules @@ -953,6 +1091,8 @@ IT.buildTools (\v flags -> flags { IT.buildTools = v }) (reqArg' "TOOL" (Just . (:[])) (fromMaybe [])) + + , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v }) ] } where readMaybe s = case reads s of @@ -960,24 +1100,353 @@ _ -> Nothing -- ------------------------------------------------------------ --- * GetOpt Utils +-- * SDist flags -- ------------------------------------------------------------ -boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -boolOpt = Command.boolOpt flagToMaybe Flag +-- | Extra flags to @sdist@ beyond runghc Setup sdist +-- +data SDistExFlags = SDistExFlags { + sDistFormat :: Flag ArchiveFormat + } + deriving Show -reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> - (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b +data ArchiveFormat = TargzFormat | ZipFormat -- | ... + deriving (Show, Eq) + +defaultSDistExFlags :: SDistExFlags +defaultSDistExFlags = SDistExFlags { + sDistFormat = Flag TargzFormat + } + +sdistCommand :: CommandUI (SDistFlags, SDistExFlags) +sdistCommand = Cabal.sdistCommand { + commandDefaultFlags = (commandDefaultFlags Cabal.sdistCommand, defaultSDistExFlags), + commandOptions = \showOrParseArgs -> + liftOptions fst setFst (commandOptions Cabal.sdistCommand showOrParseArgs) + ++ liftOptions snd setSnd sdistExOptions + } + where + setFst a (_,b) = (a,b) + setSnd b (a,_) = (a,b) + + sdistExOptions = + [option [] ["archive-format"] "archive-format" + sDistFormat (\v flags -> flags { sDistFormat = v }) + (choiceOpt + [ (Flag TargzFormat, ([], ["targz"]), + "Produce a '.tar.gz' format archive (default and required for uploading to hackage)") + , (Flag ZipFormat, ([], ["zip"]), + "Produce a '.zip' format archive") + ]) + ] + +instance Monoid SDistExFlags where + mempty = SDistExFlags { + sDistFormat = mempty + } + mappend a b = SDistExFlags { + sDistFormat = combine sDistFormat + } + where + combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Win32SelfUpgrade flags +-- ------------------------------------------------------------ + +data Win32SelfUpgradeFlags = Win32SelfUpgradeFlags { + win32SelfUpgradeVerbosity :: Flag Verbosity +} + +defaultWin32SelfUpgradeFlags :: Win32SelfUpgradeFlags +defaultWin32SelfUpgradeFlags = Win32SelfUpgradeFlags { + win32SelfUpgradeVerbosity = toFlag normal +} + +win32SelfUpgradeCommand :: CommandUI Win32SelfUpgradeFlags +win32SelfUpgradeCommand = CommandUI { + commandName = "win32selfupgrade", + commandSynopsis = "Self-upgrade the executable on Windows", + commandDescription = Nothing, + commandUsage = \pname -> + "Usage: " ++ pname ++ " win32selfupgrade PID PATH\n\n" + ++ "Flags for win32selfupgrade:", + commandDefaultFlags = defaultWin32SelfUpgradeFlags, + commandOptions = \_ -> + [optionVerbosity win32SelfUpgradeVerbosity + (\v flags -> flags { win32SelfUpgradeVerbosity = v}) + ] +} + +instance Monoid Win32SelfUpgradeFlags where + mempty = defaultWin32SelfUpgradeFlags + mappend a b = Win32SelfUpgradeFlags { + win32SelfUpgradeVerbosity = combine win32SelfUpgradeVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Index flags +-- ------------------------------------------------------------ + +data IndexFlags = IndexFlags { + indexInit :: Flag Bool, + indexList :: Flag Bool, + indexLinkSource :: [FilePath], + indexRemoveSource :: [String], + indexVerbosity :: Flag Verbosity +} + +defaultIndexFlags :: IndexFlags +defaultIndexFlags = IndexFlags { + indexInit = mempty, + indexList = mempty, + indexLinkSource = [], + indexRemoveSource = [], + indexVerbosity = toFlag normal +} + +indexCommand :: CommandUI IndexFlags +indexCommand = CommandUI { + commandName = "index", + commandSynopsis = "Query and modify the index file", + commandDescription = Nothing, + commandUsage = \pname -> + "Usage: " ++ pname ++ " index FLAGS PATH\n\n" + ++ "Flags for index:", + commandDefaultFlags = defaultIndexFlags, + commandOptions = \_ -> + [optionVerbosity indexVerbosity + (\v flags -> flags { indexVerbosity = v}) + + ,option [] ["init"] + "Create the index" + indexInit (\v flags -> flags { indexInit = v }) + trueArg + + ,option [] ["link-source"] + "Add a reference to a local build tree to the index" + indexLinkSource (\v flags -> flags { indexLinkSource = v }) + (reqArg' "PATH" (\x -> [x]) id) + + ,option [] ["remove-source"] + "Remove a reference to a local build tree from the index" + indexRemoveSource (\v flags -> flags { indexRemoveSource = v }) + (reqArg' "PATH" (\x -> [x]) id) + + ,option [] ["list"] + "List the local build trees that are referred to from the index" + indexList (\v flags -> flags { indexList = v }) + trueArg + ] +} + +instance Monoid IndexFlags where + mempty = IndexFlags { + indexInit = mempty, + indexList = mempty, + indexLinkSource = mempty, + indexRemoveSource = mempty, + indexVerbosity = mempty + } + mappend a b = IndexFlags { + indexInit = combine indexInit, + indexList = combine indexList, + indexLinkSource = combine indexLinkSource, + indexRemoveSource = combine indexRemoveSource, + indexVerbosity = combine indexVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Sandbox-related flags +-- ------------------------------------------------------------ + +data SandboxFlags = SandboxFlags { + sandboxVerbosity :: Flag Verbosity, + sandboxLocation :: Flag FilePath +} + +defaultSandboxLocation :: FilePath +defaultSandboxLocation = ".cabal-sandbox" + +defaultSandboxFlags :: SandboxFlags +defaultSandboxFlags = SandboxFlags { + sandboxVerbosity = toFlag normal, + sandboxLocation = toFlag defaultSandboxLocation + } + +commonSandboxOptions :: ShowOrParseArgs -> [OptionField SandboxFlags] +commonSandboxOptions _showOrParseArgs = + [ optionVerbosity sandboxVerbosity (\v flags -> flags { sandboxVerbosity = v }) + + , option [] ["sandbox"] + "Sandbox location (default: './.cabal-sandbox')." + sandboxLocation (\v flags -> flags { sandboxLocation = v }) + (reqArgFlag "DIR") + ] + +sandboxConfigureCommand :: CommandUI (SandboxFlags, ConfigFlags, ConfigExFlags) +sandboxConfigureCommand = CommandUI { + commandName = "sandbox-configure", + commandSynopsis = "Configure a package inside a sandbox", + commandDescription = Nothing, + commandUsage = \pname -> usageFlags pname "sandbox-configure", + commandDefaultFlags = (defaultSandboxFlags, mempty, defaultConfigExFlags), + commandOptions = \showOrParseArgs -> + liftOptions get1 set1 (commonSandboxOptions showOrParseArgs) + ++ liftOptions get2 set2 + (filter ((\n -> n /= "constraint" && n /= "verbose") . optionName) $ + configureOptions showOrParseArgs) + ++ liftOptions get3 set3 (configureExOptions showOrParseArgs) + + } + where + get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c) + get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c) + get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) + +sandboxAddSourceCommand :: CommandUI SandboxFlags +sandboxAddSourceCommand = CommandUI { + commandName = "sandbox-add-source", + commandSynopsis = "Make a source package available in a sandbox", + commandDescription = Nothing, + commandUsage = \pname -> usageFlags pname "sandbox-add-source", + commandDefaultFlags = defaultSandboxFlags, + commandOptions = commonSandboxOptions + } + +sandboxBuildCommand :: CommandUI (SandboxFlags, BuildFlags) +sandboxBuildCommand = CommandUI { + commandName = "sandbox-build", + commandSynopsis = "Build a package inside a sandbox", + commandDescription = Nothing, + commandUsage = \pname -> usageFlags pname "sandbox-build", + commandDefaultFlags = (defaultSandboxFlags, Cabal.defaultBuildFlags), + commandOptions = \showOrParseArgs -> + liftOptions fst setFst (commonSandboxOptions showOrParseArgs) + ++ liftOptions snd setSnd (filter ((/= "verbose") . optionName) $ + Cabal.buildOptions progConf showOrParseArgs) + } + where + progConf = defaultProgramConfiguration + + setFst a (_,b) = (a,b) + setSnd b (a,_) = (a,b) + +sandboxInstallCommand :: CommandUI (SandboxFlags, ConfigFlags, ConfigExFlags, + InstallFlags, HaddockFlags) +sandboxInstallCommand = CommandUI { + commandName = "sandbox-install", + commandSynopsis = "Install a list of packages into a sandbox", + commandDescription = commandDescription installCommand, + commandUsage = \pname -> usagePackages pname "sandbox-install", + commandDefaultFlags = (defaultSandboxFlags, mempty, mempty, mempty, mempty), + commandOptions = \showOrParseArgs -> + liftOptions get1 set1 (commonSandboxOptions showOrParseArgs) + ++ liftOptions get2 set2 + (filter ((\n -> n /= "constraint" && n /= "verbose") . optionName) $ + configureOptions showOrParseArgs) + ++ liftOptions get3 set3 (configureExOptions showOrParseArgs) + ++ liftOptions get4 set4 (installOptions showOrParseArgs) + ++ liftOptions get5 set5 (haddockOptions showOrParseArgs) + } + where + get1 (a,_,_,_,_) = a; set1 a (_,b,c,d,e) = (a,b,c,d,e) + get2 (_,b,_,_,_) = b; set2 b (a,_,c,d,e) = (a,b,c,d,e) + get3 (_,_,c,_,_) = c; set3 c (a,b,_,d,e) = (a,b,c,d,e) + get4 (_,_,_,d,_) = d; set4 d (a,b,c,_,e) = (a,b,c,d,e) + get5 (_,_,_,_,e) = e; set5 e (a,b,c,d,_) = (a,b,c,d,e) + +dumpPkgEnvCommand :: CommandUI SandboxFlags +dumpPkgEnvCommand = CommandUI { + commandName = "dump-pkgenv", + commandSynopsis = "Dump a parsed package environment file", + commandDescription = Nothing, + commandUsage = \pname -> usageFlags pname "dump-pkgenv", + commandDefaultFlags = defaultSandboxFlags, + commandOptions = commonSandboxOptions + } + +instance Monoid SandboxFlags where + mempty = SandboxFlags { + sandboxVerbosity = mempty, + sandboxLocation = mempty + } + mappend a b = SandboxFlags { + sandboxVerbosity = combine sandboxVerbosity, + sandboxLocation = combine sandboxLocation + } + where combine field = field a `mappend` field b + + +-- ------------------------------------------------------------ +-- * GetOpt Utils +-- ------------------------------------------------------------ + +reqArgFlag :: ArgPlaceHolder -> + MkOptDescr (b -> Flag String) (Flag String -> b -> b) b reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList liftOptions :: (b -> a) -> (a -> b -> b) -> [OptionField a] -> [OptionField b] liftOptions get set = map (liftOption get set) +yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> (b -> b)) b +yesNoOpt ShowArgs sf lf = trueArg sf lf +yesNoOpt _ sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf + +optionSolver :: (flags -> Flag PreSolver) + -> (Flag PreSolver -> flags -> flags) + -> OptionField flags +optionSolver get set = + option [] ["solver"] + ("Select dependency solver to use (default: " ++ display defaultSolver ++ "). Choices: " ++ allSolvers ++ ", where 'choose' chooses between 'topdown' and 'modular' based on compiler version.") + get set + (reqArg "SOLVER" (readP_to_E (const $ "solver must be one of: " ++ allSolvers) + (toFlag `fmap` parse)) + (flagToList . fmap display)) + +optionSolverFlags :: ShowOrParseArgs + -> (flags -> Flag Int ) -> (Flag Int -> flags -> flags) + -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags) + -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags) + -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags) + -> [OptionField flags] +optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip setsip = + [ 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 + (reqArg "NUM" (readP_to_E ("Cannot parse number: "++) + (fmap toFlag (Parse.readS_to_P reads))) + (map show . flagToList)) + , option [] ["reorder-goals"] + "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages." + getrg setrg + (yesNoOpt showOrParseArgs) + -- TODO: Disabled for now because it does not work as advertised (yet). +{- + , option [] ["independent-goals"] + "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." + getig setig + (yesNoOpt showOrParseArgs) +-} + , option [] ["shadow-installed-packages"] + "If multiple package instances of the same version are installed, treat all but one as shadowed." + getsip setsip + trueArg + ] + + usagePackages :: String -> String -> String usagePackages name pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" ++ " or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n" + ++ "Flags for " ++ name ++ ":" + +usageFlags :: String -> String -> String +usageFlags name pname = + "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" ++ "Flags for " ++ name ++ ":" --TODO: do we want to allow per-package flags? diff --git a/cabal/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal/cabal-install/Distribution/Client/SetupWrapper.hs --- a/cabal/cabal-install/Distribution/Client/SetupWrapper.hs +++ b/cabal/cabal-install/Distribution/Client/SetupWrapper.hs @@ -20,9 +20,6 @@ defaultSetupScriptOptions, ) where -import Distribution.Client.Types - ( InstalledPackage ) - import qualified Distribution.Make as Make import qualified Distribution.Simple as Simple import Distribution.Version @@ -34,39 +31,48 @@ , packageVersion, Dependency(..) ) import Distribution.PackageDescription ( GenericPackageDescription(packageDescription) - , PackageDescription(..), specVersion, BuildType(..) ) + , PackageDescription(..), specVersion + , BuildType(..), knownBuildTypes ) import Distribution.PackageDescription.Parse ( readPackageDescription ) import Distribution.Simple.Configure ( configCompiler ) import Distribution.Simple.Compiler - ( CompilerFlavor(GHC), Compiler, PackageDB(..), PackageDBStack ) + ( CompilerFlavor(GHC), Compiler, compilerVersion, showCompilerId + , PackageDB(..), PackageDBStack ) import Distribution.Simple.Program ( ProgramConfiguration, emptyProgramConfiguration - , rawSystemProgramConf, ghcProgram ) + , getDbProgramOutput, runDbProgram, ghcProgram ) import Distribution.Simple.BuildPaths ( defaultDistPref, exeExtension ) import Distribution.Simple.Command ( CommandUI(..), commandShowOptions ) import Distribution.Simple.GHC ( ghcVerbosityOptions ) -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.Client.Config + ( defaultCabalDir ) import Distribution.Client.IndexUtils ( getInstalledPackages ) +import Distribution.Client.JobControl + ( Lock, criticalSection ) import Distribution.Simple.Utils ( die, debug, info, cabalVersion, findPackageDesc, comparing - , createDirectoryIfMissingVerbose, rewriteFile ) + , createDirectoryIfMissingVerbose, installExecutableFile + , rewriteFile, intercalate ) import Distribution.Client.Utils ( moreRecentFile, inDir ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity ) +import Distribution.Compat.Exception + ( catchIO ) -import System.Directory ( doesFileExist, getCurrentDirectory ) +import System.Directory ( doesFileExist ) import System.FilePath ( (), (<.>) ) -import System.IO ( Handle ) +import System.IO ( Handle, hPutStr ) import System.Exit ( ExitCode(..), exitWith ) import System.Process ( runProcess, waitForProcess ) import Control.Monad ( when, unless ) @@ -75,26 +81,33 @@ import Data.Char ( isSpace ) data SetupScriptOptions = SetupScriptOptions { - useCabalVersion :: VersionRange, - useCompiler :: Maybe Compiler, - usePackageDB :: PackageDBStack, - usePackageIndex :: Maybe (PackageIndex InstalledPackage), - useProgramConfig :: ProgramConfiguration, - useDistPref :: FilePath, - useLoggingHandle :: Maybe Handle, - useWorkingDir :: Maybe FilePath + useCabalVersion :: VersionRange, + useCompiler :: Maybe Compiler, + usePackageDB :: PackageDBStack, + usePackageIndex :: Maybe PackageIndex, + useProgramConfig :: ProgramConfiguration, + useDistPref :: FilePath, + useLoggingHandle :: Maybe Handle, + useWorkingDir :: Maybe FilePath, + forceExternalSetupMethod :: Bool, + + -- Used only when calling setupWrapper from parallel code to serialise + -- access to the setup cache; should be Nothing otherwise. + setupCacheLock :: Maybe Lock } defaultSetupScriptOptions :: SetupScriptOptions defaultSetupScriptOptions = SetupScriptOptions { - useCabalVersion = anyVersion, - useCompiler = Nothing, - usePackageDB = [GlobalPackageDB, UserPackageDB], - usePackageIndex = Nothing, - useProgramConfig = emptyProgramConfiguration, - useDistPref = defaultDistPref, - useLoggingHandle = Nothing, - useWorkingDir = Nothing + useCabalVersion = anyVersion, + useCompiler = Nothing, + usePackageDB = [GlobalPackageDB, UserPackageDB], + usePackageIndex = Nothing, + useProgramConfig = emptyProgramConfiguration, + useDistPref = defaultDistPref, + useLoggingHandle = Nothing, + useWorkingDir = Nothing, + forceExternalSetupMethod = False, + setupCacheLock = Nothing } setupWrapper :: Verbosity @@ -116,23 +129,30 @@ mkArgs cabalLibVersion = commandName cmd : commandShowOptions cmd (flags cabalLibVersion) ++ extraArgs + checkBuildType buildType' setupMethod verbosity options' (packageId pkg) buildType' mkArgs where getPkg = findPackageDesc (fromMaybe "." (useWorkingDir options)) >>= readPackageDescription verbosity >>= return . packageDescription + checkBuildType (UnknownBuildType name) = + die $ "The build-type '" ++ name ++ "' is not known. Use one of: " + ++ intercalate ", " (map display knownBuildTypes) ++ "." + checkBuildType _ = return () + -- | Decide if we're going to be able to do a direct internal call to the -- entry point in the Cabal library or if we're going to have to compile -- and execute an external Setup.hs script. -- determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod determineSetupMethod options buildType' + | forceExternalSetupMethod options = externalSetupMethod | isJust (useLoggingHandle options) - || buildType' == Custom = externalSetupMethod + || buildType' == Custom = externalSetupMethod | cabalVersion `withinRange` - useCabalVersion options = internalSetupMethod - | otherwise = externalSetupMethod + useCabalVersion options = internalSetupMethod + | otherwise = externalSetupMethod type SetupMethod = Verbosity -> SetupScriptOptions @@ -172,8 +192,10 @@ debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion setupHs <- updateSetupScript cabalLibVersion bt debug verbosity $ "Using " ++ setupHs ++ " as setup script." - compileSetupExecutable options' cabalLibVersion setupHs - invokeSetupScript (mkargs cabalLibVersion) + path <- case bt of + Simple -> getCachedSetupExecutable options' cabalLibVersion setupHs + _ -> compileSetupExecutable options' cabalLibVersion setupHs + invokeSetupScript path (mkargs cabalLibVersion) where workingDir = case fromMaybe "" (useWorkingDir options) of @@ -181,7 +203,6 @@ dir -> dir setupDir = workingDir useDistPref options "setup" setupVersionFile = setupDir "setup" <.> "version" - setupProgFile = setupDir "setup" <.> exeExtension cabalLibVersionToUse :: IO (Version, SetupScriptOptions) cabalLibVersionToUse = do @@ -195,7 +216,7 @@ return (version, options') savedCabalVersion = do - versionString <- readFile setupVersionFile `catch` \_ -> return "" + versionString <- readFile setupVersionFile `catchIO` \_ -> return "" case reads versionString of [(version,s)] | all isSpace s -> return (Just version) _ -> return Nothing @@ -215,7 +236,7 @@ [] -> die $ "The package requires Cabal library version " ++ display (useCabalVersion options) ++ " but no suitable version is installed." - pkgs -> return $ bestVersion (map packageVersion pkgs) + pkgs -> return $ bestVersion (map fst pkgs) where bestVersion = maximumBy (comparing preference) preference version = (sameVersion, sameMajorVersion @@ -269,51 +290,99 @@ Custom -> error "buildTypeScript Custom" UnknownBuildType _ -> error "buildTypeScript UnknownBuildType" + -- | Look up the setup executable in the cache; update the cache if the setup + -- executable is not found. + getCachedSetupExecutable :: SetupScriptOptions -> Version -> FilePath + -> IO FilePath + getCachedSetupExecutable options' cabalLibVersion setupHsFile = do + cabalDir <- defaultCabalDir + let setupCacheDir = cabalDir "setup-exe-cache" + let setupProgFile = setupCacheDir + ("setup-" ++ cabalVersionString ++ "-" + ++ compilerVersionString) + <.> exeExtension + setupProgFileExists <- doesFileExist setupProgFile + if setupProgFileExists + then debug verbosity $ + "Found cached setup executable: " ++ setupProgFile + else criticalSection' $ do + -- The cache may have been populated while we were waiting. + setupProgFileExists' <- doesFileExist setupProgFile + if setupProgFileExists' + then debug verbosity $ + "Found cached setup executable: " ++ setupProgFile + else do + debug verbosity $ "Setup executable not found in the cache." + src <- compileSetupExecutable options' cabalLibVersion setupHsFile + createDirectoryIfMissingVerbose verbosity True setupCacheDir + installExecutableFile verbosity src setupProgFile + return setupProgFile + where + cabalVersionString = "Cabal-" ++ (display cabalLibVersion) + compilerVersionString = fromMaybe "nonexisting-compiler" + (showCompilerId `fmap` useCompiler options') + 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. -- - compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath -> IO () + compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath + -> IO FilePath compileSetupExecutable options' cabalLibVersion setupHsFile = do setupHsNewer <- setupHsFile `moreRecentFile` setupProgFile cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile let outOfDate = setupHsNewer || cabalVersionNewer when outOfDate $ do debug verbosity "Setup script is out of date, compiling..." - (_, conf, _) <- configureCompiler options' + (compiler, conf, _) <- configureCompiler options' --TODO: get Cabal's GHC module to export a GhcOptions type and render func - rawSystemProgramConf verbosity ghcProgram conf $ - ghcVerbosityOptions verbosity - ++ ["--make", setupHsFile, "-o", setupProgFile - ,"-odir", setupDir, "-hidir", setupDir - ,"-i", "-i" ++ workingDir ] - ++ ghcPackageDbOptions (usePackageDB options') - ++ if packageName pkg == PackageName "Cabal" - then [] - else ["-package", display cabalPkgid] + let ghcCmdLine = + ghcVerbosityOptions verbosity + ++ ["--make", setupHsFile, "-o", setupProgFile + ,"-odir", setupDir, "-hidir", setupDir + ,"-i", "-i" ++ workingDir ] + ++ ghcPackageDbOptions compiler (usePackageDB options') + ++ if packageName pkg == PackageName "Cabal" + then [] + else ["-package", display cabalPkgid] + case useLoggingHandle options of + Nothing -> runDbProgram verbosity ghcProgram conf ghcCmdLine + + -- If build logging is enabled, redirect compiler output to the log file. + (Just logHandle) -> do output <- getDbProgramOutput verbosity ghcProgram + conf ghcCmdLine + hPutStr logHandle output + return setupProgFile where - cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion + setupProgFile = setupDir "setup" <.> exeExtension + cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion - ghcPackageDbOptions :: PackageDBStack -> [String] - ghcPackageDbOptions dbstack = case dbstack of + ghcPackageDbOptions :: Compiler -> PackageDBStack -> [String] + ghcPackageDbOptions compiler dbstack = case dbstack of (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs - (GlobalPackageDB:dbs) -> "-no-user-package-conf" + (GlobalPackageDB:dbs) -> ("-no-user-" ++ packageDbFlag) : concatMap specific dbs _ -> ierror where - specific (SpecificPackageDB db) = [ "-package-conf", db ] + specific (SpecificPackageDB db) = [ '-':packageDbFlag, db ] specific _ = ierror ierror = error "internal error: unexpected package db stack" + packageDbFlag + | compilerVersion compiler < Version [7,5] [] + = "package-conf" + | otherwise + = "package-db" - invokeSetupScript :: [String] -> IO () - invokeSetupScript args = do - info verbosity $ unwords (setupProgFile : args) + invokeSetupScript :: FilePath -> [String] -> IO () + invokeSetupScript path args = do + info verbosity $ unwords (path : args) case useLoggingHandle options of Nothing -> return () Just logHandle -> info verbosity $ "Redirecting build log to " ++ show logHandle - currentDir <- getCurrentDirectory - process <- runProcess (currentDir setupProgFile) args + process <- runProcess path args (useWorkingDir options) Nothing Nothing (useLoggingHandle options) (useLoggingHandle options) exitCode <- waitForProcess process diff --git a/cabal/cabal-install/Distribution/Client/SrcDist.hs b/cabal/cabal-install/Distribution/Client/SrcDist.hs --- a/cabal/cabal-install/Distribution/Client/SrcDist.hs +++ b/cabal/cabal-install/Distribution/Client/SrcDist.hs @@ -4,42 +4,55 @@ module Distribution.Client.SrcDist ( sdist ) where + + import Distribution.Simple.SrcDist - ( printPackageProblems, prepareTree - , prepareSnapshotTree, snapshotPackage ) + ( printPackageProblems, prepareTree, snapshotPackage ) import Distribution.Client.Tar (createTarGzFile) import Distribution.Package - ( Package(..) ) + ( Package(..), packageVersion ) import Distribution.PackageDescription ( PackageDescription ) import Distribution.PackageDescription.Parse ( readPackageDescription ) import Distribution.Simple.Utils - ( defaultPackageDesc, warn, notice, setupMessage - , createDirectoryIfMissingVerbose, withTempDirectory ) -import Distribution.Simple.Setup (SDistFlags(..), fromFlag) + ( defaultPackageDesc, die, warn, notice, setupMessage + , createDirectoryIfMissingVerbose, withTempDirectory + , withUTF8FileContents, writeUTF8File ) +import Distribution.Client.Setup + ( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) ) +import Distribution.Simple.Setup + ( fromFlag, flagToMaybe ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.PreProcess (knownSuffixHandlers) import Distribution.Simple.BuildPaths ( srcPref) import Distribution.Simple.Configure(maybeGetPersistBuildConfig) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) +import Distribution.Simple.Program (requireProgram, simpleProgram, programPath) +import Distribution.Simple.Program.Db (emptyProgramDb) import Distribution.Text ( display ) +import Distribution.Version + ( Version ) import System.Time (getClockTime, toCalendarTime) import System.FilePath ((), (<.>)) -import Control.Monad (when) +import Control.Monad (when, unless) import Data.Maybe (isNothing) +import Data.Char (toLower) +import Data.List (isPrefixOf) +import System.Directory (doesFileExist, removeFile, canonicalizePath) +import System.Process (runProcess, waitForProcess) +import System.Exit (ExitCode(..)) -- |Create a source distribution. -sdist :: SDistFlags -> IO () -sdist flags = do +sdist :: SDistFlags -> SDistExFlags -> IO () +sdist flags exflags = do pkg <- return . flattenPackageDescription =<< readPackageDescription verbosity =<< defaultPackageDesc verbosity mb_lbi <- maybeGetPersistBuildConfig distPref - let tmpTargetDir = srcPref distPref -- do some QA printPackageProblems verbosity pkg @@ -47,34 +60,101 @@ when (isNothing mb_lbi) $ warn verbosity "Cannot run preprocessors. Run 'configure' command first." - createDirectoryIfMissingVerbose verbosity True tmpTargetDir - withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + date <- toCalendarTime =<< getClockTime + let pkg' | snapshot = snapshotPackage date pkg + | otherwise = pkg - date <- toCalendarTime =<< getClockTime - let pkg' | snapshot = snapshotPackage date pkg - | otherwise = pkg - setupMessage verbosity "Building source dist for" (packageId pkg') + case flagToMaybe (sDistDirectory flags) of + Just targetDir -> do + generateSourceDir targetDir pkg' mb_lbi + notice verbosity $ "Source directory created: " ++ targetDir - _ <- if snapshot - then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps - else prepareTree verbosity pkg' mb_lbi distPref tmpDir pps - targzFile <- createArchive verbosity pkg' tmpDir distPref - notice verbosity $ "Source tarball created: " ++ targzFile + Nothing -> do + createDirectoryIfMissingVerbose verbosity True tmpTargetDir + withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + let targetDir = tmpDir tarBallName pkg' + generateSourceDir targetDir pkg' mb_lbi + targzFile <- createArchive verbosity format pkg' tmpDir targetPref + notice verbosity $ "Source tarball created: " ++ targzFile where + generateSourceDir targetDir pkg' mb_lbi = do + + setupMessage verbosity "Building source dist for" (packageId pkg') + prepareTree verbosity pkg' mb_lbi distPref targetDir pps + when snapshot $ + overwriteSnapshotPackageDesc verbosity pkg' targetDir + verbosity = fromFlag (sDistVerbosity flags) snapshot = fromFlag (sDistSnapshot flags) - distPref = fromFlag (sDistDistPref flags) + format = fromFlag (sDistFormat exflags) pps = knownSuffixHandlers + distPref = fromFlag $ sDistDistPref flags + targetPref = distPref + tmpTargetDir = srcPref distPref --- |Create an archive from a tree of source files, and clean up the tree. +tarBallName :: PackageDescription -> String +tarBallName = display . packageId + +overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> FilePath -- ^source tree + -> IO () +overwriteSnapshotPackageDesc verbosity pkg targetDir = do + -- We could just writePackageDescription targetDescFile pkg_descr, + -- but that would lose comments and formatting. + descFile <- defaultPackageDesc verbosity + withUTF8FileContents descFile $ + writeUTF8File (targetDir descFile) + . unlines . map (replaceVersion (packageVersion pkg)) . lines + + where + replaceVersion :: Version -> String -> String + replaceVersion version line + | "version:" `isPrefixOf` map toLower line + = "version: " ++ display version + | otherwise = line + +-- | Create an archive from a tree of source files. +-- createArchive :: Verbosity + -> ArchiveFormat -> PackageDescription -> FilePath -> FilePath -> IO FilePath -createArchive _verbosity pkg tmpDir targetPref = do - let tarBallName = display (packageId pkg) - tarBallFilePath = targetPref tarBallName <.> "tar.gz" - createTarGzFile tarBallFilePath tmpDir tarBallName - return tarBallFilePath +createArchive _verbosity TargzFormat pkg tmpDir targetPref = do + createTarGzFile tarBallFilePath tmpDir (tarBallName pkg) + return tarBallFilePath + where + tarBallFilePath = targetPref tarBallName pkg <.> "tar.gz" + +createArchive verbosity ZipFormat pkg tmpDir targetPref = do + createZipFile verbosity zipFilePath tmpDir (tarBallName pkg) + return zipFilePath + where + zipFilePath = targetPref tarBallName pkg <.> "zip" + +createZipFile :: Verbosity -> FilePath -> FilePath -> FilePath -> IO () +createZipFile verbosity zipfile base dir = do + (zipProg, _) <- requireProgram verbosity zipProgram emptyProgramDb + + -- zip has an annoying habbit 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. + alreadyExists <- doesFileExist zipfile + when alreadyExists $ removeFile zipfile + + -- we call zip with a different CWD, so have to make the path absolute + zipfileAbs <- canonicalizePath zipfile + + --TODO: use runProgramInvocation, but has to be able to set CWD + hnd <- runProcess (programPath zipProg) ["-q", "-r", zipfileAbs, dir] (Just base) + Nothing Nothing Nothing Nothing + exitCode <- waitForProcess hnd + unless (exitCode == ExitSuccess) $ + die $ "Generating the zip file failed " + ++ "(zip returned exit code " ++ show exitCode ++ ")" + where + zipProgram = simpleProgram "zip" diff --git a/cabal/cabal-install/Distribution/Client/Tar.hs b/cabal/cabal-install/Distribution/Client/Tar.hs --- a/cabal/cabal-install/Distribution/Client/Tar.hs +++ b/cabal/cabal-install/Distribution/Client/Tar.hs @@ -21,6 +21,7 @@ -- * Converting between internal and external representation read, write, + writeEntries, -- * Packing and unpacking files to\/from internal representation pack, @@ -38,6 +39,9 @@ DevMinor, TypeCode, Format(..), + buildTreeRefTypeCode, + entrySizeInBlocks, + entrySizeInBytes, -- * Constructing simple entry values simpleEntry, @@ -87,8 +91,7 @@ ( setFileExecutable ) import System.Posix.Types ( FileMode ) -import System.Time - ( ClockTime(..) ) +import Distribution.Compat.Time import System.IO ( IOMode(ReadMode), openBinaryFile, hFileSize ) import System.IO.Unsafe (unsafeInterleaveIO) @@ -119,8 +122,6 @@ -- type FileSize = Int64 --- | The number of seconds since the UNIX epoch -type EpochTime = Int64 type DevMajor = Int type DevMinor = Int type TypeCode = Char @@ -151,11 +152,30 @@ entryFormat :: !Format } +-- | Type code for the local build tree reference entry type. We don't use the +-- symbolic link entry type because it allows only 100 ASCII characters for the +-- path. +buildTreeRefTypeCode :: TypeCode +buildTreeRefTypeCode = 'C' + -- | Native 'FilePath' of the file or directory within the archive. -- entryPath :: Entry -> FilePath entryPath = fromTarPath . entryTarPath +-- | Return the size of an entry in bytes. +entrySizeInBytes :: Entry -> FileSize +entrySizeInBytes = (*512) . fromIntegral . entrySizeInBlocks + +-- | Return the number of blocks in an entry. +entrySizeInBlocks :: Entry -> Int +entrySizeInBlocks entry = 1 + case entryContent entry of + NormalFile _ size -> bytesToBlocks size + OtherEntryType _ _ size -> bytesToBlocks size + _ -> 0 + where + bytesToBlocks s = 1 + ((fromIntegral s - 1) `div` 512) + -- | The content of a tar archive entry, which depends on the type of entry. -- -- Portable archives should contain only 'NormalFile' and 'Directory'. @@ -264,12 +284,12 @@ -- * Tar paths -- --- | The classic tar format allowed just 100 charcters for the file name. The +-- | The classic tar format allowed just 100 characters for the file name. The -- USTAR format extended this with an extra 155 characters, however it uses a -- complex method of splitting the name between the two sections. -- -- Instead of just putting any overflow into the extended area, it uses the --- extended area as a prefix. The agrevating insane bit however is that the +-- extended area as a prefix. The aggravating insane bit however is that the -- prefix (if any) must only contain a directory prefix. That is the split -- between the two areas must be on a directory separator boundary. So there is -- no simple calculation to work out if a file name is too long. Instead we @@ -365,7 +385,7 @@ where n' = n + length c packName' _ _ ok cs = (FilePath.Posix.joinPath ok, cs) --- | The tar format allows just 100 ASCII charcters for the 'SymbolicLink' and +-- | The tar format allows just 100 ASCII characters for the 'SymbolicLink' and -- 'HardLink' entry types. -- newtype LinkTarget = LinkTarget FilePath @@ -657,6 +677,11 @@ write :: [Entry] -> ByteString write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0] +-- | Same as 'write', but for 'Entries'. +writeEntries :: Entries -> ByteString +writeEntries entries = BS.concat $ foldrEntries (\e res -> (putEntry e):res) + [BS.replicate (512*2) 0] error entries + putEntry :: Entry -> ByteString putEntry entry = case entryContent entry of NormalFile content size -> BS.concat [ header, content, padding size ] @@ -669,12 +694,15 @@ putHeader :: Entry -> ByteString putHeader entry = - BS.Char8.pack $ take 148 block - ++ putOct 7 checksum - ++ ' ' : drop 156 block + BS.concat $ [ BS.take 148 block + , BS.Char8.pack $ putOct 7 checksum + , BS.Char8.singleton ' ' + , BS.drop 156 block ] where - block = putHeaderNoChkSum entry - checksum = foldl' (\x y -> x + ord y) 0 block + -- putHeaderNoChkSum returns a String, so we convert it to the final + -- representation before calculating the checksum. + block = BS.Char8.pack . putHeaderNoChkSum $ entry + checksum = BS.Char8.foldl' (\x y -> x + ord y) 0 block putHeaderNoChkSum :: Entry -> String putHeaderNoChkSum Entry { @@ -743,7 +771,7 @@ putString n s = take n s ++ fill (n - length s) '\NUL' --TODO: check integer widths, eg for large file sizes -putOct :: (Integral a, Show a) => FieldWidth -> a -> String +putOct :: (Show a, Integral a) => FieldWidth -> a -> String putOct n x = let octStr = take (n-1) $ showOct x "" in fill (n - length octStr - 1) '0' @@ -896,8 +924,3 @@ ignore ['.'] = True ignore ['.', '.'] = True ignore _ = False - -getModTime :: FilePath -> IO EpochTime -getModTime path = do - (TOD s _) <- getModificationTime path - return $! fromIntegral s diff --git a/cabal/cabal-install/Distribution/Client/Targets.hs b/cabal/cabal-install/Distribution/Client/Targets.hs --- a/cabal/cabal-install/Distribution/Client/Targets.hs +++ b/cabal/cabal-install/Distribution/Client/Targets.hs @@ -49,7 +49,7 @@ , PackageIdentifier(..), packageName, packageVersion , Dependency(Dependency) ) import Distribution.Client.Types - ( SourcePackage(..), PackageLocation(..) ) + ( SourcePackage(..), PackageLocation(..), OptionalStanza(..) ) import Distribution.Client.Dependency.Types ( PackageConstraint(..) ) @@ -673,6 +673,7 @@ | UserConstraintInstalled PackageName | UserConstraintSource PackageName | UserConstraintFlags PackageName FlagAssignment + | UserConstraintStanzas PackageName [OptionalStanza] deriving (Show,Eq) @@ -683,6 +684,7 @@ UserConstraintInstalled name -> PackageConstraintInstalled name UserConstraintSource name -> PackageConstraintSource name UserConstraintFlags name flags -> PackageConstraintFlags name flags + UserConstraintStanzas name stanzas -> PackageConstraintStanzas name stanzas renamePackageConstraint :: PackageName -> PackageConstraint -> PackageConstraint renamePackageConstraint name pc = case pc of @@ -690,6 +692,7 @@ PackageConstraintInstalled _ -> PackageConstraintInstalled name PackageConstraintSource _ -> PackageConstraintSource name PackageConstraintFlags _ flags -> PackageConstraintFlags name flags + PackageConstraintStanzas _ stanzas -> PackageConstraintStanzas name stanzas readUserConstraint :: String -> Either String UserConstraint readUserConstraint str = @@ -713,19 +716,33 @@ dispFlagValue (f, False) = Disp.char '-' <> dispFlagName f dispFlagName (FlagName f) = Disp.text f + disp (UserConstraintStanzas pkgname stanzas) = disp pkgname <+> dispStanzas stanzas + where + dispStanzas = Disp.hsep . map dispStanza + dispStanza TestStanzas = Disp.text "test" + dispStanza BenchStanzas = Disp.text "bench" + parse = parse >>= parseConstraint where + spaces = Parse.satisfy isSpace >> Parse.skipSpaces + parseConstraint pkgname = (parse >>= return . UserConstraintVersion pkgname) - +++ (do Parse.skipSpaces + +++ (do spaces _ <- Parse.string "installed" return (UserConstraintInstalled pkgname)) - +++ (do Parse.skipSpaces + +++ (do spaces _ <- Parse.string "source" return (UserConstraintSource pkgname)) + +++ (do spaces + _ <- Parse.string "test" + return (UserConstraintStanzas pkgname [TestStanzas])) + +++ (do spaces + _ <- Parse.string "bench" + return (UserConstraintStanzas pkgname [BenchStanzas])) <++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname)) - parseFlagAssignment = Parse.many1 (Parse.skipSpaces >> parseFlagValue) + parseFlagAssignment = Parse.many1 (spaces >> parseFlagValue) parseFlagValue = (do Parse.optional (Parse.char '+') f <- parseFlagName diff --git a/cabal/cabal-install/Distribution/Client/Types.hs b/cabal/cabal-install/Distribution/Client/Types.hs --- a/cabal/cabal-install/Distribution/Client/Types.hs +++ b/cabal/cabal-install/Distribution/Client/Types.hs @@ -18,7 +18,10 @@ import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import Distribution.PackageDescription - ( GenericPackageDescription, FlagAssignment ) + ( Benchmark(..), GenericPackageDescription(..), FlagAssignment + , TestSuite(..) ) +import Distribution.PackageDescription.Configuration + ( mapTreeData ) import Distribution.Client.PackageIndex ( PackageIndex ) import Distribution.Version @@ -74,17 +77,18 @@ data ConfiguredPackage = ConfiguredPackage 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 - -- 'PackageDescrption' that you'd get by applying - -- the flag assignment. + -- 'PackageDescription' that you'd get by applying + -- the flag assignment and optional stanzas. deriving Show instance Package ConfiguredPackage where - packageId (ConfiguredPackage pkg _ _) = packageId pkg + packageId (ConfiguredPackage pkg _ _ _) = packageId pkg instance PackageFixedDeps ConfiguredPackage where - depends (ConfiguredPackage _ _ deps) = deps + depends (ConfiguredPackage _ _ _ deps) = deps -- | A package description along with the location of the package sources. @@ -98,6 +102,25 @@ instance Package SourcePackage where packageId = packageInfoId +data OptionalStanza + = TestStanzas + | BenchStanzas + deriving (Eq, Ord, Show) + +enableStanzas + :: [OptionalStanza] + -> GenericPackageDescription + -> GenericPackageDescription +enableStanzas stanzas gpkg = gpkg + { condBenchmarks = flagBenchmarks $ condBenchmarks gpkg + , condTestSuites = flagTests $ condTestSuites gpkg + } + where + enableTest t = t { testEnabled = TestStanzas `elem` stanzas } + enableBenchmark bm = bm { benchmarkEnabled = BenchStanzas `elem` stanzas } + flagBenchmarks = map (\(n, bm) -> (n, mapTreeData enableBenchmark bm)) + flagTests = map (\(n, t) -> (n, mapTreeData enableTest t)) + -- ------------------------------------------------------------ -- * Package locations and repositories -- ------------------------------------------------------------ @@ -156,8 +179,9 @@ | UnpackFailed SomeException | ConfigureFailed SomeException | BuildFailed SomeException + | TestsFailed SomeException | InstallFailed SomeException data BuildSuccess = BuildOk DocsResult TestsResult data DocsResult = DocsNotTried | DocsFailed | DocsOk -data TestsResult = TestsNotTried | TestsFailed | TestsOk +data TestsResult = TestsNotTried | TestsOk diff --git a/cabal/cabal-install/Distribution/Client/Update.hs b/cabal/cabal-install/Distribution/Client/Update.hs --- a/cabal/cabal-install/Distribution/Client/Update.hs +++ b/cabal/cabal-install/Distribution/Client/Update.hs @@ -20,7 +20,7 @@ ( downloadIndex ) import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Client.IndexUtils - ( getSourcePackages ) + ( getSourcePackages, updateRepoIndexCache ) import qualified Paths_cabal_install ( version ) @@ -29,12 +29,11 @@ import Distribution.Version ( anyVersion, withinRange ) import Distribution.Simple.Utils - ( warn, notice, writeFileAtomic ) + ( writeFileAtomic, warn, notice ) import Distribution.Verbosity ( Verbosity ) import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import Distribution.Client.GZipUtils (maybeDecompress) import qualified Data.Map as Map import System.FilePath (dropExtension) @@ -57,9 +56,9 @@ notice verbosity $ "Downloading the latest package list from " ++ remoteRepoName remoteRepo indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo) - writeFileAtomic (dropExtension indexPath) . BS.Char8.unpack - . maybeDecompress + writeFileAtomic (dropExtension indexPath) . maybeDecompress =<< BS.readFile indexPath + updateRepoIndexCache verbosity repo checkForSelfUpgrade :: Verbosity -> [Repo] -> IO () checkForSelfUpgrade verbosity repos = do @@ -79,4 +78,3 @@ notice verbosity $ "Note: there is a new version of cabal-install available.\n" ++ "To upgrade, run: cabal install cabal-install" - diff --git a/cabal/cabal-install/Distribution/Client/Upload.hs b/cabal/cabal-install/Distribution/Client/Upload.hs --- a/cabal/cabal-install/Distribution/Client/Upload.hs +++ b/cabal/cabal-install/Distribution/Client/Upload.hs @@ -4,7 +4,7 @@ module Distribution.Client.Upload (check, upload, report) where import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..)) -import Distribution.Client.HttpUtils (proxy, isOldHackageURI) +import Distribution.Client.HttpUtils (isOldHackageURI, cabalBrowse) import Distribution.Simple.Utils (debug, notice, warn, info) import Distribution.Verbosity (Verbosity) @@ -15,9 +15,8 @@ import qualified Distribution.Client.BuildReports.Upload as BuildReport import Network.Browser - ( BrowserAction, browse, request - , Authority(..), addAuthority, setAuthorityGen - , setOutHandler, setErrHandler, setProxy ) + ( BrowserAction, request + , Authority(..), addAuthority ) import Network.HTTP ( Header(..), HeaderName(..), findHeader , Request(..), RequestMethod(..), Response(..) ) @@ -33,7 +32,7 @@ import System.FilePath ((), takeExtension, takeFileName) import qualified System.FilePath.Posix as FilePath.Posix (combine) import System.Directory -import Control.Monad (forM_) +import Control.Monad (forM_, when) --FIXME: how do we find this path for an arbitrary hackage server? @@ -98,16 +97,19 @@ Left remoteRepo -> do dotCabal <- defaultCabalDir let srcDir = dotCabal "reports" remoteRepoName remoteRepo - contents <- getDirectoryContents srcDir - forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile -> - do inp <- readFile (srcDir logFile) - let (reportStr, buildLog) = read inp :: (String,String) - case BuildReport.parse reportStr of - Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME - Right report' -> - do info verbosity $ "Uploading report for " ++ display (BuildReport.package report') - browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] auth - return () + -- We don't want to bomb out just because we haven't built any packages from this repo yet + srcExists <- doesDirectoryExist srcDir + when srcExists $ do + contents <- getDirectoryContents srcDir + forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile -> + do inp <- readFile (srcDir logFile) + let (reportStr, buildLog) = read inp :: (String,String) + case BuildReport.parse reportStr of + 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)] + return () Right{} -> return () where targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given @@ -122,15 +124,8 @@ -> FilePath -> IO () handlePackage verbosity uri auth path = do req <- mkRequest uri path - p <- proxy verbosity debug verbosity $ "\n" ++ show req - (_,resp) <- browse $ do - setProxy p - setErrHandler (warn verbosity . ("http error: "++)) - setOutHandler (debug verbosity) - auth - setAuthorityGen (\_ _ -> return Nothing) - request req + (_,resp) <- cabalBrowse verbosity auth $ request req debug verbosity $ show resp case rspCode resp of (2,0,0) -> do notice verbosity "Ok" diff --git a/cabal/cabal-install/Distribution/Client/Utils.hs b/cabal/cabal-install/Distribution/Client/Utils.hs --- a/cabal/cabal-install/Distribution/Client/Utils.hs +++ b/cabal/cabal-install/Distribution/Client/Utils.hs @@ -1,12 +1,30 @@ -module Distribution.Client.Utils where +{-# LANGUAGE ForeignFunctionInterface #-} +module Distribution.Client.Utils ( MergeResult(..) + , mergeBy, duplicates, duplicatesBy + , moreRecentFile, inDir, numberOfProcessors + , makeAbsoluteToCwd, filePathToByteString + , byteStringToFilePath) + where + +import qualified Data.ByteString.Lazy as BS +import Data.Bits + ( (.|.), shiftL, shiftR ) +import Data.Char + ( ord, chr ) import Data.List ( sortBy, groupBy ) +import Data.Word + ( Word8, Word32) +import Foreign.C.Types ( CInt(..) ) +import qualified Control.Exception as Exception + ( finally ) import System.Directory ( doesFileExist, getModificationTime , getCurrentDirectory, setCurrentDirectory ) -import qualified Control.Exception as Exception - ( finally ) +import System.FilePath + ( (), isAbsolute ) +import System.IO.Unsafe ( unsafePerformIO ) -- | Generic merging utility. For sorted input lists this is a full outer join. -- @@ -58,3 +76,52 @@ old <- getCurrentDirectory setCurrentDirectory d m `Exception.finally` setCurrentDirectory old + +foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt + +-- The number of processors is not going to change during the duration of the +-- program, so unsafePerformIO is safe here. +numberOfProcessors :: Int +numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors + +-- | Given a relative path, make it absolute relative to the current +-- directory. Absolute paths are returned unmodified. +makeAbsoluteToCwd :: FilePath -> IO FilePath +makeAbsoluteToCwd path | isAbsolute path = return path + | otherwise = do cwd <- getCurrentDirectory + return $! cwd path + +-- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is +-- encoded as a little-endian 'Word32'. +filePathToByteString :: FilePath -> BS.ByteString +filePathToByteString p = + BS.pack $ foldr conv [] codepts + where + codepts :: [Word32] + codepts = map (fromIntegral . ord) p + + conv :: Word32 -> [Word8] -> [Word8] + conv w32 rest = b0:b1:b2:b3:rest + where + b0 = fromIntegral $ w32 + b1 = fromIntegral $ w32 `shiftR` 8 + b2 = fromIntegral $ w32 `shiftR` 16 + b3 = fromIntegral $ w32 `shiftR` 24 + +-- | Reverse operation to 'filePathToByteString'. +byteStringToFilePath :: BS.ByteString -> FilePath +byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected + | otherwise = go 0 + where + unexpected = "Distribution.Client.Utils.byteStringToFilePath: unexpected" + bslen = BS.length bs + + go i | i == bslen = [] + | otherwise = (chr . fromIntegral $ w32) : go (i+4) + where + w32 :: Word32 + w32 = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24) + b0 = fromIntegral $ BS.index bs i + b1 = fromIntegral $ BS.index bs (i + 1) + b2 = fromIntegral $ BS.index bs (i + 2) + b3 = fromIntegral $ BS.index bs (i + 3) diff --git a/cabal/cabal-install/Distribution/Client/World.hs b/cabal/cabal-install/Distribution/Client/World.hs --- a/cabal/cabal-install/Distribution/Client/World.hs +++ b/cabal/cabal-install/Distribution/Client/World.hs @@ -40,6 +40,7 @@ import Distribution.Text ( Text(..), display, simpleParse ) import qualified Distribution.Compat.ReadP as Parse +import Distribution.Compat.Exception ( catchIO ) import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ( (<>), (<+>) ) @@ -101,7 +102,7 @@ all (`elem` pkgsNewWorld) pkgsOldWorld) then do info verbosity "Updating world file..." - writeFileAtomic world $ unlines + writeFileAtomic world . B.pack $ unlines [ (display pkg) | pkg <- pkgsNewWorld] else info verbosity "World file is already up to date." @@ -117,7 +118,7 @@ else die "Could not parse world file." where safelyReadFile :: FilePath -> IO B.ByteString - safelyReadFile file = B.readFile file `catch` handler + safelyReadFile file = B.readFile file `catchIO` handler where handler e | isDoesNotExistError e = return B.empty | otherwise = ioError e diff --git a/cabal/cabal-install/Distribution/Compat/Time.hs b/cabal/cabal-install/Distribution/Compat/Time.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Compat/Time.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +module Distribution.Compat.Time where + +import Data.Int (Int64) +import System.Directory (getModificationTime) + +#if MIN_VERSION_directory(1,2,0) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixDayLength) +import Data.Time (getCurrentTime, diffUTCTime) +#else +import System.Time (ClockTime(..), getClockTime, diffClockTimes, normalizeTimeDiff, tdDay) +#endif + +-- | The number of seconds since the UNIX epoch +type EpochTime = Int64 + +getModTime :: FilePath -> IO EpochTime +getModTime path = do +#if MIN_VERSION_directory(1,2,0) + (truncate . utcTimeToPOSIXSeconds) `fmap` getModificationTime path +#else + (TOD s _) <- getModificationTime path + return $! fromIntegral s +#endif + +-- | Return age of given file in days. +getFileAge :: FilePath -> IO Int +getFileAge file = do + t0 <- getModificationTime file +#if MIN_VERSION_directory(1,2,0) + t1 <- getCurrentTime + let days = truncate $ (t1 `diffUTCTime` t0) / posixDayLength +#else + t1 <- getClockTime + let days = (tdDay . normalizeTimeDiff) (t1 `diffClockTimes` t0) +#endif + return days diff --git a/cabal/cabal-install/Main.hs b/cabal/cabal-install/Main.hs --- a/cabal/cabal-install/Main.hs +++ b/cabal/cabal-install/Main.hs @@ -16,7 +16,8 @@ import Distribution.Client.Setup ( GlobalFlags(..), globalCommand, globalRepos , ConfigFlags(..) - , ConfigExFlags(..), configureExCommand + , ConfigExFlags(..), defaultConfigExFlags, configureExCommand + , BuildFlags(..), buildCommand , InstallFlags(..), defaultInstallFlags , installCommand, upgradeCommand , FetchFlags(..), fetchCommand @@ -26,19 +27,24 @@ , InfoFlags(..), infoCommand , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand - , InitFlags, initCommand + , InitFlags(initVerbosity), initCommand + , SDistFlags(..), SDistExFlags(..), sdistCommand + , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand + , IndexFlags(..), indexCommand + , SandboxFlags(..), sandboxAddSourceCommand + , sandboxConfigureCommand, sandboxBuildCommand, sandboxInstallCommand + , dumpPkgEnvCommand , reportCommand , unpackCommand, UnpackFlags(..) ) import Distribution.Simple.Setup - ( BuildFlags(..), buildCommand - , HaddockFlags(..), haddockCommand + ( HaddockFlags(..), haddockCommand , HscolourFlags(..), hscolourCommand , CopyFlags(..), copyCommand , RegisterFlags(..), registerCommand , CleanFlags(..), cleanCommand - , SDistFlags(..), sdistCommand , TestFlags(..), testCommand - , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) + , BenchmarkFlags(..), benchmarkCommand + , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag ) import Distribution.Client.SetupWrapper ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) @@ -47,31 +53,39 @@ import Distribution.Client.Targets ( readUserTargets ) -import Distribution.Client.List (list, info) -import Distribution.Client.Install (install, upgrade) -import Distribution.Client.Configure (configure) -import Distribution.Client.Update (update) -import Distribution.Client.Fetch (fetch) -import Distribution.Client.Check as Check (check) +import Distribution.Client.List (list, info) +import Distribution.Client.Install (install, upgrade) +import Distribution.Client.Configure (configure) +import Distribution.Client.Update (update) +import Distribution.Client.Fetch (fetch) +import Distribution.Client.Check as Check (check) --import Distribution.Client.Clean (clean) -import Distribution.Client.Upload as Upload (upload, check, report) -import Distribution.Client.SrcDist (sdist) -import Distribution.Client.Unpack (unpack) -import Distribution.Client.Init (initCabal) +import Distribution.Client.Upload as Upload (upload, check, report) +import Distribution.Client.SrcDist (sdist) +import Distribution.Client.Unpack (unpack) +import Distribution.Client.Index (index) +import Distribution.Client.Sandbox (sandboxConfigure + , sandboxAddSource, sandboxBuild + , sandboxInstall + , dumpPackageEnvironment) +import Distribution.Client.Init (initCabal) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import Distribution.Simple.Compiler - ( Compiler, PackageDB(..), PackageDBStack ) + ( Compiler, PackageDBStack ) import Distribution.Simple.Program - ( ProgramConfiguration, defaultProgramConfiguration ) + ( ProgramConfiguration ) import Distribution.Simple.Command -import Distribution.Simple.Configure (configCompilerAux) +import Distribution.Simple.Configure + ( checkPersistBuildConfigOutdated, configCompilerAux + , interpretPackageDbFlags, maybeGetPersistBuildConfig ) +import qualified Distribution.Simple.LocalBuildInfo as LBI import Distribution.Simple.Utils - ( cabalVersion, die, topHandler, intercalate ) + ( cabalVersion, die, intercalate, notice, topHandler ) import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity - ( Verbosity, normal, intToVerbosity, lessVerbose ) + ( Verbosity, normal, lessVerbose ) import qualified Paths_cabal_install (version) import System.Environment (getArgs, getProgName) @@ -79,9 +93,8 @@ import System.FilePath (splitExtension, takeExtension) import System.Directory (doesFileExist) import Data.List (intersperse) -import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(..)) -import Control.Monad (unless) +import Control.Monad (when, unless) -- | Entry point -- @@ -89,7 +102,6 @@ main = getArgs >>= mainWorker mainWorker :: [String] -> IO () -mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args mainWorker args = topHandler $ case commandsRun globalCommand commands args of CommandHelp help -> printGlobalHelp help @@ -136,8 +148,7 @@ ,reportCommand `commandAddAction` reportAction ,initCommand `commandAddAction` initAction ,configureExCommand `commandAddAction` configureAction - ,wrapperAction (buildCommand defaultProgramConfiguration) - buildVerbosity buildDistPref + ,buildCommand `commandAddAction` buildAction ,wrapperAction copyCommand copyVerbosity copyDistPref ,wrapperAction haddockCommand @@ -148,9 +159,23 @@ hscolourVerbosity hscolourDistPref ,wrapperAction registerCommand regVerbosity regDistPref - ,wrapperAction testCommand - testVerbosity testDistPref + ,testCommand `commandAddAction` testAction + ,benchmarkCommand `commandAddAction` benchmarkAction ,upgradeCommand `commandAddAction` upgradeAction + ,hiddenCommand $ + win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction + ,hiddenCommand $ + indexCommand `commandAddAction` indexAction + ,hiddenCommand $ + sandboxConfigureCommand `commandAddAction` sandboxConfigureAction + ,hiddenCommand $ + sandboxAddSourceCommand `commandAddAction` sandboxAddSourceAction + ,hiddenCommand $ + sandboxBuildCommand `commandAddAction` sandboxBuildAction + ,hiddenCommand $ + sandboxInstallCommand `commandAddAction` sandboxInstallAction + ,hiddenCommand $ + dumpPkgEnvCommand `commandAddAction` dumpPkgEnvAction ] wrapperAction :: Monoid flags @@ -184,31 +209,211 @@ (configPackageDB' configFlags') (globalRepos globalFlags') comp conf configFlags' configExFlags' extraArgs -installAction :: (ConfigFlags, ConfigExFlags, InstallFlags) +buildAction :: BuildFlags -> [String] -> GlobalFlags -> IO () +buildAction buildFlags extraArgs globalFlags = do + let distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) + (buildDistPref buildFlags) + verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + + reconfigure verbosity distPref mempty [] globalFlags (const Nothing) + build verbosity distPref buildFlags extraArgs + +-- | Actually do the work of building the package. This is separate from +-- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke +-- 'reconfigure' twice. +build :: Verbosity -> FilePath -> BuildFlags -> [String] -> IO () +build verbosity distPref buildFlags extraArgs = + setupWrapper verbosity setupOptions Nothing + buildCommand (const buildFlags') extraArgs + where + setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + buildFlags' = buildFlags + { buildVerbosity = toFlag verbosity + , buildDistPref = toFlag distPref + } + +-- | Re-configure the package in the current directory if needed. Deciding +-- when to reconfigure and with which options is convoluted: +-- +-- If we are reconfiguring, we must always run @configure@ with the +-- verbosity option we are given; however, that a previous configuration +-- uses a different verbosity setting is not reason enough to reconfigure. +-- +-- The package should be configured to use the same \"dist\" prefix as +-- given to the @build@ command, otherwise the build will probably +-- fail. Not only does this determine the \"dist\" prefix setting if we +-- need to reconfigure anyway, but an existing configuration should be +-- invalidated if its \"dist\" prefix differs. +-- +-- If the package has never been configured (i.e., there is no +-- LocalBuildInfo), we must configure first, using the default options. +-- +-- If the package has been configured, there will be a 'LocalBuildInfo'. +-- If there no package description file, we assume that the +-- 'PackageDescription' is up to date, though the configuration may need +-- to be updated for other reasons (see above). If there is a package +-- description file, and it has been modified since the 'LocalBuildInfo' +-- was generated, then we need to reconfigure. +-- +-- The caller of this function may also have specific requirements +-- regarding the flags the last configuration used. For example, +-- 'testAction' requires that the package be configured with test suites +-- enabled. The caller may pass the required settings to this function +-- along with a function to check the validity of the saved 'ConfigFlags'; +-- these required settings will be checked first upon determining that +-- a previous configuration exists. +reconfigure :: Verbosity -- ^ Verbosity setting + -> FilePath -- ^ \"dist\" prefix + -> ConfigFlags -- ^ Additional config flags to set. These flags + -- will be 'mappend'ed to the last used or + -- default 'ConfigFlags' as appropriate, so + -- this value should be 'mempty' with only the + -- required flags set. The required verbosity + -- and \"dist\" prefix flags will be set + -- automatically because they are always + -- required; therefore, it is not necessary to + -- set them here. + -> [String] -- ^ Extra arguments + -> GlobalFlags -- ^ Global flags + -> (ConfigFlags -> Maybe String) + -- ^ Check that the required flags are set in + -- the last used 'ConfigFlags'. If the required + -- flags are not set, provide a message to the + -- user explaining the reason for + -- reconfiguration. Because the correct \"dist\" + -- prefix setting is always required, it is checked + -- automatically; this function need not check + -- for it. + -> IO () +reconfigure verbosity distPref addConfigFlags + extraArgs globalFlags checkFlags = do + mLbi <- maybeGetPersistBuildConfig distPref + case mLbi of + + -- Package has never been configured. + Nothing -> do + notice verbosity + $ "Configuring with default flags." ++ configureManually + configureAction (defaultFlags, defaultConfigExFlags) + extraArgs globalFlags + + -- Package has been configured, but the configuration may be out of + -- date or required flags may not be set. + Just lbi -> do + let configFlags = LBI.configFlags lbi + flags = mconcat [configFlags, addConfigFlags, distVerbFlags] + savedDistPref = fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags) + + -- Determine what message, if any, to display to the user if + -- reconfiguration is required. + message <- case checkFlags configFlags of + + -- Flag required by the caller is not set. + Just msg -> return $! Just $! msg ++ configureManually + + Nothing + -- Required "dist" prefix is not set. + | savedDistPref /= distPref -> + return $! Just distPrefMessage + + -- All required flags are set, but the configuration + -- may be outdated. + | otherwise -> case LBI.pkgDescrFile lbi of + Nothing -> return Nothing + Just pdFile -> do + outdated <- checkPersistBuildConfigOutdated distPref pdFile + return $! if outdated + then Just $! outdatedMessage pdFile + else Nothing + + case message of + + -- No message for the user indicates that reconfiguration + -- is not required. + Nothing -> return () + + Just msg -> do + notice verbosity msg + configureAction (flags, defaultConfigExFlags) + extraArgs globalFlags + where + defaultFlags = mappend addConfigFlags distVerbFlags + distVerbFlags = mempty + { configVerbosity = toFlag verbosity + , configDistPref = toFlag distPref + } + configureManually = " If this fails, please run configure manually.\n" + distPrefMessage = + "Package previously configured with different \"dist\" prefix. " + ++ "Re-configuring based on most recently used options." + ++ configureManually + outdatedMessage pdFile = + pdFile ++ " has been changed. " + ++ "Re-configuring with most recently used options." + ++ configureManually + +installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -installAction (configFlags, _, installFlags) _ _globalFlags +installAction (configFlags, _, installFlags, _) _ _globalFlags | fromFlagOrDefault False (installOnly installFlags) = let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) in setupWrapper verbosity defaultSetupScriptOptions Nothing installCommand (const mempty) [] -installAction (configFlags, configExFlags, installFlags) +installAction (configFlags, configExFlags, installFlags, haddockFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) (configUserInstall configFlags) let configFlags' = savedConfigureFlags config `mappend` configFlags - configExFlags' = savedConfigureExFlags config `mappend` configExFlags + configExFlags' = defaultConfigExFlags `mappend` + savedConfigureExFlags config `mappend` configExFlags installFlags' = defaultInstallFlags `mappend` savedInstallFlags config `mappend` installFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, conf) <- configCompilerAux' configFlags' install verbosity (configPackageDB' configFlags') (globalRepos globalFlags') - comp conf globalFlags' configFlags' configExFlags' installFlags' + comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags targets +testAction :: TestFlags -> [String] -> GlobalFlags -> IO () +testAction testFlags extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (testVerbosity testFlags) + distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) + (testDistPref testFlags) + setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + addConfigFlags = mempty { configTests = toFlag True } + checkFlags flags + | fromFlagOrDefault False (configTests flags) = Nothing + | otherwise = Just "Re-configuring with test suites enabled." + + reconfigure verbosity distPref addConfigFlags [] globalFlags checkFlags + build verbosity distPref mempty [] + + setupWrapper verbosity setupOptions Nothing + testCommand (const testFlags) extraArgs + +benchmarkAction :: BenchmarkFlags -> [String] -> GlobalFlags -> IO () +benchmarkAction benchmarkFlags extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (benchmarkVerbosity benchmarkFlags) + distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) + (benchmarkDistPref benchmarkFlags) + setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + addConfigFlags = mempty { configBenchmarks = toFlag True } + checkFlags flags + | fromFlagOrDefault False (configTests flags) = Nothing + | otherwise = Just "Re-configuring with benchmarks enabled." + + reconfigure verbosity distPref addConfigFlags [] globalFlags checkFlags + build verbosity distPref mempty [] + + setupWrapper verbosity setupOptions Nothing + benchmarkCommand (const benchmarkFlags) extraArgs + listAction :: ListFlags -> [String] -> GlobalFlags -> IO () listAction listFlags extraArgs globalFlags = do let verbosity = fromFlag (listVerbosity listFlags) @@ -250,9 +455,9 @@ let globalFlags' = savedGlobalFlags config `mappend` globalFlags update verbosity (globalRepos globalFlags') -upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags) +upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -upgradeAction (configFlags, configExFlags, installFlags) +upgradeAction (configFlags, configExFlags, installFlags, haddockFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) targets <- readUserTargets verbosity extraArgs @@ -266,7 +471,7 @@ (comp, conf) <- configCompilerAux' configFlags' upgrade verbosity (configPackageDB' configFlags') (globalRepos globalFlags') - comp conf globalFlags' configFlags' configExFlags' installFlags' + comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags targets fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO () @@ -322,11 +527,11 @@ unless allOk exitFailure -sdistAction :: SDistFlags -> [String] -> GlobalFlags -> IO () -sdistAction sflags extraArgs _globalFlags = do +sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> GlobalFlags -> IO () +sdistAction (sdistFlags, sdistExFlags) extraArgs _globalFlags = do unless (null extraArgs) $ do die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs - sdist sflags + sdist sdistFlags sdistExFlags reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO () reportAction reportFlags extraArgs globalFlags = do @@ -355,43 +560,79 @@ targets initAction :: InitFlags -> [String] -> GlobalFlags -> IO () -initAction flags _extraArgs _globalFlags = do - initCabal flags +initAction initFlags _extraArgs globalFlags = do + let verbosity = fromFlag (initVerbosity initFlags) + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let configFlags = savedConfigureFlags config + (comp, conf) <- configCompilerAux' configFlags + initCabal verbosity + (configPackageDB' configFlags) + comp + conf + initFlags +indexAction :: IndexFlags -> [String] -> GlobalFlags -> IO () +indexAction indexFlags extraArgs _globalFlags = do + when (null extraArgs) $ do + die $ "the 'index' command expects a single argument." + when ((>1). length $ extraArgs) $ do + die $ "the 'index' command expects a single argument: " ++ unwords extraArgs + let verbosity = fromFlag (indexVerbosity indexFlags) + index verbosity indexFlags (head extraArgs) + +sandboxConfigureAction :: (SandboxFlags, ConfigFlags, ConfigExFlags) + -> [String] -> GlobalFlags -> IO () +sandboxConfigureAction (sandboxFlags, configFlags, configExFlags) + extraArgs globalFlags = do + let verbosity = fromFlag (sandboxVerbosity sandboxFlags) + sandboxConfigure verbosity sandboxFlags configFlags configExFlags + extraArgs globalFlags + +sandboxAddSourceAction :: SandboxFlags -> [String] -> GlobalFlags -> IO () +sandboxAddSourceAction sandboxFlags extraArgs _globalFlags = do + let verbosity = fromFlag (sandboxVerbosity sandboxFlags) + sandboxAddSource verbosity sandboxFlags extraArgs + +sandboxBuildAction :: (SandboxFlags, BuildFlags) -> [String] -> GlobalFlags + -> IO () +sandboxBuildAction (sandboxFlags, buildFlags) extraArgs _globalFlags = do + let verbosity = fromFlag (sandboxVerbosity sandboxFlags) + sandboxBuild verbosity sandboxFlags buildFlags extraArgs + +sandboxInstallAction :: (SandboxFlags, ConfigFlags, ConfigExFlags, + InstallFlags, HaddockFlags) + -> [String] -> GlobalFlags -> IO () +sandboxInstallAction + (sandboxFlags, configFlags, configExFlags, installFlags, haddockFlags) + extraArgs globalFlags = do + let verbosity = fromFlag (sandboxVerbosity sandboxFlags) + sandboxInstall verbosity sandboxFlags configFlags configExFlags + installFlags haddockFlags extraArgs globalFlags + +dumpPkgEnvAction :: SandboxFlags -> [String] -> GlobalFlags -> IO () +dumpPkgEnvAction sandboxFlags extraArgs _globalFlags = do + when ((>0). length $ extraArgs) $ do + die $ "the 'dump-pkgenv' command doesn't expect any arguments: " + ++ unwords extraArgs + let verbosity = fromFlag (sandboxVerbosity sandboxFlags) + dumpPackageEnvironment verbosity sandboxFlags + -- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. -- -win32SelfUpgradeAction :: [String] -> IO () -win32SelfUpgradeAction (pid:path:rest) = +win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags + -> IO () +win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do + let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags) Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path - where - verbosity = case rest of - (['-','-','v','e','r','b','o','s','e','=',n]:_) | n `elem` ['0'..'9'] - -> fromMaybe Verbosity.normal (Verbosity.intToVerbosity (read [n])) - _ -> Verbosity.normal -win32SelfUpgradeAction _ = return () +win32SelfUpgradeAction _ _ _ = return () -- -- Utils (transitionary) -- --- | Currently the user interface specifies the package dbs to use with just a --- single valued option, a 'PackageDB'. However internally we represent the --- stack of 'PackageDB's explictly as a list. This function converts encodes --- the package db stack implicit in a single packagedb. --- --- TODO: sort this out, make it consistent with the command line UI -implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack -implicitPackageDbStack userInstall packageDbFlag - | userInstall = GlobalPackageDB : UserPackageDB : extra - | otherwise = GlobalPackageDB : extra - where - extra = case packageDbFlag of - Just (SpecificPackageDB db) -> [SpecificPackageDB db] - _ -> [] - configPackageDB' :: ConfigFlags -> PackageDBStack configPackageDB' cfg = - implicitPackageDbStack userInstall (flagToMaybe (configPackageDB cfg)) + interpretPackageDbFlags userInstall (configPackageDBs cfg) where userInstall = fromFlagOrDefault True (configUserInstall cfg) diff --git a/cabal/cabal-install/Paths_cabal_install.hs b/cabal/cabal-install/Paths_cabal_install.hs deleted file mode 100644 --- a/cabal/cabal-install/Paths_cabal_install.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Paths_cabal_install ( - version, - ) where - -import Data.Version (Version(..)) - -version :: Version -version = Version {versionBranch = [0,12,0], versionTags = []} diff --git a/cabal/cabal-install/README b/cabal/cabal-install/README --- a/cabal/cabal-install/README +++ b/cabal/cabal-install/README @@ -17,13 +17,10 @@ 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: - - * Cabal (version 1.10 or later) - * HTTP (version 4000 or later) - * zlib (version 0.4 or later) - -All of these are available from [Hackage](http://hackage.haskell.org). +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 @@ -45,7 +42,7 @@ $ ./bootstrap.sh -It will download and install the above three dependencies. The script will +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/`. @@ -139,13 +136,6 @@ 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 upgrade xmonad - -This is a variation on the `install` command. Both mean to install the latest -version, the only difference is in the treatment of dependencies. The `install` -command tries to use existing installed versions of dependent packages while -the `upgrade` command tries to upgrade all the dependencies too. $ cabal list xml diff --git a/cabal/cabal-install/bootstrap.sh b/cabal/cabal-install/bootstrap.sh --- a/cabal/cabal-install/bootstrap.sh +++ b/cabal/cabal-install/bootstrap.sh @@ -7,7 +7,6 @@ # It expects to be run inside the cabal-install directory. # install settings, you can override these by setting environment vars -PREFIX=${PREFIX:-${HOME}/.cabal} #VERBOSE #EXTRA_CONFIGURE_OPTS @@ -20,6 +19,7 @@ TAR=${TAR:-tar} GUNZIP=${GUNZIP:-gunzip} SCOPE_OF_INSTALLATION="--user" +DEFAULT_PREFIX="${HOME}/.cabal" for arg in $* @@ -30,7 +30,7 @@ shift;; "--global") SCOPE_OF_INSTALLATION=${arg} - PREFIX="/usr/local" + DEFAULT_PREFIX="/usr/local" shift;; *) echo "Unknown argument or option, quitting: ${arg}" @@ -43,17 +43,21 @@ esac done +PREFIX=${PREFIX:-${DEFAULT_PREFIX}} # Versions of the packages to install. # The version regex says what existing installed versions are ok. -PARSEC_VER="3.1.1"; PARSEC_VER_REGEXP="[23]\." # == 2.* || == 3.* -NETWORK_VER="2.3.0.2"; NETWORK_VER_REGEXP="2\." # == 2.* -CABAL_VER="1.10.1.0"; CABAL_VER_REGEXP="1\.10\.[^0]" # == 1.10.* && >= 1.10.1 -TRANS_VER="0.2.2.0"; TRANS_VER_REGEXP="0\.2\." # == 0.2.* -MTL_VER="2.0.1.0"; MTL_VER_REGEXP="[12]\." # == 1.* || == 2.* -HTTP_VER="4000.1.1"; HTTP_VER_REGEXP="4000\.[01]\." # == 4000.0.* || 4000.1.* -ZLIB_VER="0.5.3.1"; ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || ==0.5.* -TIME_VER="1.2.0.4" TIME_VER_REGEXP="1\.[12]\." # == 0.1.* || ==0.2.* +PARSEC_VER="3.1.3"; PARSEC_VER_REGEXP="[23]\." # == 2.* || == 3.* +DEEPSEQ_VER="1.3.0.1"; DEEPSEQ_VER_REGEXP="1\.[1-9]\." # >= 1.1 && < 2 +TEXT_VER="0.11.2.3"; TEXT_VER_REGEXP="0\.([2-9]|(1[0-1]))\." # >= 0.2 && < 0.12 +NETWORK_VER="2.3.1.0"; NETWORK_VER_REGEXP="2\." # == 2.* +CABAL_VER="1.16.0"; CABAL_VER_REGEXP="1\.(13\.3|1[4-7]\.)" # >= 1.13.3 && < 1.18 +TRANS_VER="0.3.0.0"; TRANS_VER_REGEXP="0\.[23]\." # >= 0.2.* && < 0.4.* +MTL_VER="2.1.2"; MTL_VER_REGEXP="[12]\." # == 1.* || == 2.* +HTTP_VER="4000.2.4"; HTTP_VER_REGEXP="4000\.[012]\." # == 4000.0.* || 4000.1.* || 4000.2.* +ZLIB_VER="0.5.3.3"; ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || == 0.5.* +TIME_VER="1.4.0.1" TIME_VER_REGEXP="1\.[1234]\.?" # >= 1.1 && < 1.5 +RANDOM_VER="1.0.1.1" RANDOM_VER_REGEXP="1\.0\." # >= 1 && < 1.1 HACKAGE_URL="http://hackage.haskell.org/packages/archive" @@ -86,7 +90,7 @@ need_pkg () { PKG=$1 VER_MATCH=$2 - if grep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1 + if egrep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1 then return 1; else @@ -186,20 +190,26 @@ info_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} info_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP} info_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} +info_pkg "deepseq" ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} +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 "time" ${TIME_VER} ${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} do_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} do_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP} do_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} +do_pkg "deepseq" ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} +do_pkg "text" ${TEXT_VER} ${TEXT_VER_REGEXP} do_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} do_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} do_pkg "time" ${TIME_VER} ${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} install_pkg "cabal-install" diff --git a/cabal/cabal-install/cabal-install.cabal b/cabal/cabal-install/cabal-install.cabal --- a/cabal/cabal-install/cabal-install.cabal +++ b/cabal/cabal-install/cabal-install.cabal @@ -1,12 +1,12 @@ Name: cabal-install -Version: 0.11.2 +Version: 0.17.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing Haskell software by automating the fetching, configuration, compilation and installation of Haskell libraries and programs. homepage: http://www.haskell.org/cabal/ -bug-reports: http://hackage.haskell.org/trac/hackage/ +bug-reports: https://github.com/haskell/cabal/issues License: BSD3 License-File: LICENSE Author: Lemmih @@ -19,15 +19,16 @@ 2006 Paolo Martini 2007 Bjorn Bringert 2007 Isaac Potoczny-Jones - 2007-2011 Duncan Coutts + 2007-2012 Duncan Coutts Category: Distribution Build-type: Simple Extra-Source-Files: README bash-completion/cabal bootstrap.sh Cabal-Version: >= 1.6 source-repository head - type: darcs - location: http://darcs.haskell.org/cabal-install/ + type: git + location: https://github.com/haskell/cabal/ + subdir: cabal-install flag old-base description: Old, monolithic base @@ -37,9 +38,7 @@ Executable cabal Main-Is: Main.hs - -- We want assertion checking on even if people build with -O - -- although it is expensive, we want to catch problems early: - ghc-options: -Wall -fno-ignore-asserts + ghc-options: -Wall -threaded if impl(ghc >= 6.8) ghc-options: -fwarn-tabs Other-Modules: @@ -55,11 +54,31 @@ Distribution.Client.Dependency.TopDown.Constraints Distribution.Client.Dependency.TopDown.Types Distribution.Client.Dependency.Types + Distribution.Client.Dependency.Modular + Distribution.Client.Dependency.Modular.Assignment + Distribution.Client.Dependency.Modular.Builder + Distribution.Client.Dependency.Modular.Configured + Distribution.Client.Dependency.Modular.ConfiguredConversion + Distribution.Client.Dependency.Modular.Dependency + Distribution.Client.Dependency.Modular.Explore + Distribution.Client.Dependency.Modular.Flag + Distribution.Client.Dependency.Modular.Index + Distribution.Client.Dependency.Modular.IndexConversion + Distribution.Client.Dependency.Modular.Log + Distribution.Client.Dependency.Modular.Message + Distribution.Client.Dependency.Modular.Package + Distribution.Client.Dependency.Modular.Preference + Distribution.Client.Dependency.Modular.PSQ + Distribution.Client.Dependency.Modular.Solver + Distribution.Client.Dependency.Modular.Tree + Distribution.Client.Dependency.Modular.Validate + Distribution.Client.Dependency.Modular.Version Distribution.Client.Fetch Distribution.Client.FetchUtils Distribution.Client.GZipUtils Distribution.Client.Haddock Distribution.Client.HttpUtils + Distribution.Client.Index Distribution.Client.IndexUtils Distribution.Client.Init Distribution.Client.Init.Heuristics @@ -68,9 +87,13 @@ Distribution.Client.Install Distribution.Client.InstallPlan Distribution.Client.InstallSymlink + Distribution.Client.JobControl Distribution.Client.List + Distribution.Client.PackageEnvironment Distribution.Client.PackageIndex Distribution.Client.PackageUtils + Distribution.Client.ParseUtils + Distribution.Client.Sandbox Distribution.Client.Setup Distribution.Client.SetupWrapper Distribution.Client.SrcDist @@ -85,27 +108,29 @@ Distribution.Client.Win32SelfUpgrade Distribution.Compat.Exception Distribution.Compat.FilePerms + Distribution.Compat.Time Paths_cabal_install build-depends: base >= 2 && < 5, - Cabal >= 1.10.1 && < 1.11.3, - filepath >= 1.0 && < 1.3, + Cabal >= 1.17.0 && < 1.18, + filepath >= 1.0 && < 1.4, network >= 1 && < 3, HTTP >= 4000.0.2 && < 4001, zlib >= 0.4 && < 0.6, - time >= 1.1 && < 1.3 + time >= 1.1 && < 1.5, + mtl >= 2.0 && < 3 if flag(old-base) build-depends: base < 3 else build-depends: base >= 3, - process >= 1 && < 1.1, - directory >= 1 && < 1.2, - pretty >= 1 && < 1.1, + process >= 1 && < 1.2, + directory >= 1 && < 1.3, + pretty >= 1 && < 1.2, random >= 1 && < 1.1, - containers >= 0.1 && < 0.5, - array >= 0.1 && < 0.4, - old-time >= 1 && < 1.1 + containers >= 0.1 && < 0.6, + array >= 0.1 && < 0.5, + old-time >= 1 && < 1.2 if flag(bytestring-in-base) build-depends: base >= 2.0 && < 2.2 @@ -116,5 +141,6 @@ build-depends: Win32 >= 2 && < 3 cpp-options: -DWIN32 else - build-depends: unix >= 1.0 && < 2.5 - extensions: CPP + build-depends: unix >= 1.0 && < 2.7 + extensions: CPP, ForeignFunctionInterface + c-sources: cbits/getnumcores.c diff --git a/cabal/cabal-install/cbits/getnumcores.c b/cabal/cabal-install/cbits/getnumcores.c new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/cbits/getnumcores.c @@ -0,0 +1,46 @@ +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 612) +/* Since version 6.12, GHC's threaded RTS includes a getNumberOfProcessors + function, so we try to use that if available. cabal-install is always built + with -threaded nowadays. */ +#define HAS_GET_NUMBER_OF_PROCESSORS +#endif + + +#ifndef HAS_GET_NUMBER_OF_PROCESSORS + +#ifdef _WIN32 +#include +#elif MACOS +#include +#include +#elif __linux__ +#include +#endif + +int getNumberOfProcessors() { +#ifdef WIN32 + SYSTEM_INFO sysinfo; + GetSystemInfo(&sysinfo); + return sysinfo.dwNumberOfProcessors; +#elif MACOS + int nm[2]; + size_t len = 4; + uint32_t count; + + nm[0] = CTL_HW; nm[1] = HW_AVAILCPU; + sysctl(nm, 2, &count, &len, NULL, 0); + + if(count < 1) { + nm[1] = HW_NCPU; + sysctl(nm, 2, &count, &len, NULL, 0); + if(count < 1) { count = 1; } + } + return count; +#elif __linux__ + return sysconf(_SC_NPROCESSORS_ONLN); +#else + return 1; +#endif +} + +#endif /* HAS_GET_NUMBER_OF_PROCESSORS */ diff --git a/cabal/cabal-install/changelog b/cabal/cabal-install/changelog --- a/cabal/cabal-install/changelog +++ b/cabal/cabal-install/changelog @@ -1,5 +1,19 @@ -*-change-log-*- +0.14.0 Andres Loeh April 2012 + * Works with ghc-7.4 + * Completely new modular dependency solver (default in most cases) + * Some tweaks to old topdown dependency solver + * Install plans are now checked for reinstalls that break packages + * Flags --constraint and --preference work for nonexisting packages + * New constraint forms for source and installed packages + * New constraint form for package-specific use flags + * New constraint form for package-specific stanza flags + * Test suite dependencies are pulled in on demand + * No longer install packages on --enable-tests when tests fail + * New "cabal bench" command + * Various "cabal init" tweaks + 0.10.0 Duncan Coutts February 2011 * New package targets: local dirs, local and remote tarballs * Initial support for a "world" package target diff --git a/cabal/cabal/Cabal.cabal b/cabal/cabal/Cabal.cabal deleted file mode 100644 --- a/cabal/cabal/Cabal.cabal +++ /dev/null @@ -1,163 +0,0 @@ -Name: Cabal -Version: 1.12.0 -Copyright: 2003-2006, Isaac Jones - 2005-2011, Duncan Coutts -License: BSD3 -License-File: LICENSE -Author: Isaac Jones - Duncan Coutts -Maintainer: cabal-devel@haskell.org -Homepage: http://www.haskell.org/cabal/ -bug-reports: http://hackage.haskell.org/trac/hackage/ -Synopsis: A framework for packaging Haskell software -Description: - The Haskell Common Architecture for Building Applications and - Libraries: a framework defining a common interface for authors to more - easily build their Haskell applications in a portable way. - . - The Haskell Cabal is part of a larger infrastructure for distributing, - organizing, and cataloging Haskell libraries and tools. -Category: Distribution -cabal-version: >=1.10 -Build-Type: Custom --- Even though we do use the default Setup.lhs it's vital to bootstrapping --- that we build Setup.lhs using our own local Cabal source code. - -Extra-Source-Files: - README changelog - -source-repository head - type: darcs - location: http://darcs.haskell.org/cabal/ - -Flag base4 - Description: Choose the even newer, even smaller, split-up base package. - -Flag base3 - Description: Choose the new smaller, split-up base package. - -Library - build-depends: base >= 2 && < 5, - filepath >= 1 && < 1.3 - if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 } - if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 } - if flag(base3) - Build-Depends: directory >= 1 && < 1.2, - process >= 1 && < 1.2, - old-time >= 1 && < 1.1, - containers >= 0.1 && < 0.5, - array >= 0.1 && < 0.4, - pretty >= 1 && < 1.2 - - if !os(windows) - Build-Depends: unix >= 2.0 && < 2.6 - - ghc-options: -Wall -fno-ignore-asserts - if impl(ghc >= 6.8) - ghc-options: -fwarn-tabs - nhc98-Options: -K4M - - Exposed-Modules: - Distribution.Compiler, - Distribution.InstalledPackageInfo, - Distribution.License, - Distribution.Make, - Distribution.ModuleName, - Distribution.Package, - Distribution.PackageDescription, - Distribution.PackageDescription.Configuration, - Distribution.PackageDescription.Parse, - Distribution.PackageDescription.Check, - Distribution.PackageDescription.PrettyPrint, - Distribution.ParseUtils, - Distribution.ReadE, - Distribution.Simple, - Distribution.Simple.Build, - Distribution.Simple.Build.Macros, - Distribution.Simple.Build.PathsModule, - Distribution.Simple.BuildPaths, - Distribution.Simple.Command, - Distribution.Simple.Compiler, - Distribution.Simple.Configure, - Distribution.Simple.GHC, - Distribution.Simple.LHC, - Distribution.Simple.Haddock, - Distribution.Simple.Hpc, - Distribution.Simple.Hugs, - Distribution.Simple.Install, - Distribution.Simple.InstallDirs, - Distribution.Simple.JHC, - Distribution.Simple.LocalBuildInfo, - Distribution.Simple.NHC, - Distribution.Simple.PackageIndex, - Distribution.Simple.PreProcess, - Distribution.Simple.PreProcess.Unlit, - Distribution.Simple.Program, - Distribution.Simple.Program.Ar, - Distribution.Simple.Program.Builtin, - Distribution.Simple.Program.Db, - Distribution.Simple.Program.HcPkg, - Distribution.Simple.Program.Ld, - Distribution.Simple.Program.Run, - Distribution.Simple.Program.Script, - Distribution.Simple.Program.Types, - Distribution.Simple.Register, - Distribution.Simple.Setup, - Distribution.Simple.SrcDist, - Distribution.Simple.Test, - Distribution.Simple.UHC, - Distribution.Simple.UserHooks, - Distribution.Simple.Utils, - Distribution.System, - Distribution.TestSuite, - Distribution.Text, - Distribution.Verbosity, - Distribution.Version, - Distribution.Compat.ReadP, - Language.Haskell.Extension - - Other-Modules: - Distribution.GetOpt, - Distribution.Compat.Exception, - Distribution.Compat.CopyFile, - Distribution.Compat.TempFile, - Distribution.Simple.GHC.IPI641, - Distribution.Simple.GHC.IPI642, - Paths_Cabal - - Default-Language: Haskell98 - Default-Extensions: CPP - -test-suite unit-tests - type: exitcode-stdio-1.0 - main-is: suite.hs - other-modules: PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check, - PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check, - PackageTests.BuildDeps.InternalLibrary0.Check, - PackageTests.BuildDeps.InternalLibrary1.Check, - PackageTests.BuildDeps.InternalLibrary2.Check, - PackageTests.BuildDeps.InternalLibrary3.Check, - PackageTests.BuildDeps.InternalLibrary4.Check, - PackageTests.BuildDeps.TargetSpecificDeps1.Check, - PackageTests.BuildDeps.TargetSpecificDeps2.Check, - PackageTests.BuildDeps.TargetSpecificDeps3.Check, - PackageTests.BuildDeps.SameDepsAllRound.Check, - PackageTests.TestStanza.Check, - PackageTests.TestSuiteExeV10.Check, - PackageTests.PackageTester - hs-source-dirs: tests - build-depends: - base, - test-framework, - test-framework-quickcheck2, - test-framework-hunit, - HUnit, - QuickCheck >= 2.1.0.1, - Cabal, - process, - directory, - filepath, - extensible-exceptions, - bytestring, - unix - Default-Language: Haskell98 diff --git a/cabal/cabal/DefaultSetup.hs b/cabal/cabal/DefaultSetup.hs deleted file mode 100644 --- a/cabal/cabal/DefaultSetup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal/Distribution/Compat/CopyFile.hs b/cabal/cabal/Distribution/Compat/CopyFile.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Compat/CopyFile.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# OPTIONS -cpp #-} --- OPTIONS required for ghc-6.4.x compat, and must appear first -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -cpp #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp #-} --- #hide -module Distribution.Compat.CopyFile ( - copyFile, - copyOrdinaryFile, - copyExecutableFile, - setFileOrdinary, - setFileExecutable, - setDirOrdinary, - ) where - -#ifdef __GLASGOW_HASKELL__ - -import Control.Monad - ( when ) -import Control.Exception - ( bracket, bracketOnError ) -import Distribution.Compat.Exception - ( catchIO ) -#if __GLASGOW_HASKELL__ >= 608 -import Distribution.Compat.Exception - ( throwIOIO ) -import System.IO.Error - ( ioeSetLocation ) -#endif -import System.Directory - ( renameFile, removeFile ) -import Distribution.Compat.TempFile - ( openBinaryTempFile ) -import System.FilePath - ( takeDirectory ) -import System.IO - ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf ) -import Foreign - ( allocaBytes ) -#endif /* __GLASGOW_HASKELL__ */ - -#ifndef mingw32_HOST_OS -#if __GLASGOW_HASKELL__ >= 611 -import System.Posix.Internals (withFilePath) -#else -import Foreign.C (withCString) -#endif -import System.Posix.Types - ( FileMode ) -import System.Posix.Internals - ( c_chmod ) -#if __GLASGOW_HASKELL__ >= 608 -import Foreign.C - ( throwErrnoPathIfMinus1_ ) -#else -import Foreign.C - ( throwErrnoIfMinus1_ ) -#endif -#endif /* mingw32_HOST_OS */ - -copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO () -copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest -copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest - -setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () -#ifndef mingw32_HOST_OS -setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- -setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x - -setFileMode :: FilePath -> FileMode -> IO () -setFileMode name m = -#if __GLASGOW_HASKELL__ >= 611 - withFilePath name $ \s -> do -#else - withCString name $ \s -> do -#endif -#if __GLASGOW_HASKELL__ >= 608 - throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) -#else - throwErrnoIfMinus1_ name (c_chmod s m) -#endif -#else -setFileOrdinary _ = return () -setFileExecutable _ = return () -#endif --- This happens to be true on Unix and currently on Windows too: -setDirOrdinary = setFileExecutable - -copyFile :: FilePath -> FilePath -> IO () -#ifdef __GLASGOW_HASKELL__ -copyFile fromFPath toFPath = - copy -#if __GLASGOW_HASKELL__ >= 608 - `catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "copyFile")) -#endif - where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> - bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> - do allocaBytes bufferSize $ copyContents hFrom hTmp - hClose hTmp - renameFile tmpFPath toFPath - openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp" - cleanTmp (tmpFPath, hTmp) = do - hClose hTmp `catchIO` \_ -> return () - removeFile tmpFPath `catchIO` \_ -> return () - bufferSize = 4096 - - copyContents hFrom hTo buffer = do - count <- hGetBuf hFrom buffer bufferSize - when (count > 0) $ do - hPutBuf hTo buffer count - copyContents hFrom hTo buffer -#else -copyFile fromFPath toFPath = readFile fromFPath >>= writeFile toFPath -#endif diff --git a/cabal/cabal/Distribution/Compat/Exception.hs b/cabal/cabal/Distribution/Compat/Exception.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Compat/Exception.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# OPTIONS -cpp #-} --- OPTIONS required for ghc-6.4.x compat, and must appear first -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -cpp #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp #-} - -#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610)) -#define NEW_EXCEPTION -#endif - -module Distribution.Compat.Exception ( - Exception.IOException, - onException, - catchIO, - catchExit, - throwIOIO, - tryIO, - ) where - -import System.Exit -import qualified Control.Exception as Exception - -onException :: IO a -> IO b -> IO a -#ifdef NEW_EXCEPTION -onException = Exception.onException -#else -onException io what = io `Exception.catch` \e -> do what - Exception.throw e -#endif - -throwIOIO :: Exception.IOException -> IO a -#ifdef NEW_EXCEPTION -throwIOIO = Exception.throwIO -#else -throwIOIO = Exception.throwIO . Exception.IOException -#endif - -tryIO :: IO a -> IO (Either Exception.IOException a) -#ifdef NEW_EXCEPTION -tryIO = Exception.try -#else -tryIO = Exception.tryJust Exception.ioErrors -#endif - -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#ifdef NEW_EXCEPTION -catchIO = Exception.catch -#else -catchIO = Exception.catchJust Exception.ioErrors -#endif - -catchExit :: IO a -> (ExitCode -> IO a) -> IO a -#ifdef NEW_EXCEPTION -catchExit = Exception.catch -#else -catchExit = Exception.catchJust exitExceptions - where exitExceptions (Exception.ExitException ee) = Just ee - exitExceptions _ = Nothing -#endif - diff --git a/cabal/cabal/Distribution/Compat/ReadP.hs b/cabal/cabal/Distribution/Compat/ReadP.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Compat/ReadP.hs +++ /dev/null @@ -1,470 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.ReadP --- Copyright : (c) The University of Glasgow 2002 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Portability : portable --- --- This is a library of parser combinators, originally written by Koen Claessen. --- It parses all alternatives in parallel, so it never keeps hold of --- the beginning of the input string, a common source of space leaks with --- other parsers. The '(+++)' choice combinator is genuinely commutative; --- it makes no difference which branch is \"shorter\". --- --- See also Koen's paper /Parallel Parsing Processes/ --- (). --- --- This version of ReadP has been locally hacked to make it H98, by --- Martin Sjögren --- ------------------------------------------------------------------------------ - -module Distribution.Compat.ReadP - ( - -- * The 'ReadP' type - ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus - - -- * Primitive operations - get, -- :: ReadP Char - look, -- :: ReadP String - (+++), -- :: ReadP a -> ReadP a -> ReadP a - (<++), -- :: ReadP a -> ReadP a -> ReadP a - gather, -- :: ReadP a -> ReadP (String, a) - - -- * Other operations - pfail, -- :: ReadP a - satisfy, -- :: (Char -> Bool) -> ReadP Char - char, -- :: Char -> ReadP Char - string, -- :: String -> ReadP String - munch, -- :: (Char -> Bool) -> ReadP String - munch1, -- :: (Char -> Bool) -> ReadP String - skipSpaces, -- :: ReadP () - choice, -- :: [ReadP a] -> ReadP a - count, -- :: Int -> ReadP a -> ReadP [a] - between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a - option, -- :: a -> ReadP a -> ReadP a - optional, -- :: ReadP a -> ReadP () - many, -- :: ReadP a -> ReadP [a] - many1, -- :: ReadP a -> ReadP [a] - skipMany, -- :: ReadP a -> ReadP () - skipMany1, -- :: ReadP a -> ReadP () - sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a] - sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] - endBy, -- :: ReadP a -> ReadP sep -> ReadP [a] - endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] - chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a - chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a - chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a - chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a - manyTill, -- :: ReadP a -> ReadP end -> ReadP [a] - - -- * Running a parser - ReadS, -- :: *; = String -> [(a,String)] - readP_to_S, -- :: ReadP a -> ReadS a - readS_to_P -- :: ReadS a -> ReadP a - - -- * Properties - -- $properties - ) - where - -import Control.Monad( MonadPlus(..), liftM2 ) -import Data.Char (isSpace) - -infixr 5 +++, <++ - --- --------------------------------------------------------------------------- --- The P type --- is representation type -- should be kept abstract - -data P s a - = Get (s -> P s a) - | Look ([s] -> P s a) - | Fail - | Result a (P s a) - | Final [(a,[s])] -- invariant: list is non-empty! - --- Monad, MonadPlus - -instance Monad (P s) where - return x = Result x Fail - - (Get f) >>= k = Get (\c -> f c >>= k) - (Look f) >>= k = Look (\s -> f s >>= k) - Fail >>= _ = Fail - (Result x p) >>= k = k x `mplus` (p >>= k) - (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s] - - fail _ = Fail - -instance MonadPlus (P s) where - mzero = Fail - - -- most common case: two gets are combined - Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c) - - -- results are delivered as soon as possible - Result x p `mplus` q = Result x (p `mplus` q) - p `mplus` Result x q = Result x (p `mplus` q) - - -- fail disappears - Fail `mplus` p = p - p `mplus` Fail = p - - -- two finals are combined - -- final + look becomes one look and one final (=optimization) - -- final + sthg else becomes one look and one final - Final r `mplus` Final t = Final (r ++ t) - Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s)) - Final r `mplus` p = Look (\s -> Final (r ++ run p s)) - Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r)) - p `mplus` Final r = Look (\s -> Final (run p s ++ r)) - - -- two looks are combined (=optimization) - -- look + sthg else floats upwards - Look f `mplus` Look g = Look (\s -> f s `mplus` g s) - Look f `mplus` p = Look (\s -> f s `mplus` p) - p `mplus` Look f = Look (\s -> p `mplus` f s) - --- --------------------------------------------------------------------------- --- The ReadP type - -newtype Parser r s a = R ((a -> P s r) -> P s r) -type ReadP r a = Parser r Char a - --- Functor, Monad, MonadPlus - -instance Functor (Parser r s) where - fmap h (R f) = R (\k -> f (k . h)) - -instance Monad (Parser r s) where - return x = R (\k -> k x) - fail _ = R (\_ -> Fail) - R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) - ---instance MonadPlus (Parser r s) where --- mzero = pfail --- mplus = (+++) - --- --------------------------------------------------------------------------- --- Operations over P - -final :: [(a,[s])] -> P s a --- Maintains invariant for Final constructor -final [] = Fail -final r = Final r - -run :: P c a -> ([c] -> [(a, [c])]) -run (Get f) (c:s) = run (f c) s -run (Look f) s = run (f s) s -run (Result x p) s = (x,s) : run p s -run (Final r) _ = r -run _ _ = [] - --- --------------------------------------------------------------------------- --- Operations over ReadP - -get :: ReadP r Char --- ^ Consumes and returns the next character. --- Fails if there is no input left. -get = R Get - -look :: ReadP r String --- ^ Look-ahead: returns the part of the input that is left, without --- consuming it. -look = R Look - -pfail :: ReadP r a --- ^ Always fails. -pfail = R (\_ -> Fail) - -(+++) :: ReadP r a -> ReadP r a -> ReadP r a --- ^ Symmetric choice. -R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k) - -(<++) :: ReadP a a -> ReadP r a -> ReadP r a --- ^ Local, exclusive, left-biased choice: If left parser --- locally produces any result at all, then right parser is --- not used. -R f <++ q = - do s <- look - probe (f return) s 0 - where - probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int) - probe (Look f') s n = probe (f' s) s n - probe p@(Result _ _) _ n = discard n >> R (p >>=) - probe (Final r) _ _ = R (Final r >>=) - probe _ _ _ = q - - discard 0 = return () - discard n = get >> discard (n-1 :: Int) - -gather :: ReadP (String -> P Char r) a -> ReadP r (String, a) --- ^ Transforms a parser into one that does the same, but --- in addition returns the exact characters read. --- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument --- is built using any occurrences of readS_to_P. -gather (R m) = - R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) - where - gath l (Get f) = Get (\c -> gath (l.(c:)) (f c)) - gath _ Fail = Fail - gath l (Look f) = Look (\s -> gath l (f s)) - gath l (Result k p) = k (l []) `mplus` gath l p - gath _ (Final _) = error "do not use readS_to_P in gather!" - --- --------------------------------------------------------------------------- --- Derived operations - -satisfy :: (Char -> Bool) -> ReadP r Char --- ^ Consumes and returns the next character, if it satisfies the --- specified predicate. -satisfy p = do c <- get; if p c then return c else pfail - -char :: Char -> ReadP r Char --- ^ Parses and returns the specified character. -char c = satisfy (c ==) - -string :: String -> ReadP r String --- ^ Parses and returns the specified string. -string this = do s <- look; scan this s - where - scan [] _ = do return this - scan (x:xs) (y:ys) | x == y = do get >> scan xs ys - scan _ _ = do pfail - -munch :: (Char -> Bool) -> ReadP r String --- ^ Parses the first zero or more characters satisfying the predicate. -munch p = - do s <- look - scan s - where - scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s) - scan _ = do return "" - -munch1 :: (Char -> Bool) -> ReadP r String --- ^ Parses the first one or more characters satisfying the predicate. -munch1 p = - do c <- get - if p c then do s <- munch p; return (c:s) - else pfail - -choice :: [ReadP r a] -> ReadP r a --- ^ Combines all parsers in the specified list. -choice [] = pfail -choice [p] = p -choice (p:ps) = p +++ choice ps - -skipSpaces :: ReadP r () --- ^ Skips all whitespace. -skipSpaces = - do s <- look - skip s - where - skip (c:s) | isSpace c = do _ <- get; skip s - skip _ = do return () - -count :: Int -> ReadP r a -> ReadP r [a] --- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of --- results is returned. -count n p = sequence (replicate n p) - -between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a --- ^ @ between open close p @ parses @open@, followed by @p@ and finally --- @close@. Only the value of @p@ is returned. -between open close p = do _ <- open - x <- p - _ <- close - return x - -option :: a -> ReadP r a -> ReadP r a --- ^ @option x p@ will either parse @p@ or return @x@ without consuming --- any input. -option x p = p +++ return x - -optional :: ReadP r a -> ReadP r () --- ^ @optional p@ optionally parses @p@ and always returns @()@. -optional p = (p >> return ()) +++ return () - -many :: ReadP r a -> ReadP r [a] --- ^ Parses zero or more occurrences of the given parser. -many p = return [] +++ many1 p - -many1 :: ReadP r a -> ReadP r [a] --- ^ Parses one or more occurrences of the given parser. -many1 p = liftM2 (:) p (many p) - -skipMany :: ReadP r a -> ReadP r () --- ^ Like 'many', but discards the result. -skipMany p = many p >> return () - -skipMany1 :: ReadP r a -> ReadP r () --- ^ Like 'many1', but discards the result. -skipMany1 p = p >> skipMany p - -sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@. --- Returns a list of values returned by @p@. -sepBy p sep = sepBy1 p sep +++ return [] - -sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@. --- Returns a list of values returned by @p@. -sepBy1 p sep = liftM2 (:) p (many (sep >> p)) - -endBy :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended --- by @sep@. -endBy p sep = many (do x <- p ; _ <- sep ; return x) - -endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] --- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended --- by @sep@. -endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x) - -chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a --- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. --- Returns a value produced by a /right/ associative application of all --- functions returned by @op@. If there are no occurrences of @p@, @x@ is --- returned. -chainr p op x = chainr1 p op +++ return x - -chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a --- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@. --- Returns a value produced by a /left/ associative application of all --- functions returned by @op@. If there are no occurrences of @p@, @x@ is --- returned. -chainl p op x = chainl1 p op +++ return x - -chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a --- ^ Like 'chainr', but parses one or more occurrences of @p@. -chainr1 p op = scan - where scan = p >>= rest - rest x = do f <- op - y <- scan - return (f x y) - +++ return x - -chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a --- ^ Like 'chainl', but parses one or more occurrences of @p@. -chainl1 p op = p >>= rest - where rest x = do f <- op - y <- p - rest (f x y) - +++ return x - -manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a] --- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@ --- succeeds. Returns a list of values returned by @p@. -manyTill p end = scan - where scan = (end >> return []) <++ (liftM2 (:) p scan) - --- --------------------------------------------------------------------------- --- Converting between ReadP and Read - -readP_to_S :: ReadP a a -> ReadS a --- ^ Converts a parser into a Haskell ReadS-style function. --- This is the main way in which you can \"run\" a 'ReadP' parser: --- the expanded type is --- @ readP_to_S :: ReadP a -> String -> [(a,String)] @ -readP_to_S (R f) = run (f return) - -readS_to_P :: ReadS a -> ReadP r a --- ^ Converts a Haskell ReadS-style function into a parser. --- Warning: This introduces local backtracking in the resulting --- parser, and therefore a possible inefficiency. -readS_to_P r = - R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s'])) - --- --------------------------------------------------------------------------- --- QuickCheck properties that hold for the combinators - -{- $properties -The following are QuickCheck specifications of what the combinators do. -These can be seen as formal specifications of the behavior of the -combinators. - -We use bags to give semantics to the combinators. - -> type Bag a = [a] - -Equality on bags does not care about the order of elements. - -> (=~) :: Ord a => Bag a -> Bag a -> Bool -> xs =~ ys = sort xs == sort ys - -A special equality operator to avoid unresolved overloading -when testing the properties. - -> (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool -> (=~.) = (=~) - -Here follow the properties: - -> prop_Get_Nil = -> readP_to_S get [] =~ [] -> -> prop_Get_Cons c s = -> readP_to_S get (c:s) =~ [(c,s)] -> -> prop_Look s = -> readP_to_S look s =~ [(s,s)] -> -> prop_Fail s = -> readP_to_S pfail s =~. [] -> -> prop_Return x s = -> readP_to_S (return x) s =~. [(x,s)] -> -> prop_Bind p k s = -> readP_to_S (p >>= k) s =~. -> [ ys'' -> | (x,s') <- readP_to_S p s -> , ys'' <- readP_to_S (k (x::Int)) s' -> ] -> -> prop_Plus p q s = -> readP_to_S (p +++ q) s =~. -> (readP_to_S p s ++ readP_to_S q s) -> -> prop_LeftPlus p q s = -> readP_to_S (p <++ q) s =~. -> (readP_to_S p s +<+ readP_to_S q s) -> where -> [] +<+ ys = ys -> xs +<+ _ = xs -> -> prop_Gather s = -> forAll readPWithoutReadS $ \p -> -> readP_to_S (gather p) s =~ -> [ ((pre,x::Int),s') -> | (x,s') <- readP_to_S p s -> , let pre = take (length s - length s') s -> ] -> -> prop_String_Yes this s = -> readP_to_S (string this) (this ++ s) =~ -> [(this,s)] -> -> prop_String_Maybe this s = -> readP_to_S (string this) s =~ -> [(this, drop (length this) s) | this `isPrefixOf` s] -> -> prop_Munch p s = -> readP_to_S (munch p) s =~ -> [(takeWhile p s, dropWhile p s)] -> -> prop_Munch1 p s = -> readP_to_S (munch1 p) s =~ -> [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)] -> -> prop_Choice ps s = -> readP_to_S (choice ps) s =~. -> readP_to_S (foldr (+++) pfail ps) s -> -> prop_ReadS r s = -> readP_to_S (readS_to_P r) s =~. r s --} - diff --git a/cabal/cabal/Distribution/Compat/TempFile.hs b/cabal/cabal/Distribution/Compat/TempFile.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Compat/TempFile.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# OPTIONS -cpp #-} --- OPTIONS required for ghc-6.4.x compat, and must appear first -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -cpp #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp #-} --- #hide -module Distribution.Compat.TempFile ( - openTempFile, - openBinaryTempFile, - openNewBinaryFile, - createTempDirectory, - ) where - - -import System.FilePath (()) -import Foreign.C (eEXIST) - -#if __NHC__ || __HUGS__ -import System.IO (openFile, openBinaryFile, - Handle, IOMode(ReadWriteMode)) -import System.Directory (doesFileExist) -import System.FilePath ((<.>), splitExtension) -import System.IO.Error (try, isAlreadyExistsError) -#else -import System.IO (Handle, openTempFile, openBinaryTempFile) -import Data.Bits ((.|.)) -import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR, - o_BINARY, o_NONBLOCK, o_NOCTTY) -import System.IO.Error (isAlreadyExistsError) -#if __GLASGOW_HASKELL__ >= 611 -import System.Posix.Internals (withFilePath) -#else -import Foreign.C (withCString) -#endif -import Foreign.C (CInt) -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO.Handle.FD (fdToHandle) -#else -import GHC.Handle (fdToHandle) -#endif -import Distribution.Compat.Exception (onException, tryIO) -#endif -import Foreign.C (getErrno, errnoToIOError) - -#if __NHC__ -import System.Posix.Types (CPid(..)) -foreign import ccall unsafe "getpid" c_getpid :: IO CPid -#else -import System.Posix.Internals (c_getpid) -#endif - -#ifdef mingw32_HOST_OS -import System.Directory ( createDirectory ) -#else -import qualified System.Posix -#endif - --- ------------------------------------------------------------ --- * temporary files --- ------------------------------------------------------------ - --- 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 - -#if __NHC__ || __HUGS__ --- use a temporary filename that doesn't already exist. --- NB. *not* secure (we don't atomically lock the tmp file we get) -openTempFile :: FilePath -> String -> IO (FilePath, Handle) -openTempFile tmp_dir template - = do x <- getProcessID - findTempName x - where - (templateBase, templateExt) = splitExtension template - findTempName :: Int -> IO (FilePath, Handle) - findTempName x - = do let path = tmp_dir (templateBase ++ "-" ++ show x) <.> templateExt - b <- doesFileExist path - if b then findTempName (x+1) - else do hnd <- openFile path ReadWriteMode - return (path, hnd) - -openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) -openBinaryTempFile tmp_dir template - = do x <- getProcessID - findTempName x - where - (templateBase, templateExt) = splitExtension template - findTempName :: Int -> IO (FilePath, Handle) - findTempName x - = do let path = tmp_dir (templateBase ++ "-" ++ show x) <.> templateExt - b <- doesFileExist path - if b then findTempName (x+1) - else do hnd <- openBinaryFile path ReadWriteMode - return (path, hnd) - -openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) -openNewBinaryFile = openBinaryTempFile - -getProcessID :: IO Int -getProcessID = fmap fromIntegral c_getpid -#else --- This is a copy/paste of the openBinaryTempFile definition, but --- if uses 666 rather than 600 for the permissions. The base library --- needs to be changed to make this better. -openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) -openNewBinaryFile dir template = do - pid <- c_getpid - findTempName pid - 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. - (prefix,suffix) = - case break (== '.') $ reverse template of - -- First case: template contains no '.'s. Just re-reverse it. - (rev_suffix, "") -> (reverse rev_suffix, "") - -- Second case: template contains at least one '.'. Strip the - -- dot from the prefix and prepend it to the suffix (if we don't - -- do this, the unique number will get added after the '.' and - -- thus be part of the extension, which is wrong.) - (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) - -- Otherwise, something is wrong, because (break (== '.')) should - -- always return a pair with either the empty string or a string - -- beginning with '.' as the second component. - _ -> error "bug in System.IO.openTempFile" - - oflags = rw_flags .|. o_EXCL .|. o_BINARY - -#if __GLASGOW_HASKELL__ < 611 - withFilePath = withCString -#endif - - findTempName x = do - fd <- withFilePath filepath $ \ f -> - c_open f oflags 0o666 - if fd < 0 - then do - errno <- getErrno - if errno == eEXIST - then findTempName (x+1) - else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) - else do - -- TODO: We want to tell fdToHandle what the filepath is, - -- as any exceptions etc will only be able to report the - -- fd currently - h <- -#if __GLASGOW_HASKELL__ >= 609 - fdToHandle fd -#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS) - -- fdToHandle is borked on Windows with ghc-6.6.x - openFd (fromIntegral fd) Nothing False filepath - ReadWriteMode True -#else - fdToHandle (fromIntegral fd) -#endif - `onException` c_close fd - return (filepath, h) - where - filename = prefix ++ show x ++ suffix - filepath = dir `combine` filename - - -- FIXME: bits copied from System.FilePath - combine a b - | null b = a - | null a = b - | last a == pathSeparator = a ++ b - | otherwise = a ++ [pathSeparator] ++ b - --- FIXME: Should use filepath library -pathSeparator :: Char -#ifdef mingw32_HOST_OS -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif - --- FIXME: Copied from GHC.Handle -std_flags, output_flags, rw_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -rw_flags = output_flags .|. o_RDWR -#endif - -createTempDirectory :: FilePath -> String -> IO FilePath -createTempDirectory dir template = do - pid <- c_getpid - findTempName pid - where - findTempName x = do - let dirpath = dir template ++ "-" ++ show x - r <- tryIO $ mkPrivateDir dirpath - case r of - Right _ -> return dirpath - Left e | isAlreadyExistsError e -> findTempName (x+1) - | otherwise -> ioError e - -mkPrivateDir :: String -> IO () -#ifdef mingw32_HOST_OS -mkPrivateDir s = createDirectory s -#else -mkPrivateDir s = System.Posix.createDirectory s 0o700 -#endif diff --git a/cabal/cabal/Distribution/Compiler.hs b/cabal/cabal/Distribution/Compiler.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Compiler.hs +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compiler --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This has an enumeration of the various compilers that Cabal knows about. It --- also specifies the default compiler. Sadly you'll often see code that does --- case analysis on this compiler flavour enumeration like: --- --- > case compilerFlavor comp of --- > GHC -> GHC.getInstalledPackages verbosity packageDb progconf --- > JHC -> JHC.getInstalledPackages verbosity packageDb progconf --- --- Obviously it would be better to use the proper 'Compiler' abstraction --- because that would keep all the compiler-specific code together. --- Unfortunately we cannot make this change yet without breaking the --- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the --- moment we just have to live with this deficiency. If you're interested, see --- ticket #50. - -{- 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(..), - buildCompilerFlavor, - defaultCompilerFlavor, - parseCompilerFlavorCompat, - - -- * Compiler id - CompilerId(..), - ) where - -import Distribution.Version (Version(..)) - -import qualified System.Info (compilerName) -import Distribution.Text (Text(..), display) -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<>)) - -import qualified Data.Char as Char (toLower, isDigit, isAlphaNum) -import Control.Monad (when) - -data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC - | OtherCompiler String - deriving (Show, Read, Eq, Ord) - -knownCompilerFlavors :: [CompilerFlavor] -knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC] - -instance Text CompilerFlavor where - disp (OtherCompiler name) = Disp.text name - disp NHC = Disp.text "nhc98" - disp other = Disp.text (lowercase (show other)) - - parse = do - comp <- Parse.munch1 Char.isAlphaNum - when (all Char.isDigit comp) Parse.pfail - return (classifyCompilerFlavor comp) - -classifyCompilerFlavor :: String -> CompilerFlavor -classifyCompilerFlavor s = - case lookup (lowercase s) compilerMap of - Just compiler -> compiler - Nothing -> OtherCompiler s - where - compilerMap = [ (display compiler, compiler) - | compiler <- knownCompilerFlavors ] - - ---TODO: In some future release, remove 'parseCompilerFlavorCompat' and use --- ordinary 'parse'. Also add ("nhc", NHC) to the above 'compilerMap'. - --- | Like 'classifyCompilerFlavor' but compatible with the old ReadS parser. --- --- It is compatible in the sense that it accepts only the same strings, --- eg "GHC" but not "ghc". However other strings get mapped to 'OtherCompiler'. --- The point of this is that we do not allow extra valid values that would --- upset older Cabal versions that had a stricter parser however we cope with --- new values more gracefully so that we'll be able to introduce new value in --- future without breaking things so much. --- -parseCompilerFlavorCompat :: Parse.ReadP r CompilerFlavor -parseCompilerFlavorCompat = do - comp <- Parse.munch1 Char.isAlphaNum - when (all Char.isDigit comp) Parse.pfail - case lookup comp compilerMap of - Just compiler -> return compiler - Nothing -> return (OtherCompiler comp) - where - compilerMap = [ (show compiler, compiler) - | compiler <- knownCompilerFlavors - , compiler /= YHC ] - -buildCompilerFlavor :: CompilerFlavor -buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName - --- | The default compiler flavour to pick when compiling stuff. This defaults --- to the compiler used to build the Cabal lib. --- --- However if it's not a recognised compiler then it's 'Nothing' and the user --- will have to specify which compiler they want. --- -defaultCompilerFlavor :: Maybe CompilerFlavor -defaultCompilerFlavor = case buildCompilerFlavor of - OtherCompiler _ -> Nothing - _ -> Just buildCompilerFlavor - --- ------------------------------------------------------------ --- * Compiler Id --- ------------------------------------------------------------ - -data CompilerId = CompilerId CompilerFlavor Version - deriving (Eq, Ord, Read, Show) - -instance Text CompilerId where - disp (CompilerId f (Version [] _)) = disp f - disp (CompilerId f v) = disp f <> Disp.char '-' <> disp v - - parse = do - flavour <- parse - version <- (Parse.char '-' >> parse) Parse.<++ return (Version [] []) - return (CompilerId flavour version) - -lowercase :: String -> String -lowercase = map Char.toLower diff --git a/cabal/cabal/Distribution/GetOpt.hs b/cabal/cabal/Distribution/GetOpt.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/GetOpt.hs +++ /dev/null @@ -1,335 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.GetOpt --- Copyright : (c) Sven Panne 2002-2005 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Portability : portable --- --- This library provides facilities for parsing the command-line options --- in a standalone program. It is essentially a Haskell port of the GNU --- @getopt@ library. --- ------------------------------------------------------------------------------ - -{- -Sven Panne Oct. 1996 (small -changes Dec. 1997) - -Two rather obscure features are missing: The Bash 2.0 non-option hack -(if you don't already know it, you probably don't want to hear about -it...) and the recognition of long options with a single dash -(e.g. '-help' is recognised as '--help', as long as there is no short -option 'h'). - -Other differences between GNU's getopt and this implementation: - -* To enforce a coherent description of options and arguments, there - are explanation fields in the option/argument descriptor. - -* Error messages are now more informative, but no longer POSIX - compliant... :-( - -And a final Haskell advertisement: The GNU C implementation uses well -over 1100 lines, we need only 195 here, including a 46 line example! -:-) --} - --- #hide -module Distribution.GetOpt ( - -- * GetOpt - getOpt, getOpt', - usageInfo, - ArgOrder(..), - OptDescr(..), - ArgDescr(..), - - -- * Example - - -- $example -) where - -import Data.List ( isPrefixOf, intersperse, find ) - --- |What to do with options following non-options -data ArgOrder a - = RequireOrder -- ^ no option processing after first non-option - | Permute -- ^ freely intersperse options and non-options - | ReturnInOrder (String -> a) -- ^ wrap non-options into options - -{-| -Each 'OptDescr' describes a single option. - -The arguments to 'Option' are: - -* list of short option characters - -* list of long option strings (without \"--\") - -* argument descriptor - -* explanation of option for user --} -data OptDescr a = -- description of a single options: - Option [Char] -- list of short option characters - [String] -- list of long option strings (without "--") - (ArgDescr a) -- argument descriptor - String -- explanation of option for user - --- |Describes whether an option takes an argument or not, and if so --- how the argument is injected into a value of type @a@. -data ArgDescr a - = NoArg a -- ^ no argument expected - | ReqArg (String -> a) String -- ^ option requires argument - | OptArg (Maybe String -> a) String -- ^ optional argument - -data OptKind a -- kind of cmd line arg (internal use only): - = Opt a -- an option - | UnreqOpt String -- an un-recognized option - | NonOpt String -- a non-option - | EndOfOpts -- end-of-options marker (i.e. "--") - | OptErr String -- something went wrong... - --- | Return a string describing the usage of a command, derived from --- the header (first argument) and the options described by the --- second argument. -usageInfo :: String -- header - -> [OptDescr a] -- option descriptors - -> String -- nicely formatted decription of options -usageInfo header optDescr = unlines (header:table) - where (ss,ls,ds) = unzip3 [ (sepBy ", " (map (fmtShort ad) sos) - ,concatMap (fmtLong ad) (take 1 los) - ,d) - | Option sos los ad d <- optDescr ] - ssWidth = (maximum . map length) ss - lsWidth = (maximum . map length) ls - dsWidth = 30 `max` (80 - (ssWidth + lsWidth + 3)) - table = [ " " ++ padTo ssWidth so' ++ - " " ++ padTo lsWidth lo' ++ - " " ++ d' - | (so,lo,d) <- zip3 ss ls ds - , (so',lo',d') <- fmtOpt dsWidth so lo d ] - padTo n x = take n (x ++ repeat ' ') - sepBy s = concat . intersperse s - -fmtOpt :: Int -> String -> String -> String -> [(String, String, String)] -fmtOpt descrWidth so lo descr = - case wrapText descrWidth descr of - [] -> [(so,lo,"")] - (d:ds) -> (so,lo,d) : [ ("","",d') | d' <- ds ] - -fmtShort :: ArgDescr a -> Char -> String -fmtShort (NoArg _ ) so = "-" ++ [so] -fmtShort (ReqArg _ _) so = "-" ++ [so] -fmtShort (OptArg _ _) so = "-" ++ [so] - -fmtLong :: ArgDescr a -> String -> String -fmtLong (NoArg _ ) lo = "--" ++ lo -fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad -fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" - -wrapText :: Int -> String -> [String] -wrapText width = map unwords . wrap 0 [] . words - where wrap :: Int -> [String] -> [String] -> [[String]] - wrap 0 [] (w:ws) - | length w + 1 > width - = wrap (length w) [w] ws - wrap col line (w:ws) - | col + length w + 1 > width - = reverse line : wrap 0 [] (w:ws) - wrap col line (w:ws) - = let col' = col + length w + 1 - in wrap col' (w:line) ws - wrap _ [] [] = [] - wrap _ line [] = [reverse line] - -{-| -Process the command-line, and return the list of values that matched -(and those that didn\'t). The arguments are: - -* The order requirements (see 'ArgOrder') - -* The option descriptions (see 'OptDescr') - -* The actual command line arguments (presumably got from - 'System.Environment.getArgs'). - -'getOpt' returns a triple consisting of the option arguments, a list -of non-options, and a list of error messages. --} -getOpt :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String],[String]) -- (options,non-options,error messages) -getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) - where (os,xs,us,es) = getOpt' ordering optDescr args - -{-| -This is almost the same as 'getOpt', but returns a quadruple -consisting of the option arguments, a list of non-options, a list of -unrecognized options, and a list of error messages. --} -getOpt' :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) -getOpt' _ _ [] = ([],[],[],[]) -getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering - where procNextOpt (Opt o) _ = (o:os,xs,us,es) - procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) - procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) - procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) - procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) - procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) - procNextOpt EndOfOpts Permute = ([],rest,[],[]) - procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) - procNextOpt (OptErr e) _ = (os,xs,us,e:es) - - (opt,rest) = getNext arg args optDescr - (os,xs,us,es) = getOpt' ordering optDescr rest - --- take a look at the next cmd line arg and decide what to do with it -getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) -getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr -getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr -getNext a rest _ = (NonOpt a,rest) - --- handle long option -longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -longOpt ls rs optDescr = long ads arg rs - where (opt,arg) = break (=='=') ls - getWith p = [ o | o@(Option _ xs _ _) <- optDescr - , find (p opt) xs /= Nothing] - exact = getWith (==) - options = if null exact then getWith isPrefixOf else exact - ads = [ ad | Option _ _ ad _ <- options ] - optStr = ("--"++opt) - - long (_:_:_) _ rest = (errAmbig options optStr,rest) - long [NoArg a ] [] rest = (Opt a,rest) - long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) - long [ReqArg _ d] [] [] = (errReq d optStr,[]) - long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) - long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) - long [OptArg f _] [] rest = (Opt (f Nothing),rest) - long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) - long _ _ rest = (UnreqOpt ("--"++ls),rest) - --- handle short option -shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -shortOpt y ys rs optDescr = short ads ys rs - where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] - ads = [ ad | Option _ _ ad _ <- options ] - optStr = '-':[y] - - short (_:_:_) _ rest = (errAmbig options optStr,rest) - short (NoArg a :_) [] rest = (Opt a,rest) - short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) - short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) - short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) - short (ReqArg f _:_) xs rest = (Opt (f xs),rest) - short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) - short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) - short [] [] rest = (UnreqOpt optStr,rest) - short [] xs rest = (UnreqOpt (optStr++xs),rest) - --- miscellaneous error formatting - -errAmbig :: [OptDescr a] -> String -> OptKind a -errAmbig ods optStr = OptErr (usageInfo header ods) - where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" - -errReq :: String -> String -> OptKind a -errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") - -errUnrec :: String -> String -errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" - -errNoArg :: String -> OptKind a -errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") - -{- ------------------------------------------------------------------------------------------ --- and here a small and hopefully enlightening example: - -data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show - -options :: [OptDescr Flag] -options = - [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", - Option ['V','?'] ["version","release"] (NoArg Version) "show version info", - Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", - Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] - -out :: Maybe String -> Flag -out Nothing = Output "stdout" -out (Just o) = Output o - -test :: ArgOrder Flag -> [String] -> String -test order cmdline = case getOpt order options cmdline of - (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" - (_,_,errs) -> concat errs ++ usageInfo header options - where header = "Usage: foobar [OPTION...] files..." - --- example runs: --- putStr (test RequireOrder ["foo","-v"]) --- ==> options=[] args=["foo", "-v"] --- putStr (test Permute ["foo","-v"]) --- ==> options=[Verbose] args=["foo"] --- putStr (test (ReturnInOrder Arg) ["foo","-v"]) --- ==> options=[Arg "foo", Verbose] args=[] --- putStr (test Permute ["foo","--","-v"]) --- ==> options=[] args=["foo", "-v"] --- putStr (test Permute ["-?o","--name","bar","--na=baz"]) --- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] --- putStr (test Permute ["--ver","foo"]) --- ==> option `--ver' is ambiguous; could be one of: --- -v --verbose verbosely list files --- -V, -? --version, --release show version info --- Usage: foobar [OPTION...] files... --- -v --verbose verbosely list files --- -V, -? --version, --release show version info --- -o[FILE] --output[=FILE] use FILE for dump --- -n USER --name=USER only dump USER's files ------------------------------------------------------------------------------------------ --} - -{- $example - -To hopefully illuminate the role of the different data -structures, here\'s the command-line options for a (very simple) -compiler: - -> module Opts where -> -> import Distribution.GetOpt -> import Data.Maybe ( fromMaybe ) -> -> data Flag -> = Verbose | Version -> | Input String | Output String | LibDir String -> deriving Show -> -> options :: [OptDescr Flag] -> options = -> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" -> , Option ['V','?'] ["version"] (NoArg Version) "show version number" -> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE" -> , Option ['c'] [] (OptArg inp "FILE") "input FILE" -> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" -> ] -> -> inp,outp :: Maybe String -> Flag -> outp = Output . fromMaybe "stdout" -> inp = Input . fromMaybe "stdin" -> -> compilerOpts :: [String] -> IO ([Flag], [String]) -> compilerOpts argv = -> case getOpt Permute options argv of -> (o,n,[] ) -> return (o,n) -> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) -> where header = "Usage: ic [OPTION...] files..." - --} diff --git a/cabal/cabal/Distribution/InstalledPackageInfo.hs b/cabal/cabal/Distribution/InstalledPackageInfo.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/InstalledPackageInfo.hs +++ /dev/null @@ -1,294 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.InstalledPackageInfo --- Copyright : (c) The University of Glasgow 2004 --- --- Maintainer : libraries@haskell.org --- Portability : portable --- --- This is the information about an /installed/ package that --- is communicated to the @ghc-pkg@ program in order to register --- a package. @ghc-pkg@ now consumes this package format (as of version --- 6.4). This is specific to GHC at the moment. --- --- The @.cabal@ file format is for describing a package that is not yet --- installed. It has a lot of flexibility, like conditionals and dependency --- ranges. As such, that format is not at all suitable for describing a package --- that has already been built and installed. By the time we get to that stage, --- we have resolved all conditionals and resolved dependency version --- constraints to exact versions of dependent packages. So, this module defines --- the 'InstalledPackageInfo' data structure that contains all the info we keep --- about an installed package. There is a parser and pretty printer. The --- 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, - ParseResult(..), PError(..), PWarning, - emptyInstalledPackageInfo, - parseInstalledPackageInfo, - showInstalledPackageInfo, - showInstalledPackageInfoField, - fieldsInstalledPackageInfo, - ) where - -import Distribution.ParseUtils - ( FieldDescr(..), ParseResult(..), PError(..), PWarning - , simpleField, listField, parseLicenseQ - , showFields, showSingleNamedField, parseFieldsFlat - , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ - , showFilePath, showToken, boolField, parseOptVersion - , parseFreeText, showFreeText ) -import Distribution.License ( License(..) ) -import Distribution.Package - ( PackageName(..), PackageIdentifier(..), PackageId, InstalledPackageId(..) - , packageName, packageVersion ) -import qualified Distribution.Package as Package - ( Package(..) ) -import Distribution.ModuleName - ( ModuleName ) -import Distribution.Version - ( Version(..) ) -import Distribution.Text - ( Text(disp, parse) ) - --- ----------------------------------------------------------------------------- --- The InstalledPackageInfo type - -data InstalledPackageInfo_ m - = InstalledPackageInfo { - -- these parts are exactly the same as PackageDescription - installedPackageId :: InstalledPackageId, - sourcePackageId :: PackageId, - license :: License, - copyright :: String, - maintainer :: String, - author :: String, - stability :: String, - homepage :: String, - pkgUrl :: String, - synopsis :: String, - description :: String, - category :: String, - -- these parts are required by an installed package only: - exposed :: Bool, - exposedModules :: [m], - hiddenModules :: [m], - trusted :: Bool, - importDirs :: [FilePath], -- contain sources in case of Hugs - libraryDirs :: [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] - } - deriving (Read, Show) - -instance Package.Package (InstalledPackageInfo_ str) where - packageId = sourcePackageId - -type InstalledPackageInfo = InstalledPackageInfo_ ModuleName - -emptyInstalledPackageInfo :: InstalledPackageInfo_ m -emptyInstalledPackageInfo - = InstalledPackageInfo { - installedPackageId = InstalledPackageId "", - sourcePackageId = PackageIdentifier (PackageName "") noVersion, - license = AllRightsReserved, - copyright = "", - maintainer = "", - author = "", - stability = "", - homepage = "", - pkgUrl = "", - synopsis = "", - description = "", - category = "", - exposed = False, - exposedModules = [], - hiddenModules = [], - trusted = False, - importDirs = [], - libraryDirs = [], - hsLibraries = [], - extraLibraries = [], - extraGHCiLibraries= [], - includeDirs = [], - includes = [], - depends = [], - hugsOptions = [], - ccOptions = [], - ldOptions = [], - frameworkDirs = [], - frameworks = [], - haddockInterfaces = [], - haddockHTMLs = [] - } - -noVersion :: Version -noVersion = Version{ versionBranch=[], versionTags=[] } - --- ----------------------------------------------------------------------------- --- Parsing - -parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo -parseInstalledPackageInfo = - parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo - --- ----------------------------------------------------------------------------- --- Pretty-printing - -showInstalledPackageInfo :: InstalledPackageInfo -> String -showInstalledPackageInfo = showFields fieldsInstalledPackageInfo - -showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) -showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo - --- ----------------------------------------------------------------------------- --- Description of the fields, for parsing/printing - -fieldsInstalledPackageInfo :: [FieldDescr InstalledPackageInfo] -fieldsInstalledPackageInfo = basicFieldDescrs ++ installedFieldDescrs - -basicFieldDescrs :: [FieldDescr InstalledPackageInfo] -basicFieldDescrs = - [ simpleField "name" - disp parsePackageNameQ - packageName (\name pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgName=name}}) - , simpleField "version" - disp parseOptVersion - packageVersion (\ver pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgVersion=ver}}) - , simpleField "id" - disp parse - installedPackageId (\ipid pkg -> pkg{installedPackageId=ipid}) - , simpleField "license" - disp parseLicenseQ - license (\l pkg -> pkg{license=l}) - , simpleField "copyright" - showFreeText parseFreeText - copyright (\val pkg -> pkg{copyright=val}) - , simpleField "maintainer" - showFreeText parseFreeText - maintainer (\val pkg -> pkg{maintainer=val}) - , simpleField "stability" - showFreeText parseFreeText - stability (\val pkg -> pkg{stability=val}) - , simpleField "homepage" - showFreeText parseFreeText - homepage (\val pkg -> pkg{homepage=val}) - , simpleField "package-url" - showFreeText parseFreeText - pkgUrl (\val pkg -> pkg{pkgUrl=val}) - , simpleField "synopsis" - showFreeText parseFreeText - synopsis (\val pkg -> pkg{synopsis=val}) - , simpleField "description" - showFreeText parseFreeText - description (\val pkg -> pkg{description=val}) - , simpleField "category" - showFreeText parseFreeText - category (\val pkg -> pkg{category=val}) - , simpleField "author" - showFreeText parseFreeText - author (\val pkg -> pkg{author=val}) - ] - -installedFieldDescrs :: [FieldDescr InstalledPackageInfo] -installedFieldDescrs = [ - boolField "exposed" - exposed (\val pkg -> pkg{exposed=val}) - , listField "exposed-modules" - disp parseModuleNameQ - exposedModules (\xs pkg -> pkg{exposedModules=xs}) - , listField "hidden-modules" - disp parseModuleNameQ - hiddenModules (\xs pkg -> pkg{hiddenModules=xs}) - , boolField "trusted" - trusted (\val pkg -> pkg{trusted=val}) - , listField "import-dirs" - showFilePath parseFilePathQ - importDirs (\xs pkg -> pkg{importDirs=xs}) - , listField "library-dirs" - showFilePath parseFilePathQ - libraryDirs (\xs pkg -> pkg{libraryDirs=xs}) - , listField "hs-libraries" - showFilePath parseTokenQ - hsLibraries (\xs pkg -> pkg{hsLibraries=xs}) - , listField "extra-libraries" - showToken parseTokenQ - extraLibraries (\xs pkg -> pkg{extraLibraries=xs}) - , listField "extra-ghci-libraries" - showToken parseTokenQ - extraGHCiLibraries (\xs pkg -> pkg{extraGHCiLibraries=xs}) - , listField "include-dirs" - showFilePath parseFilePathQ - includeDirs (\xs pkg -> pkg{includeDirs=xs}) - , listField "includes" - showFilePath parseFilePathQ - includes (\xs pkg -> pkg{includes=xs}) - , 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}) - , listField "ld-options" - showToken parseTokenQ - ldOptions (\path pkg -> pkg{ldOptions=path}) - , listField "framework-dirs" - showFilePath parseFilePathQ - frameworkDirs (\xs pkg -> pkg{frameworkDirs=xs}) - , listField "frameworks" - showToken parseTokenQ - frameworks (\xs pkg -> pkg{frameworks=xs}) - , listField "haddock-interfaces" - showFilePath parseFilePathQ - haddockInterfaces (\xs pkg -> pkg{haddockInterfaces=xs}) - , listField "haddock-html" - showFilePath parseFilePathQ - haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs}) - ] diff --git a/cabal/cabal/Distribution/License.hs b/cabal/cabal/Distribution/License.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/License.hs +++ /dev/null @@ -1,138 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.License --- Copyright : Isaac Jones 2003-2005 --- Duncan Coutts 2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- The License datatype. For more information about these and other --- open-source licenses, you may visit . --- --- 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', 'LGPL' 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. -} - -module Distribution.License ( - License(..), - knownLicenses, - ) where - -import Distribution.Version (Version(Version)) - -import Distribution.Text (Text(..), display) -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<>)) -import qualified Data.Char as Char (isAlphaNum) - --- |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. --- -data License = - ---TODO: * remove BSD4 - - -- | GNU Public License. Source code must accompany alterations. - GPL (Maybe Version) - - -- | Lesser GPL, Less restrictive than GPL, useful for libraries. - | LGPL (Maybe Version) - - -- | 3-clause BSD license, newer, no advertising clause. Very free license. - | BSD3 - - -- | 4-clause BSD license, older, with advertising clause. You almost - -- certainly want to use the BSD3 license instead. - | BSD4 - - -- | The MIT license, similar to the BSD3. Very free license. - | MIT - - -- | Holder makes no claim to ownership, least restrictive license. - | PublicDomain - - -- | No rights are granted to others. Undistributable. Most restrictive. - | AllRightsReserved - - -- | Some other license. - | OtherLicense - - -- | Not a recognised license. - -- Allows us to deal with future extensions more gracefully. - | UnknownLicense String - deriving (Read, Show, Eq) - -knownLicenses :: [License] -knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3]) - , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3]) - , BSD3, MIT - , PublicDomain, AllRightsReserved, OtherLicense] - where - unversioned = Nothing - 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 (UnknownLicense other) = Disp.text other - disp other = Disp.text (show other) - - parse = do - name <- Parse.munch1 (\c -> Char.isAlphaNum c && c /= '-') - version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse) - return $! case (name, version :: Maybe Version) of - ("GPL", _ ) -> GPL version - ("LGPL", _ ) -> LGPL version - ("BSD3", Nothing) -> BSD3 - ("BSD4", Nothing) -> BSD4 - ("MIT", Nothing) -> MIT - ("PublicDomain", Nothing) -> PublicDomain - ("AllRightsReserved", Nothing) -> AllRightsReserved - ("OtherLicense", Nothing) -> OtherLicense - _ -> UnknownLicense $ name - ++ maybe "" (('-':) . display) version - -dispOptVersion :: Maybe Version -> Disp.Doc -dispOptVersion Nothing = Disp.empty -dispOptVersion (Just v) = Disp.char '-' <> disp v diff --git a/cabal/cabal/Distribution/Make.hs b/cabal/cabal/Distribution/Make.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Make.hs +++ /dev/null @@ -1,213 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Make --- Copyright : Martin Sjögren 2004 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is an alternative build system that delegates everything to the @make@ --- program. All the commands just end up calling @make@ with appropriate --- arguments. The intention was to allow preexisting packages that used --- makefiles to be wrapped into Cabal packages. In practice essentially all --- such packages were converted over to the \"Simple\" build system instead. --- Consequently this module is not used much and it certainly only sees cursory --- maintenance and no testing. Perhaps at some point we should stop pretending --- 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 --- assume that there is a configure script, and that after the ConfigCmd has --- been run, there is a Makefile. Further assumptions: --- --- [ConfigCmd] We assume the configure script accepts --- @--with-hc@, --- @--with-hc-pkg@, --- @--prefix@, --- @--bindir@, --- @--libdir@, --- @--libexecdir@, --- @--datadir@. --- --- [BuildCmd] We assume that the default Makefile target will build everything. --- --- [InstallCmd] We assume there is an @install@ target. Note that we assume that --- this does *not* register the package! --- --- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@. --- The @copy@ target should probably just invoke @make install@ --- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix) --- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make --- install@ directly here is that we don\'t know the value of @$(prefix)@. --- --- [SDistCmd] We assume there is a @dist@ target. --- --- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@. --- --- [UnregisterCmd] We assume there is an @unregister@ target. --- --- [HaddockCmd] We assume there is a @docs@ or @doc@ target. - - --- copy : --- $(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(..), - defaultMain, defaultMainArgs, defaultMainNoRead - ) where - --- local -import Distribution.Compat.Exception -import Distribution.Package --must not specify imports, since we're exporting moule. -import Distribution.Simple.Program(defaultProgramConfiguration) -import Distribution.PackageDescription -import Distribution.Simple.Setup -import Distribution.Simple.Command - -import Distribution.Simple.Utils (rawSystemExit, cabalVersion) - -import Distribution.License (License(..)) -import Distribution.Version - ( Version(..) ) -import Distribution.Text - ( display ) - -import System.Environment (getArgs, getProgName) -import Data.List (intersperse) -import System.Exit - -defaultMain :: IO () -defaultMain = getArgs >>= defaultMainArgs - -defaultMainArgs :: [String] -> IO () -defaultMainArgs = defaultMainHelper - -{-# DEPRECATED defaultMainNoRead "it ignores its PackageDescription arg" #-} -defaultMainNoRead :: PackageDescription -> IO () -defaultMainNoRead = const defaultMain - -defaultMainHelper :: [String] -> IO () -defaultMainHelper args = - case commandsRun globalCommand commands args of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (flags, commandParse) -> - case commandParse of - _ | fromFlag (globalVersion flags) -> printVersion - | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action - - where - printHelp help = getProgName >>= putStr . help - printOptionsList = putStr . unlines - printErrors errs = do - putStr (concat (intersperse "\n" errs)) - exitWith (ExitFailure 1) - printNumericVersion = putStrLn $ display cabalVersion - printVersion = putStrLn $ "Cabal library version " - ++ display cabalVersion - - progs = defaultProgramConfiguration - commands = - [configureCommand progs `commandAddAction` configureAction - ,buildCommand progs `commandAddAction` buildAction - ,installCommand `commandAddAction` installAction - ,copyCommand `commandAddAction` copyAction - ,haddockCommand `commandAddAction` haddockAction - ,cleanCommand `commandAddAction` cleanAction - ,sdistCommand `commandAddAction` sdistAction - ,registerCommand `commandAddAction` registerAction - ,unregisterCommand `commandAddAction` unregisterAction - ] - -configureAction :: ConfigFlags -> [String] -> IO () -configureAction flags args = do - noExtraFlags args - let verbosity = fromFlag (configVerbosity flags) - rawSystemExit verbosity "sh" $ - "configure" - : configureArgs backwardsCompatHack flags - where backwardsCompatHack = True - -copyAction :: CopyFlags -> [String] -> IO () -copyAction flags args = do - noExtraFlags args - let destArgs = case fromFlag $ copyDest flags of - NoCopyDest -> ["install"] - CopyTo path -> ["copy", "destdir=" ++ path] - rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs - -installAction :: InstallFlags -> [String] -> IO () -installAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"] - rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"] - -haddockAction :: HaddockFlags -> [String] -> IO () -haddockAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"] - `catchIO` \_ -> - rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] - -buildAction :: BuildFlags -> [String] -> IO () -buildAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ buildVerbosity flags) "make" [] - -cleanAction :: CleanFlags -> [String] -> IO () -cleanAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"] - -sdistAction :: SDistFlags -> [String] -> IO () -sdistAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"] - -registerAction :: RegisterFlags -> [String] -> IO () -registerAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"] - -unregisterAction :: RegisterFlags -> [String] -> IO () -unregisterAction flags args = do - noExtraFlags args - rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"] diff --git a/cabal/cabal/Distribution/ModuleName.hs b/cabal/cabal/Distribution/ModuleName.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/ModuleName.hs +++ /dev/null @@ -1,130 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.ModuleName --- Copyright : Duncan Coutts 2008 --- --- 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, - components, - toFilePath, - main, - simple, - ) where - -import Distribution.Text - ( Text(..) ) - -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 - ( intersperse ) - --- | A valid Haskell module name. --- -newtype ModuleName = ModuleName [String] - deriving (Eq, Ord, Read, Show) - -instance Text ModuleName where - disp (ModuleName ms) = - Disp.hcat (intersperse (Disp.char '.') (map Disp.text ms)) - - parse = do - ms <- Parse.sepBy1 component (Parse.char '.') - return (ModuleName ms) - - where - component = do - c <- Parse.satisfy Char.isUpper - cs <- Parse.munch validModuleChar - return (c:cs) - -validModuleChar :: Char -> Bool -validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\'' - -validModuleComponent :: String -> Bool -validModuleComponent [] = False -validModuleComponent (c:cs) = Char.isUpper c - && all validModuleChar cs - -{-# DEPRECATED simple "use ModuleName.fromString instead" #-} -simple :: String -> ModuleName -simple str = ModuleName [str] - --- | Construct a 'ModuleName' from a valid module name 'String'. --- --- This is just a convenience function intended for valid module strings. It is --- an error if it is used with a string that is not a valid module name. If you --- are parsing user input then use 'Distribution.Text.simpleParse' instead. --- -fromString :: String -> ModuleName -fromString string - | all validModuleComponent components' = ModuleName components' - | otherwise = error badName - - where - components' = split string - badName = "ModuleName.fromString: invalid module name " ++ show string - - split cs = case break (=='.') cs of - (chunk,[]) -> chunk : [] - (chunk,_:rest) -> chunk : split rest - --- | The module name @Main@. --- -main :: ModuleName -main = ModuleName ["Main"] - --- | The individual components of a hierarchical module name. For example --- --- > components (fromString "A.B.C") = ["A", "B", "C"] --- -components :: ModuleName -> [String] -components (ModuleName ms) = ms - --- | Convert a module name to a file path, but without any file extension. --- For example: --- --- > toFilePath (fromString "A.B.C") = "A/B/C" --- -toFilePath :: ModuleName -> FilePath -toFilePath = concat . intersperse [pathSeparator] . components diff --git a/cabal/cabal/Distribution/Package.hs b/cabal/cabal/Distribution/Package.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Package.hs +++ /dev/null @@ -1,193 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Package --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Defines a package identifier along with a parser and pretty printer for it. --- 'PackageIdentifier's consist of a name and an exact version. It also defines --- 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(..), - PackageIdentifier(..), - PackageId, - - -- * Installed package identifiers - InstalledPackageId(..), - - -- * Package source dependencies - Dependency(..), - thisPackageVersion, - notThisPackageVersion, - simplifyDependency, - - -- * Package classes - Package(..), packageName, packageVersion, - PackageFixedDeps(..), - ) where - -import Distribution.Version - ( Version(..), VersionRange, anyVersion, thisVersion - , notThisVersion, simplifyVersionRange ) - -import Distribution.Text (Text(..)) -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP ((<++)) -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<>), (<+>), text) -import qualified Data.Char as Char ( isDigit, isAlphaNum ) -import Data.List ( intersperse ) - -newtype PackageName = PackageName String - deriving (Read, Show, Eq, Ord) - -instance Text PackageName where - disp (PackageName n) = Disp.text n - parse = do - ns <- Parse.sepBy1 component (Parse.char '-') - return (PackageName (concat (intersperse "-" ns))) - where - component = do - cs <- Parse.munch1 Char.isAlphaNum - if all Char.isDigit cs then Parse.pfail else return cs - -- each component must contain an alphabetic character, to avoid - -- ambiguity in identifiers like foo-1 (the 1 is the version number). - --- | Type alias so we can use the shorter name PackageId. -type PackageId = PackageIdentifier - --- | The name and version of a package. -data PackageIdentifier - = PackageIdentifier { - pkgName :: PackageName, -- ^The name of this package, eg. foo - pkgVersion :: Version -- ^the version of this package, eg 1.2 - } - deriving (Read, Show, Eq, Ord) - -instance Text PackageIdentifier where - disp (PackageIdentifier n v) = case v of - Version [] _ -> disp n -- if no version, don't show version. - _ -> disp n <> Disp.char '-' <> disp v - - parse = do - n <- parse - v <- (Parse.char '-' >> parse) <++ return (Version [] []) - return (PackageIdentifier n v) - --- ------------------------------------------------------------ --- * Installed Package Ids --- ------------------------------------------------------------ - --- | An InstalledPackageId uniquely identifies an instance of an installed package. --- There can be at most one package with a given 'InstalledPackageId' --- in a package database, or overlay of databases. --- -newtype InstalledPackageId = InstalledPackageId String - deriving (Read,Show,Eq,Ord) - -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` ":-_." - --- ------------------------------------------------------------ --- * Package source dependencies --- ------------------------------------------------------------ - --- | Describes a dependency on a source package (API) --- -data Dependency = Dependency PackageName VersionRange - deriving (Read, Show, Eq) - -instance Text Dependency where - disp (Dependency name ver) = - disp name <+> disp ver - - parse = do name <- parse - Parse.skipSpaces - ver <- parse <++ return anyVersion - Parse.skipSpaces - return (Dependency name ver) - -thisPackageVersion :: PackageIdentifier -> Dependency -thisPackageVersion (PackageIdentifier n v) = - Dependency n (thisVersion v) - -notThisPackageVersion :: PackageIdentifier -> Dependency -notThisPackageVersion (PackageIdentifier n v) = - Dependency n (notThisVersion v) - --- | Simplify the 'VersionRange' expression in a 'Dependency'. --- See 'simplifyVersionRange'. --- -simplifyDependency :: Dependency -> Dependency -simplifyDependency (Dependency name range) = - Dependency name (simplifyVersionRange range) - --- | Class of things that have a 'PackageIdentifier' --- --- Types in this class are all notions of a package. This allows us to have --- different types for the different phases that packages go though, from --- simple name\/id, package description, configured or installed packages. --- --- Not all kinds of packages can be uniquely identified by a --- 'PackageIdentifier'. In particular, installed packages cannot, there may be --- many installed instances of the same source package. --- -class Package pkg where - packageId :: pkg -> PackageIdentifier - -packageName :: Package pkg => pkg -> PackageName -packageName = pkgName . packageId - -packageVersion :: Package pkg => pkg -> Version -packageVersion = pkgVersion . packageId - -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. --- -class Package pkg => PackageFixedDeps pkg where - depends :: pkg -> [PackageIdentifier] diff --git a/cabal/cabal/Distribution/PackageDescription.hs b/cabal/cabal/Distribution/PackageDescription.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/PackageDescription.hs +++ /dev/null @@ -1,895 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defines the data structure for the @.cabal@ file format. There are --- several parts to this structure. It has top level info and then 'Library', --- 'Executable', and 'TestSuite' sections each of which have associated --- 'BuildInfo' data that's used to build the library, exe, or test. To further --- complicate things there is both a 'PackageDescription' and a --- 'GenericPackageDescription'. This distinction relates to cabal --- configurations. When we initially read a @.cabal@ file we get a --- 'GenericPackageDescription' which has all the conditional sections. --- Before actually building a package we have to decide --- on each conditional. Once we've done that we get a 'PackageDescription'. --- It was done this way initially to avoid breaking too much stuff when the --- feature was introduced. It could probably do with being rationalised at some --- point to make it simpler. - -{- 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(..), - emptyPackageDescription, - specVersion, - descCabalVersion, - BuildType(..), - knownBuildTypes, - - -- ** Libraries - Library(..), - emptyLibrary, - withLib, - hasLibs, - libModules, - - -- ** Executables - Executable(..), - emptyExecutable, - withExe, - hasExes, - exeModules, - - -- * Tests - TestSuite(..), - TestSuiteInterface(..), - TestType(..), - testType, - knownTestTypes, - emptyTestSuite, - hasTests, - withTest, - testModules, - enabledTests, - - -- * Build information - BuildInfo(..), - emptyBuildInfo, - allBuildInfo, - allLanguages, - allExtensions, - usedExtensions, - hcOptions, - - -- ** Supplementary build information - HookedBuildInfo, - emptyHookedBuildInfo, - updatePackageDescription, - - -- * package configuration - GenericPackageDescription(..), - Flag(..), FlagName(..), FlagAssignment, - CondTree(..), ConfVar(..), Condition(..), - - -- * Source repositories - SourceRepo(..), - RepoKind(..), - RepoType(..), - knownRepoTypes, - ) where - -import Data.List (nub, intersperse) -import Data.Maybe (maybeToList) -import Data.Monoid (Monoid(mempty, mappend)) -import Control.Monad (MonadPlus(mplus)) -import Text.PrettyPrint.HughesPJ as Disp -import qualified Distribution.Compat.ReadP as Parse -import qualified Data.Char as Char (isAlphaNum, isDigit, toLower) - -import Distribution.Package - ( PackageName(PackageName), PackageIdentifier(PackageIdentifier) - , Dependency, Package(..) ) -import Distribution.ModuleName ( ModuleName ) -import Distribution.Version - ( Version(Version), VersionRange, anyVersion, orLaterVersion - , asVersionIntervals, LowerBound(..) ) -import Distribution.License (License(AllRightsReserved)) -import Distribution.Compiler (CompilerFlavor) -import Distribution.System (OS, Arch) -import Distribution.Text - ( Text(..), display ) -import Language.Haskell.Extension - ( Language, Extension ) - --- ----------------------------------------------------------------------------- --- The PackageDescription type - --- | This data type is the internal representation of the file @pkg.cabal@. --- It contains two kinds of information about the package: information --- which is needed for all packages, such as the package name and version, and --- information which is needed for the simple build system only, such as --- the compiler options and library name. --- -data PackageDescription - = PackageDescription { - -- the following are required by all packages: - package :: PackageIdentifier, - license :: License, - licenseFile :: FilePath, - copyright :: String, - maintainer :: String, - author :: String, - stability :: String, - testedWith :: [(CompilerFlavor,VersionRange)], - homepage :: String, - pkgUrl :: String, - bugReports :: String, - sourceRepos :: [SourceRepo], - synopsis :: String, -- ^A one-line summary of this package - description :: String, -- ^A more verbose description of this package - category :: String, - customFieldsPD :: [(String,String)], -- ^Custom fields starting - -- with x-, stored in a - -- simple assoc-list. - buildDepends :: [Dependency], - -- | The version of the Cabal spec that this package description uses. - -- For historical reasons this is specified with a version range but - -- only ranges of the form @>= v@ make sense. We are in the process of - -- transitioning to specifying just a single version, not a range. - specVersionRaw :: Either Version VersionRange, - buildType :: Maybe BuildType, - -- components - library :: Maybe Library, - executables :: [Executable], - testSuites :: [TestSuite], - dataFiles :: [FilePath], - dataDir :: FilePath, - extraSrcFiles :: [FilePath], - extraTmpFiles :: [FilePath] - } - deriving (Show, Read, Eq) - -instance Package PackageDescription where - packageId = package - --- | The version of the Cabal spec that this package should be interpreted --- against. --- --- Historically we used a version range but we are switching to using a single --- version. Currently we accept either. This function converts into a single --- version by ignoring upper bounds in the version range. --- -specVersion :: PackageDescription -> Version -specVersion pkg = case specVersionRaw pkg of - Left version -> version - Right versionRange -> case asVersionIntervals versionRange of - [] -> Version [0] [] - ((LowerBound version _, _):_) -> version - --- | The range of versions of the Cabal tools that this package is intended to --- work with. --- --- This function is deprecated and should not be used for new purposes, only to --- support old packages that rely on the old interpretation. --- -descCabalVersion :: PackageDescription -> VersionRange -descCabalVersion pkg = case specVersionRaw pkg of - Left version -> orLaterVersion version - Right versionRange -> versionRange -{-# DEPRECATED descCabalVersion "Use specVersion instead" #-} - -emptyPackageDescription :: PackageDescription -emptyPackageDescription - = PackageDescription { - package = PackageIdentifier (PackageName "") - (Version [] []), - license = AllRightsReserved, - licenseFile = "", - specVersionRaw = Right anyVersion, - buildType = Nothing, - copyright = "", - maintainer = "", - author = "", - stability = "", - testedWith = [], - buildDepends = [], - homepage = "", - pkgUrl = "", - bugReports = "", - sourceRepos = [], - synopsis = "", - description = "", - category = "", - customFieldsPD = [], - library = Nothing, - executables = [], - testSuites = [], - dataFiles = [], - dataDir = "", - extraSrcFiles = [], - extraTmpFiles = [] - } - --- | The type of build system used by this package. -data BuildType - = Simple -- ^ calls @Distribution.Simple.defaultMain@ - | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, - -- which invokes @configure@ to generate additional build - -- information used by later phases. - | Make -- ^ calls @Distribution.Make.defaultMain@ - | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) - | UnknownBuildType String - -- ^ a package that uses an unknown build type cannot actually - -- be built. Doing it this way rather than just giving a - -- parse error means we get better error messages and allows - -- you to inspect the rest of the package description. - deriving (Show, Read, Eq) - -knownBuildTypes :: [BuildType] -knownBuildTypes = [Simple, Configure, Make, Custom] - -instance Text BuildType where - disp (UnknownBuildType other) = Disp.text other - disp other = Disp.text (show other) - - parse = do - name <- Parse.munch1 Char.isAlphaNum - return $ case name of - "Simple" -> Simple - "Configure" -> Configure - "Custom" -> Custom - "Make" -> Make - _ -> UnknownBuildType name - --- --------------------------------------------------------------------------- --- The Library type - -data Library = Library { - exposedModules :: [ModuleName], - libExposed :: Bool, -- ^ Is the lib to be exposed by default? - libBuildInfo :: BuildInfo - } - deriving (Show, Eq, Read) - -instance Monoid Library where - mempty = Library { - exposedModules = mempty, - libExposed = True, - libBuildInfo = mempty - } - mappend a b = Library { - exposedModules = combine exposedModules, - libExposed = libExposed a && libExposed b, -- so False propagates - libBuildInfo = combine libBuildInfo - } - where combine field = field a `mappend` field b - -emptyLibrary :: Library -emptyLibrary = mempty - --- |does this package have any libraries? -hasLibs :: PackageDescription -> Bool -hasLibs p = maybe False (buildable . libBuildInfo) (library p) - --- |'Maybe' version of 'hasLibs' -maybeHasLibs :: PackageDescription -> Maybe Library -maybeHasLibs p = - library p >>= \lib -> if buildable (libBuildInfo lib) - then Just lib - else Nothing - --- |If the package description has a library section, call the given --- function with the library build info as argument. -withLib :: PackageDescription -> (Library -> IO ()) -> IO () -withLib pkg_descr f = - maybe (return ()) f (maybeHasLibs pkg_descr) - --- | Get all the module names from the library (exposed and internal modules) -libModules :: Library -> [ModuleName] -libModules lib = exposedModules lib - ++ otherModules (libBuildInfo lib) - --- --------------------------------------------------------------------------- --- The Executable type - -data Executable = Executable { - exeName :: String, - modulePath :: FilePath, - buildInfo :: BuildInfo - } - deriving (Show, Read, Eq) - -instance Monoid Executable where - mempty = Executable { - exeName = mempty, - modulePath = mempty, - buildInfo = mempty - } - mappend a b = Executable{ - exeName = combine' exeName, - modulePath = combine modulePath, - buildInfo = combine buildInfo - } - where combine field = field a `mappend` field b - combine' field = case (field a, field b) of - ("","") -> "" - ("", x) -> x - (x, "") -> x - (x, y) -> error $ "Ambiguous values for executable field: '" - ++ x ++ "' and '" ++ y ++ "'" - -emptyExecutable :: Executable -emptyExecutable = mempty - --- |does this package have any executables? -hasExes :: PackageDescription -> Bool -hasExes p = any (buildable . buildInfo) (executables p) - --- | Perform the action on each buildable 'Executable' in the package --- description. -withExe :: PackageDescription -> (Executable -> IO ()) -> IO () -withExe pkg_descr f = - sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)] - --- | Get all the module names from an exe -exeModules :: Executable -> [ModuleName] -exeModules exe = otherModules (buildInfo exe) - --- --------------------------------------------------------------------------- --- The TestSuite type - --- | A \"test-suite\" stanza in a cabal file. --- -data TestSuite = TestSuite { - testName :: String, - testInterface :: TestSuiteInterface, - testBuildInfo :: BuildInfo, - testEnabled :: Bool - -- TODO: By having a 'testEnabled' field in the PackageDescription, we - -- are mixing build status information (i.e., arguments to 'configure') - -- with static package description information. This is undesirable, but - -- a better solution is waiting on the next overhaul to the - -- GenericPackageDescription -> PackageDescription resolution process. - } - deriving (Show, Read, Eq) - --- | The test suite interfaces that are currently defined. Each test suite must --- specify which interface it supports. --- --- More interfaces may be defined in future, either new revisions or totally --- new interfaces. --- -data TestSuiteInterface = - - -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form - -- of an executable. It returns a zero exit code for success, non-zero for - -- failure. The stdout and stderr channels may be logged. It takes no - -- command line parameters and nothing on stdin. - -- - TestSuiteExeV10 Version FilePath - - -- | Test interface \"detailed-0.9\". The test-suite takes the form of a - -- library containing a designated module that exports \"tests :: [Test]\". - -- - | TestSuiteLibV09 Version ModuleName - - -- | A test suite that does not conform to one of the above interfaces for - -- the given reason (e.g. unknown test type). - -- - | TestSuiteUnsupported TestType - deriving (Eq, Read, Show) - -instance Monoid TestSuite where - mempty = TestSuite { - testName = mempty, - testInterface = mempty, - testBuildInfo = mempty, - testEnabled = False - } - - mappend a b = TestSuite { - testName = combine' testName, - testInterface = combine testInterface, - testBuildInfo = combine testBuildInfo, - testEnabled = if testEnabled a then True else testEnabled b - } - where combine field = field a `mappend` field b - combine' f = case (f a, f b) of - ("", x) -> x - (x, "") -> x - (x, y) -> error "Ambiguous values for test field: '" - ++ x ++ "' and '" ++ y ++ "'" - -instance Monoid TestSuiteInterface where - mempty = TestSuiteUnsupported (TestTypeUnknown mempty (Version [] [])) - mappend a (TestSuiteUnsupported _) = a - mappend _ b = b - -emptyTestSuite :: TestSuite -emptyTestSuite = mempty - --- | Does this package have any test suites? -hasTests :: PackageDescription -> Bool -hasTests = any (buildable . testBuildInfo) . testSuites - --- | Get all the enabled test suites from a package. -enabledTests :: PackageDescription -> [TestSuite] -enabledTests = filter testEnabled . testSuites - --- | Perform an action on each buildable 'TestSuite' in a package. -withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO () -withTest pkg_descr f = - mapM_ f $ filter (buildable . testBuildInfo) $ enabledTests pkg_descr - --- | Get all the module names from a test suite. -testModules :: TestSuite -> [ModuleName] -testModules test = (case testInterface test of - TestSuiteLibV09 _ m -> [m] - _ -> []) - ++ otherModules (testBuildInfo test) - --- | The \"test-type\" field in the test suite stanza. --- -data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\" - | TestTypeLib Version -- ^ \"type: detailed-x.y\" - | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\" - deriving (Show, Read, Eq) - -knownTestTypes :: [TestType] -knownTestTypes = [ TestTypeExe (Version [1,0] []) - -- 'detailed-0.9' test type is disabled in Cabal-1.10.x - -- needs more work on the details of the library interface - {- , TestTypeLib (Version [0,9] []) -} ] - -instance Text TestType where - disp (TestTypeExe ver) = text "exitcode-stdio-" <> disp ver - disp (TestTypeLib ver) = text "detailed-" <> disp ver - disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver - - parse = do - cs <- Parse.sepBy1 component (Parse.char '-') - _ <- Parse.char '-' - ver <- parse - let name = concat (intersperse "-" cs) - return $! case lowercase name of - "exitcode-stdio" -> TestTypeExe ver - "detailed" -> TestTypeLib ver - _ -> TestTypeUnknown name ver - - where - component = do - cs <- Parse.munch1 Char.isAlphaNum - if all Char.isDigit cs then Parse.pfail else return cs - -- each component must contain an alphabetic character, to avoid - -- ambiguity in identifiers like foo-1 (the 1 is the version number). - -testType :: TestSuite -> TestType -testType test = case testInterface test of - TestSuiteExeV10 ver _ -> TestTypeExe ver - TestSuiteLibV09 ver _ -> TestTypeLib ver - TestSuiteUnsupported testtype -> testtype - --- --------------------------------------------------------------------------- --- The BuildInfo type - --- Consider refactoring into executable and library versions. -data BuildInfo = BuildInfo { - buildable :: Bool, -- ^ component is buildable here - buildTools :: [Dependency], -- ^ tools needed to build this bit - cppOptions :: [String], -- ^ options for pre-processing Haskell code - ccOptions :: [String], -- ^ options for C compiler - ldOptions :: [String], -- ^ options for linker - pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used - frameworks :: [String], -- ^support frameworks for Mac OS X - cSources :: [FilePath], - hsSourceDirs :: [FilePath], -- ^ where to look for the haskell module hierarchy - otherModules :: [ModuleName], -- ^ non-exposed or non-main modules - - defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified - otherLanguages :: [Language], -- ^ other languages used within the package - defaultExtensions :: [Extension], -- ^ language extensions used by all modules - otherExtensions :: [Extension], -- ^ other language extensions used within the package - oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions' - - extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package - 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], - customFieldsBI :: [(String,String)], -- ^Custom fields starting - -- with x-, stored in a - -- simple assoc-list. - targetBuildDepends :: [Dependency] -- ^ Dependencies specific to a library or executable target - } - deriving (Show,Read,Eq) - -instance Monoid BuildInfo where - mempty = BuildInfo { - buildable = True, - buildTools = [], - cppOptions = [], - ccOptions = [], - ldOptions = [], - pkgconfigDepends = [], - frameworks = [], - cSources = [], - hsSourceDirs = [], - otherModules = [], - defaultLanguage = Nothing, - otherLanguages = [], - defaultExtensions = [], - otherExtensions = [], - oldExtensions = [], - extraLibs = [], - extraLibDirs = [], - includeDirs = [], - includes = [], - installIncludes = [], - options = [], - ghcProfOptions = [], - ghcSharedOptions = [], - customFieldsBI = [], - targetBuildDepends = [] - } - mappend a b = BuildInfo { - buildable = buildable a && buildable b, - buildTools = combine buildTools, - cppOptions = combine cppOptions, - ccOptions = combine ccOptions, - ldOptions = combine ldOptions, - pkgconfigDepends = combine pkgconfigDepends, - frameworks = combineNub frameworks, - cSources = combineNub cSources, - hsSourceDirs = combineNub hsSourceDirs, - otherModules = combineNub otherModules, - defaultLanguage = combineMby defaultLanguage, - otherLanguages = combineNub otherLanguages, - defaultExtensions = combineNub defaultExtensions, - otherExtensions = combineNub otherExtensions, - oldExtensions = combineNub oldExtensions, - extraLibs = combine extraLibs, - extraLibDirs = combineNub extraLibDirs, - includeDirs = combineNub includeDirs, - includes = combineNub includes, - installIncludes = combineNub installIncludes, - options = combine options, - ghcProfOptions = combine ghcProfOptions, - ghcSharedOptions = combine ghcSharedOptions, - customFieldsBI = combine customFieldsBI, - targetBuildDepends = combineNub targetBuildDepends - } - where - combine field = field a `mappend` field b - combineNub field = nub (combine field) - combineMby field = field b `mplus` field a - -emptyBuildInfo :: BuildInfo -emptyBuildInfo = mempty - --- | The 'BuildInfo' for the library (if there is one and it's buildable), and --- all buildable executables and test suites. Useful for gathering dependencies. -allBuildInfo :: PackageDescription -> [BuildInfo] -allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr] - , let bi = libBuildInfo lib - , buildable bi ] - ++ [ bi | exe <- executables pkg_descr - , let bi = buildInfo exe - , buildable bi ] - ++ [ bi | tst <- testSuites pkg_descr - , let bi = testBuildInfo tst - , buildable bi - , testEnabled tst ] - --FIXME: many of the places where this is used, we actually want to look at - -- unbuildable bits too, probably need separate functions - --- | The 'Language's used by this component --- -allLanguages :: BuildInfo -> [Language] -allLanguages bi = maybeToList (defaultLanguage bi) - ++ otherLanguages bi - --- | The 'Extension's that are used somewhere by this component --- -allExtensions :: BuildInfo -> [Extension] -allExtensions bi = usedExtensions bi - ++ otherExtensions bi - --- | The 'Extensions' that are used by all modules in this component --- -usedExtensions :: BuildInfo -> [Extension] -usedExtensions bi = oldExtensions bi - ++ defaultExtensions bi - -type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)]) - -emptyHookedBuildInfo :: HookedBuildInfo -emptyHookedBuildInfo = (Nothing, []) - --- |Select options for a particular Haskell compiler. -hcOptions :: CompilerFlavor -> BuildInfo -> [String] -hcOptions hc bi = [ opt | (hc',opts) <- options bi - , hc' == hc - , opt <- opts ] - --- ------------------------------------------------------------ --- * Source repos --- ------------------------------------------------------------ - --- | Information about the source revision control system for a package. --- --- When specifying a repo it is useful to know the meaning or intention of the --- information as doing so enables automation. There are two obvious common --- purposes: one is to find the repo for the latest development version, the --- other is to find the repo for this specific release. The 'ReopKind' --- specifies which one we mean (or another custom one). --- --- A package can specify one or the other kind or both. Most will specify just --- a head repo but some may want to specify a repo to reconstruct the sources --- for this package release. --- --- The required information is the 'RepoType' which tells us if it's using --- 'Darcs', 'Git' for example. The 'repoLocation' and other details are --- interpreted according to the repo type. --- -data SourceRepo = SourceRepo { - -- | The kind of repo. This field is required. - repoKind :: RepoKind, - - -- | The type of the source repository system for this repo, eg 'Darcs' or - -- 'Git'. This field is required. - repoType :: Maybe RepoType, - - -- | The location of the repository. For most 'RepoType's this is a URL. - -- This field is required. - repoLocation :: Maybe String, - - -- | 'CVS' can put multiple \"modules\" on one server and requires a - -- module name in addition to the location to identify a particular repo. - -- Logically this is part of the location but unfortunately has to be - -- specified separately. This field is required for the 'CVS' 'RepoType' and - -- should not be given otherwise. - repoModule :: Maybe String, - - -- | The name or identifier of the branch, if any. Many source control - -- systems have the notion of multiple branches in a repo that exist in the - -- same location. For example 'Git' and 'CVS' use this while systems like - -- 'Darcs' use different locations for different branches. This field is - -- optional but should be used if necessary to identify the sources, - -- especially for the 'RepoThis' repo kind. - repoBranch :: Maybe String, - - -- | The tag identify a particular state of the repository. This should be - -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind. - -- - repoTag :: Maybe String, - - -- | Some repositories contain multiple projects in different subdirectories - -- This field specifies the subdirectory where this packages sources can be - -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted - -- relative to the root of the repository. This field is optional. If not - -- given the default is \".\" ie no subdirectory. - repoSubdir :: Maybe FilePath -} - deriving (Eq, Read, Show) - --- | What this repo info is for, what it represents. --- -data RepoKind = - -- | The repository for the \"head\" or development version of the project. - -- This repo is where we should track the latest development activity or - -- the usual repo people should get to contribute patches. - RepoHead - - -- | The repository containing the sources for this exact package version - -- or release. For this kind of repo a tag should be given to give enough - -- information to re-create the exact sources. - | RepoThis - - | RepoKindUnknown String - deriving (Eq, Ord, Read, Show) - --- | An enumeration of common source control systems. The fields used in the --- 'SourceRepo' depend on the type of repo. The tools and methods used to --- obtain and track the repo depend on the repo type. --- -data RepoType = Darcs | Git | SVN | CVS - | Mercurial | GnuArch | Bazaar | Monotone - | OtherRepoType String - deriving (Eq, Ord, Read, Show) - -knownRepoTypes :: [RepoType] -knownRepoTypes = [Darcs, Git, SVN, CVS - ,Mercurial, GnuArch, Bazaar, Monotone] - -repoTypeAliases :: RepoType -> [String] -repoTypeAliases Bazaar = ["bzr"] -repoTypeAliases Mercurial = ["hg"] -repoTypeAliases GnuArch = ["arch"] -repoTypeAliases _ = [] - -instance Text RepoKind where - disp RepoHead = Disp.text "head" - disp RepoThis = Disp.text "this" - disp (RepoKindUnknown other) = Disp.text other - - parse = do - name <- ident - return $ case lowercase name of - "head" -> RepoHead - "this" -> RepoThis - _ -> RepoKindUnknown name - -instance Text RepoType where - disp (OtherRepoType other) = Disp.text other - disp other = Disp.text (lowercase (show other)) - parse = fmap classifyRepoType ident - -classifyRepoType :: String -> RepoType -classifyRepoType s = - case lookup (lowercase s) repoTypeMap of - Just repoType' -> repoType' - Nothing -> OtherRepoType s - where - repoTypeMap = [ (name, repoType') - | repoType' <- knownRepoTypes - , name <- display repoType' : repoTypeAliases repoType' ] - -ident :: Parse.ReadP r String -ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') - -lowercase :: String -> String -lowercase = map Char.toLower - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - -updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription -updatePackageDescription (mb_lib_bi, exe_bi) p - = p{ executables = updateExecutables exe_bi (executables p) - , library = updateLibrary mb_lib_bi (library p) - } - where - updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library - updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib}) - updateLibrary Nothing mb_lib = mb_lib - updateLibrary (Just _) Nothing = Nothing - - updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)] - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^list with exeNames updated - updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' - - updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo) - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^libst with exeName updated - updateExecutable _ [] = [] - updateExecutable exe_bi'@(name,bi) (exe:exes) - | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes - | otherwise = exe : updateExecutable exe_bi' exes - --- --------------------------------------------------------------------------- --- The GenericPackageDescription type - -data GenericPackageDescription = - GenericPackageDescription { - packageDescription :: PackageDescription, - genPackageFlags :: [Flag], - condLibrary :: Maybe (CondTree ConfVar [Dependency] Library), - condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)], - condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] - } - deriving (Show, Eq) - -instance Package GenericPackageDescription where - packageId = packageId . packageDescription - ---TODO: make PackageDescription an instance of Text. - --- | A flag can represent a feature to be included, or a way of linking --- a target against its dependencies, or in fact whatever you can think of. -data Flag = MkFlag - { flagName :: FlagName - , flagDescription :: String - , flagDefault :: Bool - , flagManual :: Bool - } - deriving (Show, Eq) - --- | A 'FlagName' is the name of a user-defined configuration flag -newtype FlagName = FlagName String - deriving (Eq, Ord, Show, Read) - --- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to --- 'Bool' flag values. It represents the flags chosen by the user or --- discovered during configuration. For example @--flags=foo --flags=-bar@ --- becomes @[("foo", True), ("bar", False)]@ --- -type FlagAssignment = [(FlagName, Bool)] - --- | A @ConfVar@ represents the variable type used. -data ConfVar = OS OS - | Arch Arch - | Flag FlagName - | Impl CompilerFlavor VersionRange - deriving (Eq, Show) - ---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 - | CNot (Condition c) - | COr (Condition c) (Condition c) - | CAnd (Condition c) (Condition c) - deriving (Show, Eq) - ---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] - -data CondTree v c a = CondNode - { condTreeData :: a - , condTreeConstraints :: c - , condTreeComponents :: [( Condition v - , CondTree v c a - , Maybe (CondTree v c a))] - } - deriving (Show, Eq) - ---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) diff --git a/cabal/cabal/Distribution/PackageDescription/Check.hs b/cabal/cabal/Distribution/PackageDescription/Check.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/PackageDescription/Check.hs +++ /dev/null @@ -1,1441 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.Check --- Copyright : Lennart Kolmodin 2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This has code for checking for various problems in packages. There is one --- set of checks that just looks at a 'PackageDescription' in isolation and --- another set of checks that also looks at files in the package. Some of the --- checks are basic sanity checks, others are portability standards that we'd --- like to encourage. There is a 'PackageCheck' type that distinguishes the --- 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 --- 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(..), - checkPackage, - checkConfiguredPackage, - - -- ** Checking package contents - checkPackageFiles, - checkPackageContent, - CheckPackageContentOps(..), - checkPackageFileNames, - ) where - -import Data.Maybe - ( isNothing, isJust, catMaybes, maybeToList, fromMaybe ) -import Data.List (sort, group, isPrefixOf, nub, find) -import Control.Monad - ( filterM, liftM ) -import qualified System.Directory as System - ( doesFileExist, doesDirectoryExist ) - -import Distribution.Package ( pkgName ) -import Distribution.PackageDescription -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription, finalizePackageDescription ) -import Distribution.Compiler - ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..) ) -import Distribution.System - ( OS(..), Arch(..), buildPlatform ) -import Distribution.License - ( License(..), knownLicenses ) -import Distribution.Simple.Utils - ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase ) - -import Distribution.Version - ( Version(..) - , VersionRange(..), foldVersionRange' - , anyVersion, noVersion, thisVersion, laterVersion, earlierVersion - , orLaterVersion, orEarlierVersion - , unionVersionRanges, intersectVersionRanges - , asVersionIntervals, UpperBound(..), isNoVersion ) -import Distribution.Package - ( PackageName(PackageName), packageName, packageVersion - , Dependency(..) ) - -import Distribution.Text - ( display, disp ) -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<>), (<+>)) - -import qualified Language.Haskell.Extension as Extension (deprecatedExtensions) -import Language.Haskell.Extension - ( Language(UnknownLanguage), knownLanguages, Extension(..), KnownExtension(..) ) -import System.FilePath - ( (), takeExtension, isRelative, isAbsolute - , splitDirectories, splitPath ) -import System.FilePath.Windows as FilePath.Windows - ( isValid ) - --- | Results of some kind of failed package check. --- --- There are a range of severities, from merely dubious to totally insane. --- All of them come with a human readable explanation. In future we may augment --- them with more machine readable explanations, for example to help an IDE --- suggest automatic corrections. --- -data PackageCheck = - - -- | This package description is no good. There's no way it's going to - -- build sensibly. This should give an error at configure time. - PackageBuildImpossible { explanation :: String } - - -- | A problem that is likely to affect building the package, or an - -- issue that we'd like every package author to be aware of, even if - -- the package is never distributed. - | 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 - -- 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 - -- certain to be a portability problem for other environments. We can - -- quite legitimately refuse to publicly distribute packages with these - -- problems. - | PackageDistInexcusable { explanation :: String } - -instance Show PackageCheck where - show notice = explanation notice - -check :: Bool -> PackageCheck -> Maybe PackageCheck -check False _ = Nothing -check True pc = Just pc - --- ------------------------------------------------------------ --- * Standard checks --- ------------------------------------------------------------ - --- | Check for common mistakes and problems in package descriptions. --- --- This is the standard collection of checks covering all apsects except --- for checks that require looking at files within the package. For those --- see 'checkPackageFiles'. --- --- It requires the 'GenericPackageDescription' and optionally a particular --- configuration of that package. If you pass 'Nothing' then we just check --- a version of the generic description using 'flattenPackageDescription'. --- -checkPackage :: GenericPackageDescription - -> Maybe PackageDescription - -> [PackageCheck] -checkPackage gpkg mpkg = - checkConfiguredPackage pkg - ++ checkConditionals gpkg - ++ checkPackageVersions gpkg - where - pkg = fromMaybe (flattenPackageDescription gpkg) mpkg - ---TODO: make this variant go away --- we should alwaws know the GenericPackageDescription -checkConfiguredPackage :: PackageDescription -> [PackageCheck] -checkConfiguredPackage pkg = - checkSanity pkg - ++ checkFields pkg - ++ checkLicense pkg - ++ checkSourceRepos pkg - ++ checkGhcOptions pkg - ++ checkCCOptions pkg - ++ checkPaths pkg - ++ checkCabalVersion pkg - - --- ------------------------------------------------------------ --- * Basic sanity checks --- ------------------------------------------------------------ - --- | Check that this package description is sane. --- -checkSanity :: PackageDescription -> [PackageCheck] -checkSanity pkg = - catMaybes [ - - check (null . (\(PackageName n) -> n) . packageName $ pkg) $ - PackageBuildImpossible "No 'name' field." - - , check (null . versionBranch . packageVersion $ pkg) $ - PackageBuildImpossible "No 'version' field." - - , check (null (executables pkg) && isNothing (library pkg)) $ - PackageBuildImpossible - "No executables and no library found. Nothing to do." - - , check (not (null exeDuplicates)) $ - PackageBuildImpossible $ "Duplicate executable sections " - ++ commaSep exeDuplicates - , check (not (null testDuplicates)) $ - PackageBuildImpossible $ "Duplicate test sections " - ++ commaSep testDuplicates - - --TODO: this seems to duplicate a check on the testsuites - , check (not (null testsThatAreExes)) $ - PackageBuildImpossible $ "These test sections share names with executable sections: " - ++ commaSep testsThatAreExes - ] - --TODO: check for name clashes case insensitively: windows file systems cannot cope. - - ++ maybe [] checkLibrary (library pkg) - ++ concatMap checkExecutable (executables pkg) - ++ concatMap (checkTestSuite pkg) (testSuites pkg) - - ++ catMaybes [ - - check (specVersion pkg > cabalVersion) $ - PackageBuildImpossible $ - "This package description follows version " - ++ display (specVersion pkg) ++ " of the Cabal specification. This " - ++ "tool only supports up to version " ++ display cabalVersion ++ "." - ] - where - exeNames = map exeName $ executables pkg - testNames = map testName $ testSuites pkg - exeDuplicates = dups exeNames - testDuplicates = dups testNames - testsThatAreExes = filter (flip elem exeNames) testNames - -checkLibrary :: Library -> [PackageCheck] -checkLibrary lib = - catMaybes [ - - check (not (null moduleDuplicates)) $ - PackageBuildWarning $ - "Duplicate modules in library: " - ++ commaSep (map display moduleDuplicates) - ] - - where - moduleDuplicates = dups (libModules lib) - -checkExecutable :: Executable -> [PackageCheck] -checkExecutable exe = - catMaybes [ - - check (null (modulePath exe)) $ - PackageBuildImpossible $ - "No 'Main-Is' field found for executable " ++ exeName exe - - , check (not (null (modulePath exe)) - && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $ - PackageBuildImpossible $ - "The 'Main-Is' field must specify a '.hs' or '.lhs' file " - ++ "(even if it is generated by a preprocessor)." - - , check (not (null moduleDuplicates)) $ - PackageBuildWarning $ - "Duplicate modules in executable '" ++ exeName exe ++ "': " - ++ commaSep (map display moduleDuplicates) - ] - where - moduleDuplicates = dups (exeModules exe) - -checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck] -checkTestSuite pkg test = - catMaybes [ - - case testInterface test of - TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $ - PackageBuildWarning $ - quote (display tt) ++ " is not a known type of test suite. " - ++ "The known test suite types are: " - ++ commaSep (map display knownTestTypes) - - TestSuiteUnsupported tt -> Just $ - PackageBuildWarning $ - quote (display tt) ++ " is not a supported test suite version. " - ++ "The known test suite types are: " - ++ commaSep (map display knownTestTypes) - _ -> Nothing - - , check (not $ null moduleDuplicates) $ - PackageBuildWarning $ - "Duplicate modules in test suite '" ++ testName test ++ "': " - ++ commaSep (map display moduleDuplicates) - - , check mainIsWrongExt $ - PackageBuildImpossible $ - "The 'main-is' field must specify a '.hs' or '.lhs' file " - ++ "(even if it is generated by a preprocessor)." - - , check exeNameClash $ - PackageBuildImpossible $ - "The test suite " ++ testName test - ++ " has the same name as an executable." - - , check libNameClash $ - PackageBuildImpossible $ - "The test suite " ++ testName test - ++ " has the same name as the package." - ] - where - moduleDuplicates = dups $ testModules test - - mainIsWrongExt = case testInterface test of - TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] - _ -> False - - exeNameClash = testName test `elem` [ exeName exe | exe <- executables pkg ] - libNameClash = testName test `elem` [ libName - | _lib <- maybeToList (library pkg) - , let PackageName libName = - pkgName (package pkg) ] - --- ------------------------------------------------------------ --- * Additional pure checks --- ------------------------------------------------------------ - -checkFields :: PackageDescription -> [PackageCheck] -checkFields pkg = - catMaybes [ - - check (not . FilePath.Windows.isValid . display . packageName $ pkg) $ - PackageDistInexcusable $ - "Unfortunately, the package name '" ++ display (packageName pkg) - ++ "' is one of the reserved system file names on Windows. Many tools " - ++ "need to convert package names to file names so using this name " - ++ "would cause problems." - - , check (isNothing (buildType pkg)) $ - PackageBuildWarning $ - "No 'build-type' specified. If you do not need a custom Setup.hs or " - ++ "./configure script then use 'build-type: Simple'." - - , case buildType pkg of - Just (UnknownBuildType unknown) -> Just $ - PackageBuildWarning $ - quote unknown ++ " is not a known 'build-type'. " - ++ "The known build types are: " - ++ commaSep (map display knownBuildTypes) - _ -> Nothing - - , check (not (null unknownCompilers)) $ - PackageBuildWarning $ - "Unknown compiler " ++ commaSep (map quote unknownCompilers) - ++ " in 'tested-with' field." - - , check (not (null unknownLanguages)) $ - PackageBuildWarning $ - "Unknown languages: " ++ commaSep unknownLanguages - - , check (not (null unknownExtensions)) $ - PackageBuildWarning $ - "Unknown extensions: " ++ commaSep unknownExtensions - - , check (not (null languagesUsedAsExtensions)) $ - PackageBuildWarning $ - "Languages listed as extensions: " - ++ commaSep languagesUsedAsExtensions - ++ ". Languages must be specified in either the 'default-language' " - ++ " or the 'other-languages' field." - - , check (not (null deprecatedExtensions)) $ - PackageDistSuspicious $ - "Deprecated extensions: " - ++ commaSep (map (quote . display . fst) deprecatedExtensions) - ++ ". " ++ intercalate " " - [ "Instead of '" ++ display ext - ++ "' use '" ++ display replacement ++ "'." - | (ext, Just replacement) <- deprecatedExtensions ] - - , check (null (category pkg)) $ - PackageDistSuspicious "No 'category' field." - - , check (null (maintainer pkg)) $ - PackageDistSuspicious "No 'maintainer' field." - - , check (null (synopsis pkg) && null (description pkg)) $ - PackageDistInexcusable $ "No 'synopsis' or 'description' field." - - , check (null (description pkg) && not (null (synopsis pkg))) $ - PackageDistSuspicious "No 'description' field." - - , check (null (synopsis pkg) && not (null (description pkg))) $ - PackageDistSuspicious "No 'synopsis' field." - - --TODO: recommend the bug reports url, author and homepage fields - --TODO: recommend not using the stability field - --TODO: recommend specifying a source repo - - , check (length (synopsis pkg) >= 80) $ - PackageDistSuspicious - "The 'synopsis' field is rather long (max 80 chars is recommended)." - - -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12" - , check (not (null testedWithImpossibleRanges)) $ - PackageDistInexcusable $ - "Invalid 'tested-with' version range: " - ++ commaSep (map display testedWithImpossibleRanges) - ++ ". To indicate that you have tested a package with multiple " - ++ "different versions of the same compiler use multiple entries, " - ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " - ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." - ] - where - unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] - unknownLanguages = [ name | bi <- allBuildInfo pkg - , UnknownLanguage name <- allLanguages bi ] - unknownExtensions = [ name | bi <- allBuildInfo pkg - , UnknownExtension name <- allExtensions bi - , name `notElem` map display knownLanguages ] - deprecatedExtensions = nub $ catMaybes - [ find ((==ext) . fst) Extension.deprecatedExtensions - | bi <- allBuildInfo pkg - , ext <- allExtensions bi ] - languagesUsedAsExtensions = - [ name | bi <- allBuildInfo pkg - , UnknownExtension name <- allExtensions bi - , name `elem` map display knownLanguages ] - - testedWithImpossibleRanges = - [ Dependency (PackageName (display compiler)) vr - | (compiler, vr) <- testedWith pkg - , isNoVersion vr ] - - -checkLicense :: PackageDescription -> [PackageCheck] -checkLicense pkg = - catMaybes [ - - check (license pkg == AllRightsReserved) $ - PackageDistInexcusable - "The 'license' field is missing or specified as AllRightsReserved." - - , case license pkg of - UnknownLicense l -> Just $ - PackageBuildWarning $ - quote ("license: " ++ l) ++ " is not a recognised license. The " - ++ "known licenses are: " - ++ commaSep (map display knownLicenses) - _ -> Nothing - - , check (license pkg == BSD4) $ - PackageDistSuspicious $ - "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " - ++ "refers to the old 4-clause BSD license with the advertising " - ++ "clause. 'BSD3' refers the new 3-clause BSD license." - - , case unknownLicenseVersion (license pkg) of - Just knownVersions -> Just $ - PackageDistSuspicious $ - "'license: " ++ display (license pkg) ++ "' is not a known " - ++ "version of that license. The known versions are " - ++ commaSep (map display knownVersions) - ++ ". If this is not a mistake and you think it should be a known " - ++ "version then please file a ticket." - _ -> Nothing - - , check (license pkg `notElem` [AllRightsReserved, PublicDomain] - -- AllRightsReserved and PublicDomain are not strictly - -- licenses so don't need license files. - && null (licenseFile pkg)) $ - PackageDistSuspicious "A 'license-file' is not specified." - ] - where - unknownLicenseVersion (GPL (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | GPL (Just v') <- knownLicenses ] - unknownLicenseVersion (LGPL (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ] - unknownLicenseVersion _ = Nothing - -checkSourceRepos :: PackageDescription -> [PackageCheck] -checkSourceRepos pkg = - catMaybes $ concat [[ - - case repoKind repo of - RepoKindUnknown kind -> Just $ PackageDistInexcusable $ - quote kind ++ " is not a recognised kind of source-repository. " - ++ "The repo kind is usually 'head' or 'this'" - _ -> Nothing - - , check (repoType repo == Nothing) $ - PackageDistInexcusable - "The source-repository 'type' is a required field." - - , check (repoLocation repo == Nothing) $ - PackageDistInexcusable - "The source-repository 'location' is a required field." - - , check (repoType repo == Just CVS && repoModule repo == Nothing) $ - PackageDistInexcusable - "For a CVS source-repository, the 'module' is a required field." - - , check (repoKind repo == RepoThis && repoTag repo == Nothing) $ - PackageDistInexcusable $ - "For the 'this' kind of source-repository, the 'tag' is a required " - ++ "field. It should specify the tag corresponding to this version " - ++ "or release of the package." - - , check (maybe False System.FilePath.isAbsolute (repoSubdir repo)) $ - PackageDistInexcusable - "The 'subdir' field of a source-repository must be a relative path." - ] - | repo <- sourceRepos pkg ] - ---TODO: check location looks like a URL for some repo types. - -checkGhcOptions :: PackageDescription -> [PackageCheck] -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"] $ - PackageDistInexcusable $ - "'ghc-options: -fasm' is unnecessary and will not work on CPU " - ++ "architectures other than x86, x86-64, ppc or sparc." - - , checkFlags ["-fvia-C"] $ - PackageDistSuspicious $ - "'ghc-options: -fvia-C' is usually unnecessary. If your package " - ++ "needs -via-C for correctness rather than performance then it " - ++ "is using the FFI incorrectly and will probably not work with GHC " - ++ "6.10 or later." - - , 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." - - , checkFlags ["-prof"] $ - PackageBuildWarning $ - "'ghc-options: -prof' is not necessary and will lead to problems " - ++ "when used on a library. Use the configure flag " - ++ "--enable-library-profiling and/or --enable-executable-profiling." - - , checkFlags ["-o"] $ - PackageBuildWarning $ - "'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." - - , checkFlags ["--make"] $ - PackageBuildWarning $ - "'ghc-options: --make' is never needed. Cabal uses this automatically." - - , checkFlags ["-main-is"] $ - PackageDistSuspicious $ - "'ghc-options: -main-is' is not portable." - - , checkFlags ["-O0", "-Onot"] $ - PackageDistSuspicious $ - "'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." - - , 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." - - , checkFlags ["-split-objs"] $ - PackageBuildWarning $ - "'ghc-options: -split-objs' is not needed. Use the --enable-split-objs configure flag." - - , checkFlags ["-optl-Wl,-s", "-optl-s"] $ - PackageDistInexcusable $ - "'ghc-options: -optl-Wl,-s' is not needed and is not portable to all" - ++ " operating systems. Cabal 1.4 and later automatically strip" - ++ " executables. Cabal also has a flag --disable-executable-stripping" - ++ " which is necessary when building packages for some Linux" - ++ " distributions and using '-optl-Wl,-s' prevents that from working." - - , checkFlags ["-fglasgow-exts"] $ - PackageDistSuspicious $ - "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use the 'extensions' field." - - , check ("-threaded" `elem` lib_ghc_options) $ - PackageDistSuspicious $ - "'ghc-options: -threaded' 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] ] - - , checkAlternatives "ghc-options" "extensions" - [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options ] - - , checkAlternatives "ghc-options" "cpp-options" $ - [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ] - ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ] - - , checkAlternatives "ghc-options" "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ] - - , checkAlternatives "ghc-options" "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ] - - , checkAlternatives "ghc-options" "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ] - ] - - 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) - - 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) - _ -> Nothing - ghcExtension "-cpp" = Just (EnableExtension CPP) - ghcExtension _ = Nothing - -checkCCOptions :: PackageDescription -> [PackageCheck] -checkCCOptions pkg = - catMaybes [ - - checkAlternatives "cc-options" "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_ccOptions ] - - , checkAlternatives "cc-options" "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_ccOptions ] - - , checkAlternatives "cc-options" "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_ccOptions ] - - , checkAlternatives "ld-options" "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ] - - , checkAlternatives "ld-options" "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ] - - , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $ - PackageDistSuspicious $ - "'cc-options: -O[n]' is generally not needed. When building with " - ++ " optimisations Cabal automatically adds '-O2' for C code. " - ++ "Setting it yourself interferes with the --disable-optimization " - ++ "flag." - ] - - where all_ccOptions = [ opts | bi <- allBuildInfo pkg - , opts <- ccOptions bi ] - all_ldOptions = [ opts | bi <- allBuildInfo pkg - , opts <- ldOptions bi ] - - checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkCCFlags flags = check (any (`elem` flags) all_ccOptions) - -checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck -checkAlternatives badField goodField flags = - check (not (null badFlags)) $ - PackageBuildWarning $ - "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags) - ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags) - - where (badFlags, goodFlags) = unzip flags - -checkPaths :: PackageDescription -> [PackageCheck] -checkPaths pkg = - [ PackageBuildWarning $ - quote (kind ++ ": " ++ path) - ++ " is a relative path outside of the source tree. " - ++ "This will not work when generating a tarball with 'sdist'." - | (path, kind) <- relPaths ++ absPaths - , isOutsideTree path ] - ++ - [ PackageDistInexcusable $ - quote (kind ++ ": " ++ path) ++ " is an absolute directory." - | (path, kind) <- relPaths - , isAbsolute path ] - ++ - [ PackageDistInexcusable $ - quote (kind ++ ": " ++ path) ++ " points inside the 'dist' " - ++ "directory. This is not reliable because the location of this " - ++ "directory is configurable by the user (or package manager). In " - ++ "addition the layout of the 'dist' directory is subject to change " - ++ "in future versions of Cabal." - | (path, kind) <- relPaths ++ absPaths - , isInsideDist path ] - ++ - [ PackageDistInexcusable $ - "The 'ghc-options' contains the path '" ++ path ++ "' which points " - ++ "inside the 'dist' directory. This is not reliable because the " - ++ "location of this directory is configurable by the user (or package " - ++ "manager). In addition the layout of the 'dist' directory is subject " - ++ "to change in future versions of Cabal." - | bi <- allBuildInfo pkg - , (GHC, flags) <- options bi - , path <- flags - , isInsideDist path ] - where - isOutsideTree path = case splitDirectories path of - "..":_ -> True - ".":"..":_ -> True - _ -> False - isInsideDist path = case map lowercase (splitDirectories path) of - "dist" :_ -> True - ".":"dist":_ -> True - _ -> False - -- paths that must be relative - relPaths = - [ (path, "extra-src-files") | path <- extraSrcFiles pkg ] - ++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ] - ++ [ (path, "data-files") | path <- dataFiles pkg ] - ++ [ (path, "data-dir") | path <- [dataDir pkg]] - ++ concat - [ [ (path, "c-sources") | path <- cSources bi ] - ++ [ (path, "install-includes") | path <- installIncludes bi ] - ++ [ (path, "hs-source-dirs") | path <- hsSourceDirs bi ] - | bi <- allBuildInfo pkg ] - -- paths that are allowed to be absolute - absPaths = concat - [ [ (path, "includes") | path <- includes bi ] - ++ [ (path, "include-dirs") | path <- includeDirs bi ] - ++ [ (path, "extra-lib-dirs") | path <- extraLibDirs bi ] - | bi <- allBuildInfo pkg ] - ---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. - ---TODO: use the tar path checks on all the above paths - --- | Check that the package declares the version in the @\"cabal-version\"@ --- field correctly. --- -checkCabalVersion :: PackageDescription -> [PackageCheck] -checkCabalVersion pkg = - catMaybes [ - - -- check syntax of cabal-version field - check (specVersion pkg >= Version [1,10] [] - && not simpleSpecVersionRangeSyntax) $ - PackageBuildWarning $ - "Packages relying on Cabal 1.10 or later must only specify a " - ++ "version range of the form 'cabal-version: >= x.y'. Use " - ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'." - - -- check syntax of cabal-version field - , check (specVersion pkg < Version [1,9] [] - && not simpleSpecVersionRangeSyntax) $ - PackageDistSuspicious $ - "It is recommended that the 'cabal-version' field only specify a " - ++ "version range of the form '>= x.y'. Use " - ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'. " - ++ "Tools based on Cabal 1.10 and later will ignore upper bounds." - - -- check syntax of cabal-version field - , checkVersion [1,12] simpleSpecVersionSyntax $ - PackageBuildWarning $ - "With Cabal 1.10 or earlier, the 'cabal-version' field must use " - ++ "range syntax rather than a simple version number. Use " - ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'." - - -- check use of test suite sections - , checkVersion [1,8] (not (null $ testSuites pkg)) $ - PackageDistInexcusable $ - "The 'test-suite' section is new in Cabal 1.10. " - ++ "Unfortunately it messes up the parser in older Cabal versions " - ++ "so you must specify at least 'cabal-version: >= 1.8', but note" - ++ "that only Cabal 1.10 and later can actually run such test suites." - - -- check use of default-language field - -- note that we do not need to do an equivalent check for the - -- other-language field since that one does not change behaviour - , checkVersion [1,10] (any isJust (buildInfoField defaultLanguage)) $ - PackageBuildWarning $ - "To use the 'default-language' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.10'." - - , check (specVersion pkg >= Version [1,10] [] - && (any isNothing (buildInfoField defaultLanguage))) $ - PackageBuildWarning $ - "Packages using 'cabal-version: >= 1.10' must specify the " - ++ "'default-language' field for each component (e.g. Haskell98 or " - ++ "Haskell2010). If a component uses different languages in " - ++ "different modules then list the other ones in the " - ++ "'other-languages' field." - - -- 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)) $ - PackageBuildWarning $ - "To use the 'default-extensions' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.10'." - - -- check use of extensions field - , check (specVersion pkg >= Version [1,10] [] - && (any (not . null) (buildInfoField oldExtensions))) $ - PackageBuildWarning $ - "For packages using 'cabal-version: >= 1.10' the 'extensions' " - ++ "field is deprecated. The new 'default-extensions' field lists " - ++ "extensions that are used in all modules in the component, while " - ++ "the 'other-extensions' field lists extensions that are used in " - ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." - - -- check use of "foo (>= 1.0 && < 1.4) || >=1.8 " version-range syntax - , checkVersion [1,8] (not (null versionRangeExpressions)) $ - PackageDistInexcusable $ - "The package uses full version-range expressions " - ++ "in a 'build-depends' field: " - ++ commaSep (map displayRawDependency versionRangeExpressions) - ++ ". To use this new syntax the package needs to specify at least " - ++ "'cabal-version: >= 1.8'. Alternatively, if broader compatibility " - ++ "is important, then convert to conjunctive normal form, and use " - ++ "multiple 'build-depends:' lines, one conjunct per line." - - -- check use of "build-depends: foo == 1.*" syntax - , checkVersion [1,6] (not (null depsUsingWildcardSyntax)) $ - PackageDistInexcusable $ - "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 " - ++ "is important then use: " ++ commaSep - [ display (Dependency name (eliminateWildcardSyntax versionRange)) - | Dependency name versionRange <- depsUsingWildcardSyntax ] - - -- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax - , checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $ - PackageDistInexcusable $ - "The package uses full version-range expressions " - ++ "in a 'tested-with' field: " - ++ commaSep (map displayRawDependency testedWithVersionRangeExpressions) - ++ ". To use this new syntax the package needs to specify at least " - ++ "'cabal-version: >= 1.8'." - - -- check use of "tested-with: GHC == 6.12.*" syntax - , checkVersion [1,6] (not (null testedWithUsingWildcardSyntax)) $ - PackageDistInexcusable $ - "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 " - ++ "is important then use: " ++ commaSep - [ display (Dependency name (eliminateWildcardSyntax versionRange)) - | Dependency name versionRange <- testedWithUsingWildcardSyntax ] - - -- check use of "data-files: data/*.txt" syntax - , checkVersion [1,6] (not (null dataFilesUsingGlobSyntax)) $ - PackageDistInexcusable $ - "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 " - ++ "versions then list all the files explicitly." - - -- check use of "extra-source-files: mk/*.in" syntax - , checkVersion [1,6] (not (null extraSrcFilesUsingGlobSyntax)) $ - PackageDistInexcusable $ - "Using wildcards like " - ++ 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 " - ++ "explicitly." - - -- check use of "source-repository" section - , checkVersion [1,6] (not (null (sourceRepos pkg))) $ - PackageDistInexcusable $ - "The 'source-repository' section is new in Cabal 1.6. " - ++ "Unfortunately it messes up the parser in earlier Cabal versions " - ++ "so you need to specify 'cabal-version: >= 1.6'." - - -- check for new licenses - , checkVersion [1,4] (license pkg `notElem` compatLicenses) $ - PackageDistInexcusable $ - "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'." - - -- check for new language extensions - , checkVersion [1,2,3] (not (null mentionedExtensionsThatNeedCabal12)) $ - PackageDistInexcusable $ - "Unfortunately the language extensions " - ++ 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 " - ++ "use an equivalent compiler-specific flag." - - , checkVersion [1,4] (not (null mentionedExtensionsThatNeedCabal14)) $ - PackageDistInexcusable $ - "Unfortunately the language extensions " - ++ 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 " - ++ "use an equivalent compiler-specific flag." - ] - where - -- Perform a check on packages that use a version of the spec less than - -- the version given. This is for cases where a new Cabal version adds - -- a new feature and we want to check that it is not used prior to that - -- version. - checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck - checkVersion ver cond pc - | specVersion pkg >= Version ver [] = Nothing - | otherwise = check cond pc - - buildInfoField field = map field (allBuildInfo pkg) - dataFilesUsingGlobSyntax = filter usesGlobSyntax (dataFiles pkg) - extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg) - usesGlobSyntax str = case parseFileGlob str of - Just (FileGlob _ _) -> True - _ -> False - - versionRangeExpressions = - [ dep | dep@(Dependency _ vr) <- buildDepends pkg - , usesNewVersionRangeSyntax vr ] - - testedWithVersionRangeExpressions = - [ Dependency (PackageName (display compiler)) vr - | (compiler, vr) <- testedWith pkg - , usesNewVersionRangeSyntax vr ] - - simpleSpecVersionRangeSyntax = - either (const True) - (foldVersionRange' - True - (\_ -> False) - (\_ -> False) (\_ -> False) - (\_ -> True) -- >= - (\_ -> False) - (\_ _ -> False) - (\_ _ -> False) (\_ _ -> False) - id) - (specVersionRaw pkg) - - -- is the cabal-version field a simple version number, rather than a range - simpleSpecVersionSyntax = - either (const True) (const False) (specVersionRaw pkg) - - usesNewVersionRangeSyntax :: VersionRange -> Bool - usesNewVersionRangeSyntax = - (> 2) -- uses the new syntax if depth is more than 2 - . foldVersionRange' - (1 :: Int) - (const 1) - (const 1) (const 1) - (const 1) (const 1) - (const (const 1)) - (+) (+) - (const 3) -- uses new ()'s syntax - - depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg - , usesWildcardSyntax vr ] - - testedWithUsingWildcardSyntax = [ Dependency (PackageName (display compiler)) vr - | (compiler, vr) <- testedWith pkg - , usesWildcardSyntax vr ] - - usesWildcardSyntax :: VersionRange -> Bool - usesWildcardSyntax = - foldVersionRange' - False (const False) - (const False) (const False) - (const False) (const False) - (\_ _ -> True) -- the wildcard case - (||) (||) id - - eliminateWildcardSyntax = - foldVersionRange' - anyVersion thisVersion - laterVersion earlierVersion - orLaterVersion orEarlierVersion - (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v')) - intersectVersionRanges unionVersionRanges id - - compatLicenses = [ GPL Nothing, LGPL Nothing, BSD3, BSD4 - , PublicDomain, AllRightsReserved, OtherLicense ] - - mentionedExtensions = [ ext | bi <- allBuildInfo pkg - , ext <- allExtensions bi ] - mentionedExtensionsThatNeedCabal12 = - nub (filter (`elem` compatExtensionsExtra) mentionedExtensions) - - -- As of Cabal-1.4 we can add new extensions without worrying about - -- breaking old versions of cabal. - mentionedExtensionsThatNeedCabal14 = - nub (filter (`notElem` compatExtensions) mentionedExtensions) - - -- The known extensions in Cabal-1.2.3 - compatExtensions = - map EnableExtension - [ OverlappingInstances, UndecidableInstances, IncoherentInstances - , RecursiveDo, ParallelListComp, MultiParamTypeClasses - , FunctionalDependencies, Rank2Types - , RankNTypes, PolymorphicComponents, ExistentialQuantification - , ScopedTypeVariables, ImplicitParams, FlexibleContexts - , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns - , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface - , Arrows, Generics, NamedFieldPuns, PatternGuards - , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms - , HereDocuments] ++ - map DisableExtension - [MonomorphismRestriction, ImplicitPrelude] ++ - compatExtensionsExtra - - -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6 - -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8) - compatExtensionsExtra = - map EnableExtension - [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving - , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms - , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields - , OverloadedStrings, GADTs, RelaxedPolyRec - , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable - , ConstrainedClassMethods - ] ++ - map DisableExtension - [MonoPatBinds] - --- | 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! --- -displayRawVersionRange :: VersionRange -> String -displayRawVersionRange = - Disp.render - . fst - . foldVersionRange' -- precedence: - -- All the same as the usual pretty printer, except for the parens - ( Disp.text "-any" , 0 :: Int) - (\v -> (Disp.text "==" <> disp v , 0)) - (\v -> (Disp.char '>' <> disp v , 0)) - (\v -> (Disp.char '<' <> disp v , 0)) - (\v -> (Disp.text ">=" <> disp v , 0)) - (\v -> (Disp.text "<=" <> disp v , 0)) - (\v _ -> (Disp.text "==" <> dispWild v , 0)) - (\(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 - dispWild (Version b _) = - Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) - <> Disp.text ".*" - punct p p' | p < p' = Disp.parens - | otherwise = id - -displayRawDependency :: Dependency -> String -displayRawDependency (Dependency pkg vr) = - display pkg ++ " " ++ displayRawVersionRange vr - - --- ------------------------------------------------------------ --- * Checks on the GenericPackageDescription --- ------------------------------------------------------------ - --- | Check the build-depends fields for any weirdness or bad practise. --- -checkPackageVersions :: GenericPackageDescription -> [PackageCheck] -checkPackageVersions pkg = - catMaybes [ - - -- Check that the version of base is bounded above. - -- For example this bans "build-depends: base >= 3". - -- It should probably be "build-depends: base >= 3 && < 4" - -- which is the same as "build-depends: base == 3.*" - check (not (boundedAbove baseDependency)) $ - PackageDistInexcusable $ - "The dependency 'build-depends: base' does not specify an upper " - ++ "bound on the version number. Each major release of the 'base' " - ++ "package changes the API in various ways and most packages will " - ++ "need some changes to compile with it. The recommended practise " - ++ "is to specify an upper bound on the version of the 'base' " - ++ "package. This ensures your package will continue to build when a " - ++ "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'." - - ] - where - -- TODO: What we really want to do is test if there exists any - -- configuration in which the base version is unboudned above. - -- However that's a bit tricky because there are many possible - -- configurations. As a cheap easy and safe approximation we will - -- pick a single "typical" configuration and check if that has an - -- open upper bound. To get a typical configuration we finalise - -- using no package index and the current platform. - finalised = finalizePackageDescription - [] (const True) buildPlatform - (CompilerId buildCompilerFlavor (Version [] [])) - [] pkg - baseDependency = case finalised of - Right (pkg', _) | not (null baseDeps) -> - foldr intersectVersionRanges anyVersion baseDeps - where - baseDeps = - [ vr | Dependency (PackageName "base") vr <- buildDepends pkg' ] - - -- Just in case finalizePackageDescription fails for any reason, - -- or if the package doesn't depend on the base package at all, - -- then we will just skip the check, since boundedAbove noVersion = True - _ -> noVersion - - boundedAbove :: VersionRange -> Bool - boundedAbove vr = case asVersionIntervals vr of - [] -> True -- this is the inconsistent version range. - intervals -> case last intervals of - (_, UpperBound _ _) -> True - (_, NoUpperBound ) -> False - - -checkConditionals :: GenericPackageDescription -> [PackageCheck] -checkConditionals pkg = - catMaybes [ - - check (not $ null unknownOSs) $ - PackageDistInexcusable $ - "Unknown operating system name " - ++ commaSep (map quote unknownOSs) - - , check (not $ null unknownArches) $ - PackageDistInexcusable $ - "Unknown architecture name " - ++ commaSep (map quote unknownArches) - - , check (not $ null unknownImpls) $ - PackageDistInexcusable $ - "Unknown compiler name " - ++ commaSep (map quote unknownImpls) - ] - where - unknownOSs = [ os | OS (OtherOS os) <- conditions ] - unknownArches = [ arch | Arch (OtherArch arch) <- conditions ] - unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ] - conditions = maybe [] freeVars (condLibrary pkg) - ++ concatMap (freeVars . snd) (condExecutables pkg) - freeVars (CondNode _ _ ifs) = concatMap compfv ifs - compfv (c, ct, mct) = condfv c ++ freeVars ct ++ maybe [] freeVars mct - condfv c = case c of - Var v -> [v] - Lit _ -> [] - CNot c1 -> condfv c1 - COr c1 c2 -> condfv c1 ++ condfv c2 - CAnd c1 c2 -> condfv c1 ++ condfv c2 - --- ------------------------------------------------------------ --- * 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. --- -checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck] -checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg - where - checkFilesIO = CheckPackageContentOps { - doesFileExist = System.doesFileExist . relative, - doesDirectoryExist = System.doesDirectoryExist . relative - } - relative path = root path - --- | A record of operations needed to check the contents of packages. --- Used by 'checkPackageContent'. --- -data CheckPackageContentOps m = CheckPackageContentOps { - doesFileExist :: FilePath -> m Bool, - doesDirectoryExist :: FilePath -> m Bool - } - --- | Sanity check things that requires looking at files in the package. --- This is a generalised version of 'checkPackageFiles' that can work in any --- monad for which you can provide 'CheckPackageContentOps' operations. --- --- The point of this extra generality is to allow doing checks in some virtual --- file system, for example a tarball in memory. --- -checkPackageContent :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] -checkPackageContent ops pkg = do - licenseError <- checkLicenseExists ops pkg - setupError <- checkSetupExists ops pkg - configureError <- checkConfigureExists ops pkg - localPathErrors <- checkLocalPathsExist ops pkg - vcsLocation <- checkMissingVcsInfo ops pkg - - return $ catMaybes [licenseError, 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." - - where - file = licenseFile pkg - -checkSetupExists :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m (Maybe PackageCheck) -checkSetupExists ops _ = do - hsexists <- doesFileExist ops "Setup.hs" - lhsexists <- doesFileExist ops "Setup.lhs" - return $ check (not hsexists && not lhsexists) $ - PackageDistInexcusable $ - "The package is missing a Setup.hs or Setup.lhs script." - -checkConfigureExists :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m (Maybe PackageCheck) -checkConfigureExists ops PackageDescription { buildType = Just Configure } = do - exists <- doesFileExist ops "configure" - return $ check (not exists) $ - PackageBuildWarning $ - "The 'build-type' is 'Configure' but there is no 'configure' script." -checkConfigureExists _ _ = return Nothing - -checkLocalPathsExist :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] -checkLocalPathsExist ops pkg = do - let dirs = [ (dir, kind) - | bi <- allBuildInfo pkg - , (dir, kind) <- - [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ] - ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] - ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ] - , isRelative dir ] - missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs - return [ PackageBuildWarning { - explanation = quote (kind ++ ": " ++ dir) - ++ " directory does not exist." - } - | (dir, kind) <- missing ] - -checkMissingVcsInfo :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] -checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do - vcsInUse <- liftM or $ mapM (doesDirectoryExist ops) repoDirnames - if vcsInUse - then return [ PackageDistSuspicious message ] - else return [] - where - repoDirnames = [ dirname | repo <- knownRepoTypes - , dirname <- repoTypeDirname repo ] - message = "When distributing packages it is encouraged to specify source " - ++ "control information in the .cabal file using one or more " - ++ "'source-repository' sections. See the Cabal user guide for " - ++ "details." - -checkMissingVcsInfo _ _ = return [] - -repoTypeDirname :: RepoType -> [FilePath] -repoTypeDirname Darcs = ["_darcs"] -repoTypeDirname Git = [".git"] -repoTypeDirname SVN = [".svn"] -repoTypeDirname CVS = ["CVS"] -repoTypeDirname Mercurial = [".hg"] -repoTypeDirname GnuArch = [".arch-params"] -repoTypeDirname Bazaar = [".bzr"] -repoTypeDirname Monotone = ["_MTN"] -repoTypeDirname _ = [] - --- ------------------------------------------------------------ --- * Checks involving files in the package --- ------------------------------------------------------------ - --- | Check the names of all files in a package for portability problems. This --- should be done for example when creating or validating a package tarball. --- -checkPackageFileNames :: [FilePath] -> [PackageCheck] -checkPackageFileNames files = - (take 1 . catMaybes . map checkWindowsPath $ files) - ++ (take 1 . catMaybes . map checkTarPath $ files) - -- If we get any of these checks triggering then we're likely to get - -- many, and that's probably not helpful, so return at most one. - -checkWindowsPath :: FilePath -> Maybe PackageCheck -checkWindowsPath path = - check (not $ FilePath.Windows.isValid path') $ - PackageDistInexcusable $ - "Unfortunately, the file " ++ quote path ++ " is not a valid file " - ++ "name on Windows which would cause portability problems for this " - ++ "package. Windows file names cannot contain any of the characters " - ++ "\":*?<>|\" and there are a few reserved names including \"aux\", " - ++ "\"nul\", \"con\", \"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." - where - path' = ".\\" ++ path - -- force a relative name to catch invalid file names like "f:oo" which - -- otherwise parse as file "oo" in the current directory on the 'f' drive. - --- | Check a file name is valid for the portable POSIX tar format. --- --- The POSIX tar format has a restriction on the length of file names. It is --- unfortunately not a simple restriction like a maximum length. The exact --- restriction is that either the whole path be 100 characters or less, or it --- be possible to split the path on a directory separator such that the first --- part is 155 characters or less and the second part 100 characters or less. --- -checkTarPath :: FilePath -> Maybe PackageCheck -checkTarPath path - | length path > 255 = Just longPath - | otherwise = case pack nameMax (reverse (splitPath path)) of - Left err -> Just err - Right [] -> Nothing - Right (first:rest) -> case pack prefixMax remainder of - Left err -> Just err - Right [] -> Nothing - Right (_:_) -> Just noSplit - where - -- drop the '/' between the name and prefix: - remainder = init first : rest - - where - nameMax, prefixMax :: Int - nameMax = 100 - prefixMax = 155 - - pack _ [] = Left emptyName - pack maxLen (c:cs) - | n > maxLen = Left longName - | otherwise = Right (pack' maxLen n cs) - where n = length c - - pack' maxLen n (c:cs) - | n' <= maxLen = pack' maxLen n' cs - where n' = n + length c - pack' _ _ cs = cs - - longPath = PackageDistInexcusable $ - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. The maximum length is 255 ASCII characters.\n" - ++ "The file in question is:\n " ++ path - longName = PackageDistInexcusable $ - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. The maximum length for the name part (including " - ++ "extension) is 100 ASCII characters. The maximum length for any " - ++ "individual directory component is 155.\n" - ++ "The file in question is:\n " ++ path - noSplit = PackageDistInexcusable $ - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. While the total length is less than 255 ASCII " - ++ "characters, there are unfortunately further restrictions. It has to " - ++ "be possible to split the file path on a directory separator into " - ++ "two parts such that the first part fits in 155 characters or less " - ++ "and the second part fits in 100 characters or less. Basically you " - ++ "have to make the file name or directory names shorter, or you could " - ++ "split a long directory name into nested subdirectories with shorter " - ++ "names.\nThe file in question is:\n " ++ path - emptyName = PackageDistInexcusable $ - "Encountered a file with an empty name, something is very wrong! " - ++ "Files with an empty name cannot be stored in a tar archive or in " - ++ "standard file systems." - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - -quote :: String -> String -quote s = "'" ++ s ++ "'" - -commaSep :: [String] -> String -commaSep = intercalate ", " - -dups :: Ord a => [a] -> [a] -dups xs = [ x | (x:_:_) <- group (sort xs) ] diff --git a/cabal/cabal/Distribution/PackageDescription/Configuration.hs b/cabal/cabal/Distribution/PackageDescription/Configuration.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/PackageDescription/Configuration.hs +++ /dev/null @@ -1,618 +0,0 @@ -{-# OPTIONS -cpp #-} --- OPTIONS required for ghc-6.4.x compat, and must appear first -{-# LANGUAGE CPP #-} --- -fno-warn-deprecations for use of Map.foldWithKey -{-# OPTIONS_GHC -cpp -fno-warn-deprecations #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Configuration --- Copyright : Thomas Schilling, 2007 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is about the cabal configurations feature. It exports --- 'finalizePackageDescription' and 'flattenPackageDescription' which are --- functions for converting 'GenericPackageDescription's down to --- 'PackageDescription's. It has code for working with the tree of conditions --- and resolving or flattening conditions. - -{- 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, - - -- Utils - parseCondition, - freeVars, - mapCondTree, - mapTreeData, - mapTreeConds, - mapTreeConstrs, - ) where - -import Distribution.Package - ( PackageName, Dependency(..) ) -import Distribution.PackageDescription - ( GenericPackageDescription(..), PackageDescription(..) - , Library(..), Executable(..), BuildInfo(..) - , Flag(..), FlagName(..), FlagAssignment - , CondTree(..), ConfVar(..), Condition(..), TestSuite(..) ) -import Distribution.Version - ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) -import Distribution.Compiler - ( CompilerId(CompilerId) ) -import Distribution.System - ( Platform(..), OS, Arch ) -import Distribution.Simple.Utils - ( currentDir, lowercase ) - -import Distribution.Text - ( Text(parse) ) -import Distribution.Compat.ReadP as ReadP hiding ( char ) -import Control.Arrow (first) -import qualified Distribution.Compat.ReadP as ReadP ( char ) - -import Data.Char ( isAlphaNum ) -import Data.Maybe ( catMaybes, maybeToList ) -import Data.Map ( Map, fromListWith, toList ) -import qualified Data.Map as Map -import Data.Monoid - -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606) -import qualified Text.Read as R -import qualified Text.Read.Lex as L -#endif - ------------------------------------------------------------------------------- - --- | Simplify the condition and return its free variables. -simplifyCondition :: Condition c - -> (c -> Either d Bool) -- ^ (partial) variable assignment - -> (Condition d, [d]) -simplifyCondition cond i = fv . walk $ cond - where - walk cnd = case cnd of - Var v -> either Var Lit (i v) - Lit b -> Lit b - CNot c -> case walk c of - Lit True -> Lit False - Lit False -> Lit True - c' -> CNot c' - COr c d -> case (walk c, walk d) of - (Lit False, d') -> d' - (Lit True, _) -> Lit True - (c', Lit False) -> c' - (_, Lit True) -> Lit True - (c',d') -> COr c' d' - CAnd c d -> case (walk c, walk d) of - (Lit False, _) -> Lit False - (Lit True, d') -> d' - (_, Lit False) -> Lit False - (c', Lit True) -> c' - (c',d') -> CAnd c' d' - -- gather free vars - fv c = (c, fv' c) - fv' c = case c of - Var v -> [v] - Lit _ -> [] - CNot c' -> fv' c' - 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 --- the names of all the flags occurring in the condition. -simplifyWithSysParams :: OS -> Arch -> CompilerId -> Condition ConfVar - -> (Condition FlagName, [FlagName]) -simplifyWithSysParams os arch (CompilerId comp compVer) 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 - --- TODO: Add instances and check --- --- prop_sC_idempotent cond a o = cond' == cond'' --- where --- cond' = simplifyCondition cond a o --- cond'' = simplifyCondition cond' a o --- --- prop_sC_noLits cond a o = isLit res || not (hasLits res) --- where --- res = simplifyCondition cond a o --- hasLits (Lit _) = True --- hasLits (CNot c) = hasLits c --- hasLits (COr l r) = hasLits l || hasLits r --- hasLits (CAnd l r) = hasLits l || hasLits r --- hasLits _ = False --- - --- | Parse a configuration condition from a string. -parseCondition :: ReadP r (Condition ConfVar) -parseCondition = condOr - where - condOr = sepBy1 condAnd (oper "||") >>= return . foldl1 COr - condAnd = sepBy1 cond (oper "&&")>>= return . foldl1 CAnd - cond = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond - +++ archCond +++ flagCond +++ implCond ) - inparens = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp) - notCond = ReadP.char '!' >> sp >> cond >>= return . CNot - osCond = string "os" >> sp >> inparens osIdent >>= return . Var - archCond = string "arch" >> sp >> inparens archIdent >>= return . Var - flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var - implCond = string "impl" >> sp >> inparens implIdent >>= return . Var - boolLiteral = fmap Lit parse - archIdent = fmap Arch parse - osIdent = fmap OS parse - flagIdent = fmap (Flag . FlagName . lowercase) (munch1 isIdentChar) - isIdentChar c = isAlphaNum c || c == '_' || c == '-' - oper s = sp >> string s >> sp - sp = skipSpaces - implIdent = do i <- parse - vr <- sp >> option anyVersion parse - return $ Impl i vr - ------------------------------------------------------------------------------- - -mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) - -> CondTree v c a -> CondTree w d b -mapCondTree fa fc fcnd (CondNode a c ifs) = - CondNode (fa a) (fc c) (map g ifs) - where - g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t, - fmap (mapCondTree fa fc fcnd) me) - -mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a -mapTreeConstrs f = mapCondTree id f id - -mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a -mapTreeConds f = mapCondTree id id f - -mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b -mapTreeData f = mapCondTree f id id - --- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for --- clarity. -data DepTestRslt d = DepOk | MissingDeps d - -instance Monoid d => Monoid (DepTestRslt d) where - mempty = DepOk - mappend DepOk x = x - mappend x DepOk = x - mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d') - - -data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree - - --- | Try to find a flag assignment that satisfies the constaints of all trees. --- --- Returns either the missing dependencies, or a tuple containing the --- resulting data, the associated dependencies, and the chosen flag --- assignments. --- --- In case of failure, the _smallest_ number of of missing dependencies is --- returned. [TODO: Could also be specified with a function argument.] --- --- TODO: The current algorithm is rather naive. A better approach would be to: --- --- * Rule out possible paths, by taking a look at the associated dependencies. --- --- * Infer the required values for the conditions of these paths, and --- calculate the required domains for the variables used in these --- conditions. Then picking a flag assignment would be linear (I guess). --- --- This would require some sort of SAT solving, though, thus it's not --- implemented unless we really need it. --- -resolveWithFlags :: - [(FlagName,[Bool])] - -- ^ 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 - -> [Dependency] -- ^ Additional constraints - -> [CondTree ConfVar [Dependency] PDTagged] - -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function. - -> Either [Dependency] (TargetSet PDTagged, FlagAssignment) - -- ^ Either the missing dependencies (error case), or a pair of - -- (set of build targets with dependencies, chosen flag assignments) -resolveWithFlags dom os arch impl constrs trees checkDeps = - case try dom [] of - Right r -> Right r - Left dbt -> Left $ findShortest dbt - where - extraConstrs = toDepMap constrs - - -- simplify trees by (partially) evaluating all conditions and converting - -- dependencies to dependency maps. - simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps - . mapTreeConds (fst . simplifyWithSysParams os arch impl)) - trees - - -- @try@ recursively tries all possible flag assignments in the domain and - -- either succeeds or returns a binary tree with the missing dependencies - -- encountered in each run. Since the tree is constructed lazily, we - -- avoid some computation overhead in the successful case. - try [] flags = - let targetSet = TargetSet $ flip map simplifiedTrees $ - -- apply additional constraints to all dependencies - first (`constrainBy` extraConstrs) . - simplifyCondTree (env flags) - deps = overallDependencies targetSet - in case checkDeps (fromDepMap deps) of - DepOk -> Right (targetSet, flags) - MissingDeps mds -> Left (BTN mds) - - try ((n, vals):rest) flags = - tryAll $ map (\v -> try rest ((n, v):flags)) vals - - tryAll = foldr mp mz - - -- special version of `mplus' for our local purposes - mp (Left xs) (Left ys) = (Left (BTB xs ys)) - mp (Left _) m@(Right _) = m - mp m@(Right _) _ = m - - -- `mzero' - mz = Left (BTN []) - - env flags flag = (maybe (Left flag) Right . lookup flag) flags - - -- for the error case we inspect our lazy tree of missing dependencies and - -- pick the shortest list of missing dependencies - findShortest (BTN x) = x - findShortest (BTB lt rt) = - let l = findShortest lt - r = findShortest rt - in case (l,r) of - ([], xs) -> xs -- [] is too short - (xs, []) -> xs - ([x], _) -> [x] -- single elem is optimum - (_, [x]) -> [x] - (xs, ys) -> if lazyLengthCmp xs ys - then xs else ys - -- lazy variant of @\xs ys -> length xs <= length ys@ - lazyLengthCmp [] _ = True - lazyLengthCmp _ [] = False - lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys - --- | A map of dependencies. Newtyped since the default monoid instance is not --- appropriate. The monoid instance uses 'intersectVersionRanges'. -newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName VersionRange } -#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606) - deriving (Show, Read) -#else --- The Show/Read instance for Data.Map in ghc-6.4 is useless --- so we have to re-implement it here: -instance Show DependencyMap where - showsPrec d (DependencyMap m) = - showParen (d > 10) (showString "DependencyMap" . shows (M.toList m)) - -instance Read DependencyMap where - readPrec = parens $ R.prec 10 $ do - R.Ident "DependencyMap" <- R.lexP - xs <- R.readPrec - return (DependencyMap (M.fromList xs)) - where parens :: R.ReadPrec a -> R.ReadPrec a - parens p = optional - where - optional = p R.+++ mandatory - mandatory = paren optional - - paren :: R.ReadPrec a -> R.ReadPrec a - paren p = do L.Punc "(" <- R.lexP - x <- R.reset p - L.Punc ")" <- R.lexP - return x - - readListPrec = R.readListPrecDefault -#endif - -instance Monoid DependencyMap where - mempty = DependencyMap Map.empty - (DependencyMap a) `mappend` (DependencyMap b) = - DependencyMap (Map.unionWith intersectVersionRanges a b) - -toDepMap :: [Dependency] -> DependencyMap -toDepMap ds = - DependencyMap $ fromListWith intersectVersionRanges [ (p,vr) | Dependency p vr <- ds ] - -fromDepMap :: DependencyMap -> [Dependency] -fromDepMap m = [ Dependency p vr | (p,vr) <- toList (unDependencyMap m) ] - -simplifyCondTree :: (Monoid a, Monoid d) => - (v -> Either v Bool) - -> CondTree v d a - -> (d, a) -simplifyCondTree env (CondNode a d ifs) = - foldr mappend (d, a) $ catMaybes $ map simplifyIf ifs - where - simplifyIf (cnd, t, me) = - case simplifyCondition cnd env of - (Lit True, _) -> Just $ simplifyCondTree env t - (Lit False, _) -> fmap (simplifyCondTree env) me - _ -> error $ "Environment not defined for all free vars" - --- | Flatten a CondTree. This will resolve the CondTree by taking all --- possible paths into account. Note that since branches represent exclusive --- choices this may not result in a \"sane\" result. -ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c) -ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs) - where f (_, t, me) = ignoreConditions t - : maybeToList (fmap ignoreConditions me) - -freeVars :: CondTree ConfVar c a -> [FlagName] -freeVars t = [ f | Flag f <- freeVars' t ] - where - freeVars' (CondNode _ _ ifs) = concatMap compfv ifs - compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct - condfv c = case c of - Var v -> [v] - Lit _ -> [] - CNot c' -> condfv c' - COr c1 c2 -> condfv c1 ++ condfv c2 - CAnd c1 c2 -> condfv c1 ++ condfv c2 - - ------------------------------------------------------------------------------- - --- | A set of targets with their package dependencies -newtype TargetSet a = TargetSet [(DependencyMap, a)] - --- | Combine the target-specific dependencies in a TargetSet to give the --- dependencies for the package as a whole. -overallDependencies :: TargetSet PDTagged -> DependencyMap -overallDependencies (TargetSet targets) = mconcat depss - where - (depss, _) = unzip $ filter (removeDisabledTests . snd) targets - removeDisabledTests :: PDTagged -> Bool - removeDisabledTests (Lib _) = True - removeDisabledTests (Exe _ _) = True - removeDisabledTests (Test _ t) = testEnabled t - removeDisabledTests PDNull = True - --- Apply extra constraints to a dependency map. --- Combines dependencies where the result will only contain keys from the left --- (first) map. If a key also exists in the right map, both constraints will --- be intersected. -constrainBy :: DependencyMap -- ^ Input map - -> DependencyMap -- ^ Extra constraints - -> DependencyMap -constrainBy left extra = - DependencyMap $ - Map.foldWithKey tightenConstraint (unDependencyMap left) - (unDependencyMap extra) - where tightenConstraint n c l = - case Map.lookup n l of - Nothing -> l - Just vr -> Map.insert n (intersectVersionRanges vr c) l - --- | Collect up the targets in a TargetSet of tagged targets, storing the --- dependencies as we go. -flattenTaggedTargets :: TargetSet PDTagged -> - (Maybe Library, [(String, Executable)], [(String, TestSuite)]) -flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], []) targets - where - untag (_, Lib _) (Just _, _, _) = bug "Only one library expected" - untag (deps, Lib l) (Nothing, exes, tests) = (Just l', exes, tests) - where - l' = l { - libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps } - } - untag (deps, Exe n e) (mlib, exes, tests) - | any ((== n) . fst) exes = bug "Exe with same name found" - | any ((== n) . fst) tests = bug "Test sharing name of exe found" - | otherwise = (mlib, exes ++ [(n, e')], tests) - where - e' = e { - buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps } - } - untag (deps, Test n t) (mlib, exes, tests) - | any ((== n) . fst) tests = bug "Test with same name found" - | any ((== n) . fst) exes = bug "Test sharing name of exe found" - | otherwise = (mlib, exes, tests ++ [(n, t')]) - where - t' = t { - testBuildInfo = (testBuildInfo t) - { targetBuildDepends = fromDepMap deps } - } - untag (_, PDNull) x = x -- actually this should not happen, but let's be liberal - - ------------------------------------------------------------------------------- --- Convert GenericPackageDescription to PackageDescription --- - -data PDTagged = Lib Library | Exe String Executable | Test String TestSuite | PDNull deriving Show - -instance Monoid PDTagged where - mempty = PDNull - PDNull `mappend` x = x - x `mappend` PDNull = x - Lib l `mappend` Lib l' = Lib (l `mappend` l') - Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e') - Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t') - _ `mappend` _ = bug "Cannot combine incompatible tags" - --- | Create a package description with all configurations resolved. --- --- This function takes a `GenericPackageDescription` and several environment --- parameters and tries to generate `PackageDescription` by finding a flag --- assignment that result in satisfiable dependencies. --- --- It takes as inputs a not necessarily complete specifications of flags --- assignments, an optional package index as well as platform parameters. If --- some flags are not assigned explicitly, this function will try to pick an --- assignment that causes this function to succeed. The package index is --- optional since on some platforms we cannot determine which packages have --- been installed before. When no package index is supplied, every dependency --- is assumed to be satisfiable, therefore all not explicitly assigned flags --- will get their default values. --- --- This function will fail if it cannot find a flag assignment that leads to --- satisfiable dependencies. (It will not try alternative assignments for --- explicitly specified flags.) In case of failure it will return a /minimum/ --- number of dependencies that could not be satisfied. On success, it will --- return the package description and the full flag assignment chosen. --- -finalizePackageDescription :: - FlagAssignment -- ^ Explicitly specified flag assignments - -> (Dependency -> Bool) -- ^ Is a given depenency satisfiable from the set of available packages? - -- If this is unknown then use True. - -> Platform -- ^ The 'Arch' and 'OS' - -> CompilerId -- ^ Compiler + Version - -> [Dependency] -- ^ Additional constraints - -> GenericPackageDescription - -> Either [Dependency] - (PackageDescription, FlagAssignment) - -- ^ Either missing dependencies or the resolved package - -- description along with the flag assignments chosen. -finalizePackageDescription userflags satisfyDep (Platform arch os) impl constraints - (GenericPackageDescription pkg flags mlib0 exes0 tests0) = - case resolveFlags of - Right ((mlib, exes', tests'), targetSet, flagVals) -> - Right ( pkg { library = mlib - , executables = exes' - , testSuites = tests' - , buildDepends = fromDepMap (overallDependencies targetSet) - --TODO: we need to find a way to avoid pulling in deps - -- for non-buildable components. However cannot simply - -- filter at this stage, since if the package were not - -- available we would have failed already. - } - , flagVals ) - - Left missing -> Left missing - where - -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data - condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 ) - ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0 - ++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0 - - resolveFlags = - case resolveWithFlags flagChoices os arch impl constraints condTrees check of - Right (targetSet, fs) -> - let (mlib, exes, tests) = flattenTaggedTargets targetSet in - Right ( (fmap libFillInDefaults mlib, - map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes, - map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests), - targetSet, fs) - Left missing -> Left missing - - flagChoices = map (\(MkFlag n _ d manual) -> (n, d2c manual n d)) flags - d2c manual n b = case lookup n userflags of - Just val -> [val] - Nothing - | manual -> [b] - | otherwise -> [b, not b] - --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices - check ds = if all satisfyDep ds - then DepOk - else MissingDeps $ filter (not . satisfyDep) ds - -{- -let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] []) -let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] []) - -let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])] -let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index -let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds -resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks ===> Right ... -resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks ===> Left ... --} - --- | Flatten a generic package description by ignoring all conditions and just --- join the field descriptors into on package description. Note, however, --- that this may lead to inconsistent field values, since all values are --- joined into one field, which may not be possible in the original package --- description, due to the use of exclusive choices (if ... else ...). --- --- TODO: One particularly tricky case is defaulting. In the original package --- description, e.g., the source directory might either be the default or a --- certain, explicitly set path. Since defaults are filled in only after the --- package has been resolved and when no explicit value has been set, the --- default path will be missing from the package description returned by this --- function. -flattenPackageDescription :: GenericPackageDescription -> PackageDescription -flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0) = - pkg { library = mlib - , executables = reverse exes - , testSuites = reverse tests - , buildDepends = ldeps ++ reverse edeps ++ reverse tdeps - } - where - (mlib, ldeps) = case mlib0 of - Just lib -> let (l,ds) = ignoreConditions lib in - (Just (libFillInDefaults l), ds) - Nothing -> (Nothing, []) - (exes, edeps) = foldr flattenExe ([],[]) exes0 - (tests, tdeps) = foldr flattenTst ([],[]) tests0 - flattenExe (n, t) (es, ds) = - let (e, ds') = ignoreConditions t in - ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds ) - flattenTst (n, t) (es, ds) = - let (e, ds') = ignoreConditions t in - ( (testFillInDefaults $ e { testName = n }) : es, ds' ++ ds ) - --- This is in fact rather a hack. The original version just overrode the --- default values, however, when adding conditions we had to switch to a --- modifier-based approach. There, nothing is ever overwritten, but only --- joined together. --- --- This is the cleanest way i could think of, that doesn't require --- changing all field parsing functions to return modifiers instead. -libFillInDefaults :: Library -> Library -libFillInDefaults lib@(Library { libBuildInfo = bi }) = - lib { libBuildInfo = biFillInDefaults bi } - -exeFillInDefaults :: Executable -> Executable -exeFillInDefaults exe@(Executable { buildInfo = bi }) = - exe { buildInfo = biFillInDefaults bi } - -testFillInDefaults :: TestSuite -> TestSuite -testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) = - tst { testBuildInfo = biFillInDefaults bi } - -biFillInDefaults :: BuildInfo -> BuildInfo -biFillInDefaults bi = - if null (hsSourceDirs bi) - then bi { hsSourceDirs = [currentDir] } - else bi - -bug :: String -> a -bug msg = error $ msg ++ ". Consider this a bug." diff --git a/cabal/cabal/Distribution/PackageDescription/Parse.hs b/cabal/cabal/Distribution/PackageDescription/Parse.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/PackageDescription/Parse.hs +++ /dev/null @@ -1,1074 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.Parse --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defined parsers and partial pretty printers for the @.cabal@ format. --- Some of the complexity in this module is due to the fact that we have to be --- 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, - writePackageDescription, - parsePackageDescription, - showPackageDescription, - - -- ** Parsing - ParseResult(..), - FieldDescr(..), - LineNo, - - -- ** Supplementary build information - readHookedBuildInfo, - parseHookedBuildInfo, - writeHookedBuildInfo, - showHookedBuildInfo, - - pkgDescrFieldDescrs, - libFieldDescrs, - executableFieldDescrs, - binfoFieldDescrs, - sourceRepoFieldDescrs, - testSuiteFieldDescrs, - flagFieldDescrs - ) where - -import Data.Char (isSpace) -import Data.Maybe (listToMaybe, isJust) -import Data.Monoid ( Monoid(..) ) -import Data.List (nub, unfoldr, partition, (\\)) -import Control.Monad (liftM, foldM, when, unless) -import System.Directory (doesFileExist) - -import Distribution.Text - ( Text(disp, parse), display, simpleParse ) -import Distribution.Compat.ReadP - ((+++), option) -import Text.PrettyPrint.HughesPJ - -import Distribution.ParseUtils hiding (parseFields) -import Distribution.PackageDescription -import Distribution.Package - ( PackageIdentifier(..), Dependency(..), packageName, packageVersion ) -import Distribution.ModuleName ( ModuleName ) -import Distribution.Version - ( Version(Version), orLaterVersion - , LowerBound(..), asVersionIntervals ) -import Distribution.Verbosity (Verbosity) -import Distribution.Compiler (CompilerFlavor(..)) -import Distribution.PackageDescription.Configuration (parseCondition, freeVars) -import Distribution.Simple.Utils - ( die, dieWithLocation, warn, intercalate, lowercase, cabalVersion - , withFileContents, withUTF8FileContents - , writeFileAtomic, writeUTF8File ) - - --- ----------------------------------------------------------------------------- --- The PackageDescription type - -pkgDescrFieldDescrs :: [FieldDescr PackageDescription] -pkgDescrFieldDescrs = - [ simpleField "name" - disp parse - packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}}) - , simpleField "version" - disp parse - packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) - , simpleField "cabal-version" - (either disp disp) (liftM Left parse +++ liftM Right parse) - specVersionRaw (\v pkg -> pkg{specVersionRaw=v}) - , simpleField "build-type" - (maybe empty disp) (fmap Just parse) - buildType (\t pkg -> pkg{buildType=t}) - , simpleField "license" - disp parseLicenseQ - license (\l pkg -> pkg{license=l}) - , simpleField "license-file" - showFilePath parseFilePathQ - licenseFile (\l pkg -> pkg{licenseFile=l}) - , 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}) - , simpleField "homepage" - showFreeText parseFreeText - homepage (\val pkg -> pkg{homepage=val}) - , simpleField "package-url" - showFreeText parseFreeText - pkgUrl (\val pkg -> pkg{pkgUrl=val}) - , simpleField "bug-reports" - showFreeText parseFreeText - bugReports (\val pkg -> pkg{bugReports=val}) - , simpleField "synopsis" - showFreeText parseFreeText - synopsis (\val pkg -> pkg{synopsis=val}) - , simpleField "description" - showFreeText parseFreeText - description (\val pkg -> pkg{description=val}) - , simpleField "category" - showFreeText parseFreeText - category (\val pkg -> pkg{category=val}) - , simpleField "author" - showFreeText parseFreeText - author (\val pkg -> pkg{author=val}) - , listField "tested-with" - showTestedWith parseTestedWithQ - testedWith (\val pkg -> pkg{testedWith=val}) - , listField "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" - showFilePath parseFilePathQ - extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val}) - , listField "extra-tmp-files" - showFilePath parseFilePathQ - extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val}) - ] - --- | Store any fields beginning with "x-" in the customFields field of --- a PackageDescription. All other fields will generate a warning. -storeXFieldsPD :: UnrecFieldParser PackageDescription -storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD = - (customFieldsPD pkg) ++ [(f,val)]} -storeXFieldsPD _ _ = Nothing - --- --------------------------------------------------------------------------- --- The Library type - -libFieldDescrs :: [FieldDescr Library] -libFieldDescrs = - [ listField "exposed-modules" disp parseModuleNameQ - exposedModules (\mods lib -> lib{exposedModules=mods}) - - , boolField "exposed" - libExposed (\val lib -> lib{libExposed=val}) - ] ++ map biToLib binfoFieldDescrs - where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi}) - -storeXFieldsLib :: UnrecFieldParser Library -storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) = - Just $ l {libBuildInfo = bi{ customFieldsBI = (customFieldsBI bi) ++ [(f,val)]}} -storeXFieldsLib _ _ = Nothing - --- --------------------------------------------------------------------------- --- The Executable type - - -executableFieldDescrs :: [FieldDescr Executable] -executableFieldDescrs = - [ -- note ordering: configuration must come first, for - -- showPackageDescription. - simpleField "executable" - showToken parseTokenQ - exeName (\xs exe -> exe{exeName=xs}) - , simpleField "main-is" - showFilePath parseFilePathQ - modulePath (\xs exe -> exe{modulePath=xs}) - ] - ++ map biToExe binfoFieldDescrs - where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi}) - -storeXFieldsExe :: UnrecFieldParser Executable -storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) = - Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}} -storeXFieldsExe _ _ = Nothing - --- --------------------------------------------------------------------------- --- The TestSuite type - --- | An intermediate type just used for parsing the test-suite stanza. --- After validation it is converted into the proper 'TestSuite' type. -data TestSuiteStanza = TestSuiteStanza { - testStanzaTestType :: Maybe TestType, - testStanzaMainIs :: Maybe FilePath, - testStanzaTestModule :: Maybe ModuleName, - testStanzaBuildInfo :: BuildInfo - } - -emptyTestStanza :: TestSuiteStanza -emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty - -testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza] -testSuiteFieldDescrs = - [ simpleField "type" - (maybe empty disp) (fmap Just parse) - testStanzaTestType (\x suite -> suite { testStanzaTestType = x }) - , simpleField "main-is" - (maybe empty showFilePath) (fmap Just parseFilePathQ) - testStanzaMainIs (\x suite -> suite { testStanzaMainIs = x }) - , simpleField "test-module" - (maybe empty disp) (fmap Just parseModuleNameQ) - testStanzaTestModule (\x suite -> suite { testStanzaTestModule = x }) - ] - ++ map biToTest binfoFieldDescrs - where - biToTest = liftField testStanzaBuildInfo - (\bi suite -> suite { testStanzaBuildInfo = bi }) - -storeXFieldsTest :: UnrecFieldParser TestSuiteStanza -storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) = - Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}} -storeXFieldsTest _ _ = Nothing - -validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite -validateTestSuite line stanza = - case testStanzaTestType stanza of - Nothing -> return $ - emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza } - - Just tt@(TestTypeUnknown _ _) -> - return emptyTestSuite { - testInterface = TestSuiteUnsupported tt, - testBuildInfo = testStanzaBuildInfo stanza - } - - Just tt | tt `notElem` knownTestTypes -> - return emptyTestSuite { - testInterface = TestSuiteUnsupported tt, - testBuildInfo = testStanzaBuildInfo stanza - } - - Just tt@(TestTypeExe ver) -> - case testStanzaMainIs stanza of - Nothing -> syntaxError line (missingField "main-is" tt) - Just file -> do - when (isJust (testStanzaTestModule stanza)) $ - warning (extraField "test-module" tt) - return emptyTestSuite { - testInterface = TestSuiteExeV10 ver file, - testBuildInfo = testStanzaBuildInfo stanza - } - - Just tt@(TestTypeLib ver) -> - case testStanzaTestModule stanza of - Nothing -> syntaxError line (missingField "test-module" tt) - Just module_ -> do - when (isJust (testStanzaMainIs stanza)) $ - warning (extraField "main-is" tt) - return emptyTestSuite { - testInterface = TestSuiteLibV09 ver module_, - testBuildInfo = testStanzaBuildInfo stanza - } - - where - missingField name tt = "The '" ++ name ++ "' field is required for the " - ++ display tt ++ " test suite type." - - extraField name tt = "The '" ++ name ++ "' field is not used for the '" - ++ display tt ++ "' test suite type." - - --- --------------------------------------------------------------------------- --- The BuildInfo type - - -binfoFieldDescrs :: [FieldDescr BuildInfo] -binfoFieldDescrs = - [ boolField "buildable" - buildable (\val binfo -> binfo{buildable=val}) - , commaListField "build-tools" - disp parseBuildTool - buildTools (\xs binfo -> binfo{buildTools=xs}) - , spaceListField "cpp-options" - showToken parseTokenQ' - cppOptions (\val binfo -> binfo{cppOptions=val}) - , spaceListField "cc-options" - showToken parseTokenQ' - ccOptions (\val binfo -> binfo{ccOptions=val}) - , spaceListField "ld-options" - showToken parseTokenQ' - ldOptions (\val binfo -> binfo{ldOptions=val}) - , commaListField "pkgconfig-depends" - disp parsePkgconfigDependency - pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs}) - , listField "frameworks" - showToken parseTokenQ - frameworks (\val binfo -> binfo{frameworks=val}) - , listField "c-sources" - showFilePath parseFilePathQ - cSources (\paths binfo -> binfo{cSources=paths}) - - , simpleField "default-language" - (maybe empty disp) (option Nothing (fmap Just parseLanguageQ)) - defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang}) - , listField "other-languages" - disp parseLanguageQ - otherLanguages (\langs binfo -> binfo{otherLanguages=langs}) - , listField "default-extensions" - disp parseExtensionQ - defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts}) - , listField "other-extensions" - disp parseExtensionQ - otherExtensions (\exts binfo -> binfo{otherExtensions=exts}) - , listField "extensions" - disp parseExtensionQ - oldExtensions (\exts binfo -> binfo{oldExtensions=exts}) - - , listField "extra-libraries" - showToken parseTokenQ - extraLibs (\xs binfo -> binfo{extraLibs=xs}) - , listField "extra-lib-dirs" - showFilePath parseFilePathQ - extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs}) - , listField "includes" - showFilePath parseFilePathQ - includes (\paths binfo -> binfo{includes=paths}) - , listField "install-includes" - showFilePath parseFilePathQ - installIncludes (\paths binfo -> binfo{installIncludes=paths}) - , listField "include-dirs" - showFilePath parseFilePathQ - includeDirs (\paths binfo -> binfo{includeDirs=paths}) - , listField "hs-source-dirs" - showFilePath parseFilePathQ - hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths}) - , listField "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-options" GHC - options (\path binfo -> binfo{options=path}) - , optsField "hugs-options" Hugs - options (\path binfo -> binfo{options=path}) - , optsField "nhc98-options" NHC - options (\path binfo -> binfo{options=path}) - , optsField "jhc-options" JHC - options (\path binfo -> binfo{options=path}) - ] - -storeXFieldsBI :: UnrecFieldParser BuildInfo -storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) } -storeXFieldsBI _ _ = Nothing - ------------------------------------------------------------------------------- - -flagFieldDescrs :: [FieldDescr Flag] -flagFieldDescrs = - [ simpleField "description" - showFreeText parseFreeText - flagDescription (\val fl -> fl{ flagDescription = val }) - , boolField "default" - flagDefault (\val fl -> fl{ flagDefault = val }) - , boolField "manual" - flagManual (\val fl -> fl{ flagManual = val }) - ] - ------------------------------------------------------------------------------- - -sourceRepoFieldDescrs :: [FieldDescr SourceRepo] -sourceRepoFieldDescrs = - [ simpleField "type" - (maybe empty disp) (fmap Just parse) - repoType (\val repo -> repo { repoType = val }) - , simpleField "location" - (maybe empty showFreeText) (fmap Just parseFreeText) - repoLocation (\val repo -> repo { repoLocation = val }) - , simpleField "module" - (maybe empty showToken) (fmap Just parseTokenQ) - repoModule (\val repo -> repo { repoModule = val }) - , simpleField "branch" - (maybe empty showToken) (fmap Just parseTokenQ) - repoBranch (\val repo -> repo { repoBranch = val }) - , simpleField "tag" - (maybe empty showToken) (fmap Just parseTokenQ) - repoTag (\val repo -> repo { repoTag = val }) - , simpleField "subdir" - (maybe empty showFilePath) (fmap Just parseFilePathQ) - repoSubdir (\val repo -> repo { repoSubdir = val }) - ] - --- --------------------------------------------------------------- --- Parsing - --- | Given a parser and a filename, return the parse of the file, --- after checking if the file exists. -readAndParseFile :: (FilePath -> (String -> IO a) -> IO a) - -> (String -> ParseResult a) - -> Verbosity - -> FilePath -> IO a -readAndParseFile withFileContents' parser verbosity fpath = do - exists <- doesFileExist fpath - when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.") - withFileContents' fpath $ \str -> case parser str of - ParseFailed e -> do - let (line, message) = locatedErrorMsg e - dieWithLocation fpath line message - ParseOk warnings x -> do - mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings - return x - -readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo -readHookedBuildInfo = - readAndParseFile withFileContents parseHookedBuildInfo - --- |Parse the given package file. -readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription -readPackageDescription = - readAndParseFile withUTF8FileContents parsePackageDescription - -stanzas :: [Field] -> [[Field]] -stanzas [] = [] -stanzas (f:fields) = (f:this) : stanzas rest - where - (this, rest) = break isStanzaHeader fields - -isStanzaHeader :: Field -> Bool -isStanzaHeader (F _ f _) = f == "executable" -isStanzaHeader _ = False - ------------------------------------------------------------------------------- - - -mapSimpleFields :: (Field -> ParseResult Field) -> [Field] - -> ParseResult [Field] -mapSimpleFields f fs = mapM walk fs - where - walk fld@(F _ _ _) = f fld - walk (IfBlock l c fs1 fs2) = do - fs1' <- mapM walk fs1 - fs2' <- mapM walk fs2 - return (IfBlock l c fs1' fs2') - walk (Section ln n l fs1) = do - fs1' <- mapM walk fs1 - return (Section ln n l fs1') - --- prop_isMapM fs = mapSimpleFields return fs == return fs - - --- names of fields that represents dependencies, thus consrca -constraintFieldNames :: [String] -constraintFieldNames = ["build-depends"] - --- Possible refactoring would be to have modifiers be explicit about what --- 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 (F l n v) - | n == "build-depends" = runP l n (parseCommaList parse) v -parseConstraint f = bug $ "Constraint was expected (got: " ++ show f ++ ")" - -{- -headerFieldNames :: [String] -headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames)) - . map fieldName $ pkgDescrFieldDescrs --} - -libFieldNames :: [String] -libFieldNames = map fieldName libFieldDescrs - ++ buildInfoNames ++ constraintFieldNames - --- exeFieldNames :: [String] --- exeFieldNames = map fieldName executableFieldDescrs --- ++ buildInfoNames - -buildInfoNames :: [String] -buildInfoNames = map fieldName binfoFieldDescrs - ++ map fst deprecatedFieldsBuildInfo - --- A minimal implementation of the StateT monad transformer to avoid depending --- on the 'mtl' package. -newtype StT s m a = StT { runStT :: s -> m (a,s) } - -instance Monad m => Monad (StT s m) where - return a = StT (\s -> return (a,s)) - StT f >>= g = StT $ \s -> do - (a,s') <- f s - runStT (g a) s' - -get :: Monad m => StT s m s -get = StT $ \s -> return (s, s) - -modify :: Monad m => (s -> s) -> StT s m () -modify f = StT $ \s -> return ((),f s) - -lift :: Monad m => m a -> StT s m a -lift m = StT $ \s -> m >>= \a -> return (a,s) - -evalStT :: Monad m => StT s m a -> s -> m a -evalStT st s = runStT st s >>= return . fst - --- Our monad for parsing a list/tree of fields. --- --- The state represents the remaining fields to be processed. -type PM a = StT [Field] ParseResult a - - - --- return look-ahead field or nothing if we're at the end of the file -peekField :: PM (Maybe Field) -peekField = get >>= return . listToMaybe - --- Unconditionally discard the first field in our state. Will error when it --- reaches end of file. (Yes, that's evil.) -skipField :: PM () -skipField = modify tail - ---FIXME: this should take a ByteString, not a String. We have to be able to --- decode UTF8 and handle the BOM. - --- | Parses the given file into a 'GenericPackageDescription'. --- --- In Cabal 1.2 the syntax for package descriptions was changed to a format --- with sections and possibly indented property descriptions. -parsePackageDescription :: String -> ParseResult GenericPackageDescription -parsePackageDescription file = do - - -- This function is quite complex because it needs to be able to parse - -- both pre-Cabal-1.2 and post-Cabal-1.2 files. Additionally, it contains - -- a lot of parser-related noise since we do not want to depend on Parsec. - -- - -- If we detect an pre-1.2 file we implicitly convert it to post-1.2 - -- style. See 'sectionizeFields' below for details about the conversion. - - fields0 <- readFields file `catchParseError` \err -> - let tabs = findIndentTabs file in - case err of - -- In case of a TabsError report them all at once. - TabsError tabLineNo -> reportTabsError - -- but only report the ones including and following - -- the one that caused the actual error - [ t | t@(lineNo',_) <- tabs - , lineNo' >= tabLineNo ] - _ -> parseFail err - - let cabalVersionNeeded = - head $ [ minVersionBound versionRange - | Just versionRange <- [ simpleParse v - | F _ "cabal-version" v <- fields0 ] ] - ++ [Version [0] []] - minVersionBound versionRange = - case asVersionIntervals versionRange of - [] -> Version [0] [] - ((LowerBound version _, _):_) -> version - - handleFutureVersionParseFailure cabalVersionNeeded $ do - - let sf = sectionizeFields fields0 -- ensure 1.2 format - - -- figure out and warn about deprecated stuff (warnings are collected - -- inside our parsing monad) - fields <- mapSimpleFields deprecField sf - - -- Our parsing monad takes the not-yet-parsed fields as its state. - -- After each successful parse we remove the field from the state - -- ('skipField') and move on to the next one. - -- - -- Things are complicated a bit, because fields take a tree-like - -- structure -- they can be sections or "if"/"else" conditionals. - - flip evalStT fields $ do - - -- The header consists of all simple fields up to the first section - -- (flag, library, executable). - header_fields <- getHeader [] - - -- Parses just the header fields and stores them in a - -- 'PackageDescription'. Note that our final result is a - -- 'GenericPackageDescription'; for pragmatic reasons we just store - -- the partially filled-out 'PackageDescription' inside the - -- 'GenericPackageDescription'. - pkg <- lift $ parseFields pkgDescrFieldDescrs - storeXFieldsPD - emptyPackageDescription - header_fields - - -- 'getBody' assumes that the remaining fields only consist of - -- flags, lib and exe sections. - (repos, flags, mlib, exes, tests) <- 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 } - flags mlib exes tests - - where - oldSyntax flds = all isSimpleField flds - reportTabsError tabs = - syntaxError (fst (head tabs)) $ - "Do not use tabs for indentation (use spaces instead)\n" - ++ " Tabs were used at (line,column): " ++ show tabs - - maybeWarnCabalVersion newsyntax pkg - | newsyntax && specVersion pkg < Version [1,2] [] - = lift $ warning $ - "A package using section syntax must specify at least\n" - ++ "'cabal-version: >= 1.2'." - - maybeWarnCabalVersion newsyntax pkg - | not newsyntax && specVersion pkg >= Version [1,2] [] - = lift $ warning $ - "A package using 'cabal-version: " - ++ displaySpecVersion (specVersionRaw pkg) - ++ "' must use section syntax. See the Cabal user guide for details." - where - displaySpecVersion (Left version) = display version - displaySpecVersion (Right versionRange) = - case asVersionIntervals versionRange of - [] {- impossible -} -> display versionRange - ((LowerBound version _, _):_) -> display (orLaterVersion version) - - maybeWarnCabalVersion _ _ = return () - - - handleFutureVersionParseFailure cabalVersionNeeded parseBody = - (unless versionOk (warning message) >> parseBody) - `catchParseError` \parseError -> case parseError of - TabsError _ -> parseFail parseError - _ | versionOk -> parseFail parseError - | otherwise -> fail message - where versionOk = cabalVersionNeeded <= cabalVersion - message = "This package requires at least Cabal version " - ++ display cabalVersionNeeded - - -- "Sectionize" an old-style Cabal file. A sectionized file has: - -- - -- * all global fields at the beginning, followed by - -- - -- * all flag declarations, followed by - -- - -- * an optional library section, and an arbitrary number of executable - -- sections (in any order). - -- - -- The current implementatition just gathers all library-specific fields - -- in a library section and wraps all executable stanzas in an executable - -- section. - sectionizeFields :: [Field] -> [Field] - sectionizeFields fs - | oldSyntax fs = - let - -- "build-depends" is a local field now. To be backwards - -- compatible, we still allow it as a global field in old-style - -- package description files and translate it to a local field by - -- adding it to every non-empty section - (hdr0, exes0) = break ((=="executable") . fName) fs - (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0 - - (deps, libfs) = partition ((== "build-depends") . fName) - libfs0 - - exes = unfoldr toExe exes0 - toExe [] = Nothing - toExe (F l e n : r) - | e == "executable" = - let (efs, r') = break ((=="executable") . fName) r - in Just (Section l "executable" n (deps ++ efs), r') - toExe _ = bug "unexpeced input to 'toExe'" - in - hdr ++ - (if null libfs then [] - else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)]) - ++ exes - | otherwise = fs - - isSimpleField (F _ _ _) = True - isSimpleField _ = False - - -- warn if there's something at the end of the file - warnIfRest :: PM () - warnIfRest = do - s <- get - case s of - [] -> return () - _ -> lift $ warning "Ignoring trailing declarations." -- add line no. - - -- all simple fields at the beginning of the file are (considered) header - -- fields - getHeader :: [Field] -> PM [Field] - getHeader acc = peekField >>= \mf -> case mf of - Just f@(F _ _ _) -> skipField >> getHeader (f:acc) - _ -> return (reverse acc) - - -- - -- body ::= { repo | flag | library | executable | test }+ -- at most one lib - -- - -- 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 (CondTree ConfVar [Dependency] Library) - ,[(String, CondTree ConfVar [Dependency] Executable)] - ,[(String, CondTree ConfVar [Dependency] TestSuite)]) - getBody = peekField >>= \mf -> case mf of - Just (Section line_no sec_type sec_label sec_fields) - | sec_type == "executable" -> do - when (null sec_label) $ lift $ syntaxError line_no - "'executable' needs one argument (the executable's name)" - exename <- lift $ runP line_no "executable" parseTokenQ sec_label - flds <- collectFields parseExeFields sec_fields - skipField - (repos, flags, lib, exes, tests) <- getBody - return (repos, flags, lib, (exename, flds): exes, tests) - - | sec_type == "test-suite" -> do - when (null sec_label) $ lift $ syntaxError line_no - "'test-suite' needs one argument (the test suite's name)" - testname <- lift $ runP line_no "test" parseTokenQ sec_label - flds <- collectFields (parseTestFields line_no) sec_fields - - -- Check that a valid test suite type has been chosen. A type - -- field may be given inside a conditional block, so we must - -- check for that before complaining that a type field has not - -- been given. The test suite must always have a valid type, so - -- we need to check both the 'then' and 'else' blocks, though - -- the blocks need not have the same type. - let checkTestType ts ct = - let ts' = mappend ts $ condTreeData ct - -- If a conditional has only a 'then' block and no - -- 'else' block, then it cannot have a valid type - -- in every branch, unless the type is specified at - -- a higher level in the tree. - checkComponent (_, _, Nothing) = False - -- If a conditional has a 'then' block and an 'else' - -- block, both must specify a test type, unless the - -- type is specified higher in the tree. - checkComponent (_, t, Just e) = - checkTestType ts' t && checkTestType ts' e - -- Does the current node specify a test type? - hasTestType = testInterface ts' - /= testInterface emptyTestSuite - components = condTreeComponents ct - -- If the current level of the tree specifies a type, - -- then we are done. If not, then one of the conditional - -- branches below the current node must specify a type. - -- Each node may have multiple immediate children; we - -- only one need one to specify a type because the - -- configure step uses 'mappend' to join together the - -- results of flag resolution. - in hasTestType || (any checkComponent components) - if checkTestType emptyTestSuite flds - then do - skipField - (repos, flags, lib, exes, tests) <- getBody - return (repos, flags, lib, exes, (testname, flds) : tests) - else lift $ syntaxError line_no $ - "Test suite \"" ++ testname - ++ "\" is missing required field \"type\" or the field " - ++ "is not present in all conditional branches. The " - ++ "available test types are: " - ++ intercalate ", " (map display knownTestTypes) - - | sec_type == "library" -> do - when (not (null sec_label)) $ lift $ - syntaxError line_no "'library' expects no argument" - flds <- collectFields parseLibFields sec_fields - skipField - (repos, flags, lib, exes, tests) <- 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) - - | sec_type == "flag" -> do - when (null sec_label) $ lift $ - syntaxError line_no "'flag' needs one argument (the flag's name)" - flag <- lift $ parseFields - flagFieldDescrs - warnUnrec - (MkFlag (FlagName (lowercase sec_label)) "" True False) - sec_fields - skipField - (repos, flags, lib, exes, tests) <- getBody - return (repos, flag:flags, lib, exes, tests) - - | sec_type == "source-repository" -> do - when (null sec_label) $ lift $ syntaxError line_no $ - "'source-repository' needs one argument, " - ++ "the repo kind which is usually 'head' or 'this'" - kind <- case simpleParse sec_label of - Just kind -> return kind - Nothing -> lift $ syntaxError line_no $ - "could not parse repo kind: " ++ sec_label - repo <- lift $ parseFields - sourceRepoFieldDescrs - warnUnrec - (SourceRepo { - repoKind = kind, - repoType = Nothing, - repoLocation = Nothing, - repoModule = Nothing, - repoBranch = Nothing, - repoTag = Nothing, - repoSubdir = Nothing - }) - sec_fields - skipField - (repos, flags, lib, exes, tests) <- getBody - return (repo:repos, flags, lib, exes, tests) - - | otherwise -> do - lift $ warning $ "Ignoring unknown section type: " ++ sec_type - skipField - getBody - Just f -> do - _ <- lift $ syntaxError (lineNo f) $ - "Construct not supported at this position: " ++ show f - skipField - getBody - Nothing -> return ([], [], Nothing, [], []) - - -- Extracts all fields in a block and returns a 'CondTree'. - -- - -- We have to recurse down into conditionals and we treat fields that - -- describe dependencies specially. - collectFields :: ([Field] -> PM a) -> [Field] - -> PM (CondTree ConfVar [Dependency] a) - collectFields parser allflds = do - - let simplFlds = [ F l n v | F l n v <- allflds ] - condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ] - - let (depFlds, dataFlds) = partition isConstraint simplFlds - - a <- parser dataFlds - deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds - - ifs <- mapM processIfs condFlds - - return (CondNode a deps ifs) - where - isConstraint (F _ n _) = n `elem` constraintFieldNames - isConstraint _ = False - - processIfs (IfBlock l c t e) = do - cnd <- lift $ runP l "if" parseCondition c - t' <- collectFields parser t - e' <- case e of - [] -> return Nothing - es -> do fs <- collectFields parser es - return (Just fs) - return (cnd, t', e') - processIfs _ = bug "processIfs called with wrong field type" - - parseLibFields :: [Field] -> PM Library - parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary - - -- Note: we don't parse the "executable" field here, hence the tail hack. - parseExeFields :: [Field] -> PM Executable - parseExeFields = lift . parseFields (tail executableFieldDescrs) storeXFieldsExe emptyExecutable - - parseTestFields :: LineNo -> [Field] -> PM TestSuite - parseTestFields line fields = do - x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest - emptyTestStanza fields - lift $ validateTestSuite line x - - checkForUndefinedFlags :: - [Flag] -> - Maybe (CondTree ConfVar [Dependency] Library) -> - [(String, CondTree ConfVar [Dependency] Executable)] -> - [(String, CondTree ConfVar [Dependency] TestSuite)] -> - PM () - checkForUndefinedFlags flags mlib exes tests = do - let definedFlags = map flagName flags - maybe (return ()) (checkCondTreeFlags definedFlags) mlib - mapM_ (checkCondTreeFlags definedFlags . snd) exes - mapM_ (checkCondTreeFlags definedFlags . snd) tests - - checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM () - checkCondTreeFlags definedFlags ct = do - let fv = nub $ freeVars ct - when (not . all (`elem` definedFlags) $ fv) $ - fail $ "These flags are used without having been defined: " - ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] - - --- | Parse a list of fields, given a list of field descriptions, --- a structure to accumulate the parsed fields, and a function --- that can decide what to do with fields which don't match any --- of the field descriptions. -parseFields :: [FieldDescr a] -- ^ descriptions of fields we know how to - -- parse - -> UnrecFieldParser a -- ^ possibly do something with - -- unrecognized fields - -> a -- ^ accumulator - -> [Field] -- ^ fields to be parsed - -> ParseResult a -parseFields descrs unrec ini fields = - do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields - when (not (null unknowns)) $ do - warning $ render $ - text "Unknown fields:" <+> - commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")") - (reverse unknowns)) - $+$ - text "Fields allowed in this section:" $$ - nest 4 (commaSep $ map fieldName descrs) - return a - where - commaSep = fsep . punctuate comma . map text - -parseField :: [FieldDescr a] -- ^ list of parseable fields - -> UnrecFieldParser a -- ^ possibly do something with - -- unrecognized fields - -> (a,[(Int,String)]) -- ^ accumulated result and warnings - -> Field -- ^ the field to be parsed - -> ParseResult (a, [(Int,String)]) -parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val) - | name == f = parser line val a >>= \a' -> return (a',us) - | otherwise = parseField fields unrec (a,us) (F line f val) -parseField [] unrec (a,us) (F l f val) = return $ - case unrec (f,val) a of -- no fields matched, see if the 'unrec' - Just a' -> (a',us) -- function wants to do anything with it - Nothing -> (a, ((l,f):us)) -parseField _ _ _ _ = bug "'parseField' called on a non-field" - -deprecatedFields :: [(String,String)] -deprecatedFields = - deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo - -deprecatedFieldsPkgDescr :: [(String,String)] -deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ] - -deprecatedFieldsBuildInfo :: [(String,String)] -deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ] - --- Handle deprecated fields -deprecField :: Field -> ParseResult Field -deprecField (F line fld val) = do - fld' <- case lookup fld deprecatedFields of - Nothing -> return fld - Just newName -> do - warning $ "The field \"" ++ fld - ++ "\" is deprecated, please use \"" ++ newName ++ "\"" - return newName - return (F line fld' val) -deprecField _ = bug "'deprecField' called on a non-field" - - -parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo -parseHookedBuildInfo inp = do - fields <- readFields inp - let ss@(mLibFields:exes) = stanzas fields - mLib <- parseLib mLibFields - biExes <- mapM parseExe (maybe ss (const exes) mLib) - return (mLib, biExes) - where - parseLib :: [Field] -> ParseResult (Maybe BuildInfo) - parseLib (bi@((F _ inFieldName _):_)) - | lowercase inFieldName /= "executable" = liftM Just (parseBI bi) - parseLib _ = return Nothing - - parseExe :: [Field] -> ParseResult (String, BuildInfo) - parseExe ((F line inFieldName mName):bi) - | lowercase inFieldName == "executable" - = do bis <- parseBI bi - return (mName, bis) - | otherwise = syntaxError line "expecting 'executable' at top of stanza" - parseExe (_:_) = bug "`parseExe' called on a non-field" - parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza" - - parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st - --- --------------------------------------------------------------------------- --- Pretty printing - -writePackageDescription :: FilePath -> PackageDescription -> IO () -writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) - ---TODO: make this use section syntax --- add equivalent for GenericPackageDescription -showPackageDescription :: PackageDescription -> String -showPackageDescription pkg = render $ - ppPackage pkg - $$ ppCustomFields (customFieldsPD pkg) - $$ (case library pkg of - Nothing -> empty - Just lib -> ppLibrary lib) - $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ] - where - ppPackage = ppFields pkgDescrFieldDescrs - ppLibrary = ppFields libFieldDescrs - ppExecutable = ppFields executableFieldDescrs - -ppCustomFields :: [(String,String)] -> Doc -ppCustomFields flds = vcat (map ppCustomField flds) - -ppCustomField :: (String,String) -> Doc -ppCustomField (name,val) = text name <> colon <+> showFreeText val - -writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () -writeHookedBuildInfo fpath = writeFileAtomic fpath . showHookedBuildInfo - -showHookedBuildInfo :: HookedBuildInfo -> String -showHookedBuildInfo (mb_lib_bi, ex_bis) = render $ - (case mb_lib_bi of - Nothing -> empty - Just bi -> ppBuildInfo bi) - $$ vcat [ space - $$ text "executable:" <+> text name - $$ ppBuildInfo bi - | (name, bi) <- ex_bis ] - where - ppBuildInfo bi = ppFields binfoFieldDescrs bi - $$ ppCustomFields (customFieldsBI bi) - --- replace all tabs used as indentation with whitespace, also return where --- tabs were found -findIndentTabs :: String -> [(Int,Int)] -findIndentTabs = concatMap checkLine - . zip [1..] - . lines - where - checkLine (lineno, l) = - let (indent, _content) = span isSpace l - tabCols = map fst . filter ((== '\t') . snd) . zip [0..] - addLineNo = map (\col -> (lineno,col)) - in addLineNo (tabCols indent) - ---test_findIndentTabs = findIndentTabs $ unlines $ --- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ] - -bug :: String -> a -bug msg = error $ msg ++ ". Consider this a bug." diff --git a/cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs b/cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs +++ /dev/null @@ -1,238 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Distribution.PackageDescription.PrettyPrint --- Copyright : Jürgen Nicklisch-Franken 2010 --- License : AllRightsReserved --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- | 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 - -import Distribution.PackageDescription - ( TestSuite(..), TestSuiteInterface(..), testType - , SourceRepo(..), - customFieldsBI, CondTree(..), Condition(..), - FlagName(..), ConfVar(..), Executable(..), Library(..), - Flag(..), PackageDescription(..), - GenericPackageDescription(..)) -import Text.PrettyPrint - (hsep, comma, punctuate, fsep, parens, char, nest, empty, - isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render) -import Distribution.Simple.Utils (writeUTF8File) -import Distribution.ParseUtils (showFreeText, FieldDescr(..)) -import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs, - sourceRepoFieldDescrs) -import Distribution.Package (Dependency(..)) -import Distribution.Text (Text(..)) -import Data.Maybe (isJust, fromJust, isNothing) - -indentWith :: Int -indentWith = 4 - --- | Recompile with false for regression testing -simplifiedPrinting :: Bool -simplifiedPrinting = False - --- | Writes a .cabal file from a generic package description -writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO () -writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg) - --- | Writes a generic package description to a string -showGenericPackageDescription :: GenericPackageDescription -> String -showGenericPackageDescription = render . ppGenericPackageDescription - -ppGenericPackageDescription :: GenericPackageDescription -> Doc -ppGenericPackageDescription gpd = - ppPackageDescription (packageDescription gpd) - $+$ ppGenPackageFlags (genPackageFlags gpd) - $+$ ppLibrary (condLibrary gpd) - $+$ ppExecutables (condExecutables gpd) - $+$ ppTestSuites (condTestSuites gpd) - -ppPackageDescription :: PackageDescription -> Doc -ppPackageDescription pd = ppFields pkgDescrFieldDescrs pd - $+$ ppCustomFields (customFieldsPD pd) - $+$ ppSourceRepos (sourceRepos pd) - -ppSourceRepos :: [SourceRepo] -> Doc -ppSourceRepos [] = empty -ppSourceRepos (hd:tl) = ppSourceRepo hd $+$ ppSourceRepos tl - -ppSourceRepo :: SourceRepo -> Doc -ppSourceRepo repo = - emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$ - (nest indentWith (ppFields sourceRepoFieldDescrs' repo)) - 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] - -ppField :: String -> Doc -> Doc -ppField name fielddoc | isEmpty fielddoc = empty - | otherwise = text name <> colon <+> fielddoc - -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)] - -ppCustomFields :: [(String,String)] -> Doc -ppCustomFields flds = vcat [ppCustomField f | f <- flds] - -ppCustomField :: (String,String) -> Doc -ppCustomField (name,val) = text name <> colon <+> showFreeText val - -ppGenPackageFlags :: [Flag] -> Doc -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))) - -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 - $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) - ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib - $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) - -ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc -ppExecutables exes = - vcat [emptyLine $ text ("executable " ++ n) - $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes] - where - ppExe (Executable _ modulePath' buildInfo') Nothing = - (if modulePath' == "" then empty else text "main-is:" <+> text modulePath') - $+$ ppFields binfoFieldDescrs buildInfo' - $+$ ppCustomFields (customFieldsBI buildInfo') - ppExe (Executable _ modulePath' buildInfo') - (Just (Executable _ modulePath2 buildInfo2)) = - (if modulePath' == "" || modulePath' == modulePath2 - then empty else text "main-is:" <+> text modulePath') - $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 - $+$ ppCustomFields (customFieldsBI buildInfo') - -ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc -ppTestSuites suites = - emptyLine $ vcat [ text ("test-suite " ++ n) - $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite) - | (n,condTree) <- suites] - where - ppTestSuite testsuite Nothing = - text "type:" <+> disp (testType testsuite) - $+$ maybe empty (\f -> text "main-is:" <+> text f) - (testSuiteMainIs testsuite) - $+$ maybe empty (\m -> text "test-module:" <+> disp m) - (testSuiteModule testsuite) - $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite) - $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite)) - - ppTestSuite (TestSuite _ _ buildInfo' _) - (Just (TestSuite _ _ buildInfo2 _)) = - ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 - $+$ ppCustomFields (customFieldsBI buildInfo') - - testSuiteMainIs test = case testInterface test of - TestSuiteExeV10 _ f -> Just f - _ -> Nothing - - testSuiteModule test = case testInterface test of - TestSuiteLibV09 _ m -> Just m - _ -> Nothing - -ppCondition :: Condition ConfVar -> Doc -ppCondition (Var x) = ppConfVar x -ppCondition (Lit b) = text (show b) -ppCondition (CNot c) = char '!' <> (ppCondition c) -ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||" - <+> ppCondition c2]) -ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&" - <+> ppCondition c2]) -ppConfVar :: ConfVar -> Doc -ppConfVar (OS os) = text "os" <> parens (disp os) -ppConfVar (Arch arch) = text "arch" <> parens (disp arch) -ppConfVar (Flag name) = text "flag" <> parens (ppFlagName name) -ppConfVar (Impl c v) = text "impl" <> parens (disp c <+> disp v) - -ppFlagName :: FlagName -> Doc -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) - $+$ 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)) - -ppDeps :: [Dependency] -> Doc -ppDeps [] = empty -ppDeps deps = - text "build-depends:" <+> fsep (punctuate comma (map disp deps)) - -emptyLine :: Doc -> Doc -emptyLine d = text " " $+$ d - - - diff --git a/cabal/cabal/Distribution/ParseUtils.hs b/cabal/cabal/Distribution/ParseUtils.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/ParseUtils.hs +++ /dev/null @@ -1,715 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.ParseUtils --- Copyright : (c) The University of Glasgow 2004 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'. --- --- The @.cabal@ file format is not trivial, especially with the introduction --- of configurations and the section syntax that goes with that. This module --- has a bunch of parsing functions that is used by the @.cabal@ parser and a --- couple others. It has the parsing framework code and also little parsers for --- 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... - --- #hide -module Distribution.ParseUtils ( - LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, - runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning, - Field(..), fName, lineNo, - FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat, - showFields, showSingleNamedField, parseFields, parseFieldsFlat, - parseFilePathQ, parseTokenQ, parseTokenQ', - parseModuleNameQ, parseBuildTool, parsePkgconfigDependency, - parseOptVersion, parsePackageNameQ, parseVersionRangeQ, - parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ, - parseSepList, parseCommaList, parseOptCommaList, - showFilePath, showToken, showTestedWith, showFreeText, parseFreeText, - field, simpleField, listField, spaceListField, commaListField, - optsField, liftField, boolField, parseQuoted, - - UnrecFieldParser, warnUnrec, ignoreUnrec, - ) where - -import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat) -import Distribution.License -import Distribution.Version - ( Version(..), VersionRange, anyVersion ) -import Distribution.Package ( PackageName(..), Dependency(..) ) -import Distribution.ModuleName (ModuleName) -import Distribution.Compat.ReadP as ReadP hiding (get) -import Distribution.ReadE -import Distribution.Text - ( Text(..) ) -import Distribution.Simple.Utils - ( comparing, intercalate, lowercase, normaliseLineEndings ) -import Language.Haskell.Extension - ( Language, Extension ) - -import Text.PrettyPrint.HughesPJ hiding (braces) -import Data.Char (isSpace, toLower, isAlphaNum, isDigit) -import Data.Maybe (fromMaybe) -import Data.Tree as Tree (Tree(..), flatten) -import qualified Data.Map as Map -import Control.Monad (foldM) -import System.FilePath (normalise) -import Data.List (sortBy) - --- ----------------------------------------------------------------------------- - -type LineNo = Int - -data PError = AmbigousParse String LineNo - | NoParse String LineNo - | TabsError LineNo - | FromString String (Maybe LineNo) - deriving Show - -data PWarning = PWarning String - | UTFWarning LineNo String - deriving Show - -showPWarning :: FilePath -> PWarning -> String -showPWarning fpath (PWarning msg) = - normalise fpath ++ ": " ++ msg -showPWarning fpath (UTFWarning line fname) = - normalise fpath ++ ":" ++ show line - ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field." - -data ParseResult a = ParseFailed PError | ParseOk [PWarning] a - deriving Show - -instance Monad ParseResult where - return x = ParseOk [] x - ParseFailed err >>= _ = ParseFailed err - ParseOk ws x >>= f = case f x of - ParseFailed err -> ParseFailed err - ParseOk ws' x' -> ParseOk (ws'++ws) x' - fail s = ParseFailed (FromString s Nothing) - -catchParseError :: ParseResult a -> (PError -> ParseResult a) - -> ParseResult a -p@(ParseOk _ _) `catchParseError` _ = p -ParseFailed e `catchParseError` k = k e - -parseFail :: PError -> ParseResult a -parseFail = ParseFailed - -runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a -runP line fieldname p s = - case [ x | (x,"") <- results ] of - [a] -> ParseOk (utf8Warnings line fieldname s) a - --TODO: what is this double parse thing all about? - -- Can't we just do the all isSpace test the first time? - [] -> case [ x | (x,ys) <- results, all isSpace ys ] of - [a] -> ParseOk (utf8Warnings line fieldname s) a - [] -> ParseFailed (NoParse fieldname line) - _ -> ParseFailed (AmbigousParse fieldname line) - _ -> ParseFailed (AmbigousParse fieldname line) - where results = readP_to_S p s - -runE :: LineNo -> String -> ReadE a -> String -> ParseResult a -runE line fieldname p s = - case runReadE p s of - Right a -> ParseOk (utf8Warnings line fieldname s) a - Left e -> syntaxError line $ - "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s - -utf8Warnings :: LineNo -> String -> String -> [PWarning] -utf8Warnings line fieldname s = - take 1 [ UTFWarning n fieldname - | (n,l) <- zip [line..] (lines s) - , '\xfffd' `elem` l ] - -locatedErrorMsg :: PError -> (Maybe LineNo, String) -locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'.") -locatedErrorMsg (NoParse f n) = (Just n, "Parse of field '"++f++"' failed.") -locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.") -locatedErrorMsg (FromString s n) = (n, s) - -syntaxError :: LineNo -> String -> ParseResult a -syntaxError n s = ParseFailed $ FromString s (Just n) - -tabsError :: LineNo -> ParseResult a -tabsError ln = ParseFailed $ TabsError ln - -warning :: String -> ParseResult () -warning s = ParseOk [PWarning s] () - --- | Field descriptor. The parameter @a@ parameterizes over where the field's --- value is stored in. -data FieldDescr a - = FieldDescr - { fieldName :: String - , fieldGet :: a -> Doc - , fieldSet :: LineNo -> String -> a -> ParseResult a - -- ^ @fieldSet n str x@ Parses the field value from the given input - -- string @str@ and stores the result in @x@ if the parse was - -- successful. Otherwise, reports an error on line number @n@. - } - -field :: String -> (a -> Doc) -> (ReadP a a) -> FieldDescr a -field name showF readF = - FieldDescr name showF (\line val _st -> runP line name readF val) - --- Lift a field descriptor storing into an 'a' to a field descriptor storing --- into a 'b'. -liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b -liftField get set (FieldDescr name showF parseF) - = FieldDescr name (\b -> showF (get b)) - (\line str b -> do - a <- parseF line str (get b) - return (set a b)) - --- Parser combinator for simple fields. Takes a field name, a pretty printer, --- a parser function, an accessor, and a setter, returns a FieldDescr over the --- compoid structure. -simpleField :: String -> (a -> Doc) -> (ReadP a a) - -> (b -> a) -> (a -> b -> b) -> FieldDescr b -simpleField name showF readF get set - = liftField get set $ field name showF readF - -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 - -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) - where - set' xs b = set (get b ++ xs) b - -listField :: String -> (a -> Doc) -> (ReadP [a] a) - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -listField name showF readF get set = - liftField get set' $ - field name (fsep . map showF) (parseOptCommaList readF) - where - set' xs b = set (get b ++ xs) b - -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)) - where - update _ opts l | all null opts = l --empty opts as if no opts - update f opts [] = [(f,opts)] - update f opts ((f',opts'):rest) - | f == f' = (f, opts' ++ opts) : rest - | otherwise = (f',opts') : update f opts rest - reorder = sortBy (comparing fst) - --- 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 --- because it does not support warnings. We need a new parser framwork! -boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b -boolField name get set = liftField get set (FieldDescr name showF readF) - where - showF = text . show - readF line str _ - | str == "True" = ParseOk [] True - | str == "False" = ParseOk [] False - | lstr == "true" = ParseOk [caseWarning] True - | lstr == "false" = ParseOk [caseWarning] False - | otherwise = ParseFailed (NoParse name line) - where - lstr = lowercase str - caseWarning = PWarning $ - "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] - -ppField :: String -> Doc -> Doc -ppField name fielddoc = text name <> colon <+> fielddoc - -showFields :: [FieldDescr a] -> a -> String -showFields fields = render . ($+$ text "") . ppFields fields - -showSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String) -showSingleNamedField fields f = - case [ get | (FieldDescr f' get _) <- fields, f' == f ] of - [] -> Nothing - (get:_) -> Just (render . ppField f . get) - -parseFields :: [FieldDescr a] -> a -> String -> ParseResult a -parseFields fields initial = \str -> - readFields str >>= accumFields fields initial - -parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a -parseFieldsFlat fields initial = \str -> - readFieldsFlat str >>= accumFields fields initial - -accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a -accumFields fields = foldM setField - where - fieldMap = Map.fromList - [ (name, f) | f@(FieldDescr name _ _) <- fields ] - setField accum (F line name value) = case Map.lookup name fieldMap of - Just (FieldDescr _ _ set) -> set line value accum - Nothing -> do - warning ("Unrecognized field " ++ name ++ " on line " ++ show line) - return accum - setField accum f = do - warning ("Unrecognized stanza on line " ++ show (lineNo f)) - return accum - --- | The type of a function which, given a name-value pair of an --- unrecognized field, and the current structure being built, --- decides whether to incorporate the unrecognized field --- (by returning Just x, where x is a possibly modified version --- of the structure being built), or not (by returning Nothing). -type UnrecFieldParser a = (String,String) -> a -> Maybe a - --- | A default unrecognized field parser which simply returns Nothing, --- i.e. ignores all unrecognized fields, so warnings will be generated. -warnUnrec :: UnrecFieldParser a -warnUnrec _ _ = Nothing - --- | A default unrecognized field parser which silently (i.e. no --- warnings will be generated) ignores unrecognized fields, by --- returning the structure being built unmodified. -ignoreUnrec :: UnrecFieldParser a -ignoreUnrec _ x = Just x - ------------------------------------------------------------------------------- - --- The data type for our three syntactic categories -data Field - = F LineNo String String - -- ^ A regular @: @ field - | Section LineNo String String [Field] - -- ^ A section with a name and possible parameter. The syntactic - -- structure is: - -- - -- @ - -- { - -- * - -- } - -- @ - | IfBlock LineNo String [Field] [Field] - -- ^ A conditional block with an optional else branch: - -- - -- @ - -- if { - -- * - -- } else { - -- * - -- } - -- @ - deriving (Show - ,Eq) -- for testing - -lineNo :: Field -> LineNo -lineNo (F n _ _) = n -lineNo (Section n _ _ _) = n -lineNo (IfBlock n _ _ _) = n - -fName :: Field -> String -fName (F _ n _) = n -fName (Section _ n _ _) = n -fName _ = error "fname: not a field or section" - -readFields :: String -> ParseResult [Field] -readFields input = ifelse - =<< mapM (mkField 0) - =<< mkTree tokens - - where ls = (lines . normaliseLineEndings) input - tokens = (concatMap tokeniseLine . trimLines) ls - -readFieldsFlat :: String -> ParseResult [Field] -readFieldsFlat input = mapM (mkField 0) - =<< mkTree tokens - where ls = (lines . normaliseLineEndings) input - tokens = (concatMap tokeniseLineFlat . trimLines) ls - --- attach line number and determine indentation -trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)] -trimLines ls = [ (lineno, indent, hastabs, (trimTrailing l')) - | (lineno, l) <- zip [1..] ls - , let (sps, l') = span isSpace l - indent = length sps - hastabs = '\t' `elem` sps - , validLine l' ] - where validLine ('-':'-':_) = False -- Comment - validLine [] = False -- blank line - validLine _ = True - --- | We parse generically based on indent level and braces '{' '}'. To do that --- we split into lines and then '{' '}' tokens and other spans within a line. -data Token = - -- | The 'Line' token is for bits that /start/ a line, eg: - -- - -- > "\n blah blah { blah" - -- - -- tokenises to: - -- - -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"] - -- - -- so lines are the only ones that can have nested layout, since they - -- have a known indentation level. - -- - -- eg: we can't have this: - -- - -- > if ... { - -- > } else - -- > other - -- - -- because other cannot nest under else, since else doesn't start a line - -- so cannot have nested layout. It'd have to be: - -- - -- > if ... { - -- > } - -- > else - -- > other - -- - -- but that's not so common, people would normally use layout or - -- brackets not both in a single @if else@ construct. - -- - -- > if ... { foo : bar } - -- > else - -- > other - -- - -- this is ok - Line LineNo Indent HasTabs String - | Span LineNo String -- ^ span in a line, following brackets - | OpenBracket LineNo | CloseBracket LineNo - -type Indent = Int -type HasTabs = Bool - --- | Tokenise a single line, splitting on '{' '}' and the spans inbetween. --- 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 - (Span _ l':ss) -> Line n0 i t l' :ss - cs -> cs - where split _ "" = [] - split n s = case span (\c -> c /='}' && c /= '{') s of - ("", '{' : s') -> OpenBracket n : split n s' - (w , '{' : s') -> mkspan n w (OpenBracket n : split n s') - ("", '}' : s') -> CloseBracket n : split n s' - (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') - (w , _) -> mkspan n w [] - - mkspan n s ss | null s' = ss - | otherwise = Span n s' : ss - where s' = trimTrailing (trimLeading s) - -tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token] -tokeniseLineFlat (n0, i, t, l) - | null l' = [] - | otherwise = [Line n0 i t l'] - where - l' = trimTrailing (trimLeading l) - -trimLeading, trimTrailing :: String -> String -trimLeading = dropWhile isSpace -trimTrailing = reverse . dropWhile isSpace . reverse - - -type SyntaxTree = Tree (LineNo, HasTabs, String) - --- | Parse the stream of tokens into a tree of them, based on indent \/ layout -mkTree :: [Token] -> ParseResult [SyntaxTree] -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 }" - -- the following two should never happen: - Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l - Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l - - --- | Parse the stream of tokens into a tree of them, based on indent --- This parse state expect to be in a layout context, though possibly --- nested within a braces context so we may still encounter closing braces. -layout :: Indent -- ^ indent level of the parent\/previous line - -> [SyntaxTree] -- ^ accumulating param, trees in this level - -> [Token] -- ^ remaining tokens - -> ParseResult ([SyntaxTree], [Token]) - -- ^ collected trees on this level and trailing tokens -layout _ a [] = return (reverse a, []) -layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss) -layout i a (Line n _ t l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - layout i (Node (n,t,l) sub:a) ss' - -layout i a (Span n l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - layout i (Node (n,False,l) sub:a) ss' - --- look ahead to see if following lines are more indented, giving a sub-tree -layout i a (Line n i' t l:ss) = do - lookahead <- layout (i'+1) [] ss - case lookahead of - ([], _) -> layout i (Node (n,t,l) [] :a) ss - (ts, ss') -> layout i (Node (n,t,l) ts :a) ss' - -layout _ _ ( OpenBracket n :_) = syntaxError n $ "unexpected '{'" -layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss) -layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: " - ++ show l - --- | Parse the stream of tokens into a tree of them, based on explicit braces --- This parse state expects to find a closing bracket. -braces :: LineNo -- ^ line of the '{', used for error messages - -> [SyntaxTree] -- ^ accumulating param, trees in this level - -> [Token] -- ^ remaining tokens - -> ParseResult ([SyntaxTree],[Token]) - -- ^ collected trees on this level and trailing tokens -braces m a (Line n _ t l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - braces m (Node (n,t,l) sub:a) ss' - -braces m a (Span n l:OpenBracket n':ss) = do - (sub, ss') <- braces n' [] ss - braces m (Node (n,False,l) sub:a) ss' - -braces m a (Line n i t l:ss) = do - lookahead <- layout (i+1) [] ss - case lookahead of - ([], _) -> braces m (Node (n,t,l) [] :a) ss - (ts, ss') -> braces m (Node (n,t,l) ts :a) ss' - -braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss -braces _ a (CloseBracket _:ss) = return (reverse a, ss) -braces n _ [] = syntaxError n $ "opening brace '{'" - ++ "has no matching closing brace '}'" -braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'" - --- | Convert the parse tree into the Field AST --- Also check for dodgy uses of tabs in indentation. -mkField :: Int -> SyntaxTree -> ParseResult Field -mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n -mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of - ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l - (name, rest) -> case trimLeading rest of - (':':rest') -> do let followingLines = concatMap Tree.flatten ts - tabs = not (null [()| (_,True,_) <- followingLines ]) - if tabs && d >= 1 - then tabsError n - else return $ F n (map toLower name) - (fieldValue rest' followingLines) - rest' -> do ts' <- mapM (mkField (d+1)) ts - return (Section n (map toLower name) rest' ts') - where fieldValue firstLine followingLines = - let firstLine' = trimLeading firstLine - followingLines' = map (\(_,_,s) -> stripDot s) followingLines - allLines | null firstLine' = followingLines' - | otherwise = firstLine' : followingLines' - in intercalate "\n" allLines - stripDot "." = "" - stripDot s = s - --- | Convert if/then/else 'Section's to 'IfBlock's -ifelse :: [Field] -> ParseResult [Field] -ifelse [] = return [] -ifelse (Section n "if" cond thenpart - :Section _ "else" as elsepart:fs) - | null cond = syntaxError n "'if' with missing condition" - | null thenpart = syntaxError n "'then' branch of 'if' is empty" - | not (null as) = syntaxError n "'else' takes no arguments" - | null elsepart = syntaxError n "'else' branch of 'if' is empty" - | otherwise = do tp <- ifelse thenpart - ep <- ifelse elsepart - fs' <- ifelse fs - return (IfBlock n cond tp ep:fs') -ifelse (Section n "if" cond thenpart:fs) - | null cond = syntaxError n "'if' with missing condition" - | null thenpart = syntaxError n "'then' branch of 'if' is empty" - | otherwise = do tp <- ifelse thenpart - fs' <- ifelse fs - return (IfBlock n cond tp []:fs') -ifelse (Section n "else" _ _:_) = syntaxError n "stray 'else' with no preceding 'if'" -ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs' - fs''' <- ifelse fs - return (Section n s a fs'' : fs''') -ifelse (f:fs) = do fs' <- ifelse fs - return (f : fs') - ------------------------------------------------------------------------------- - --- |parse a module name -parseModuleNameQ :: ReadP r ModuleName -parseModuleNameQ = parseQuoted parse <++ parse - -parseFilePathQ :: ReadP r FilePath -parseFilePathQ = parseTokenQ - -- removed until normalise is no longer broken, was: - -- liftM normalise parseTokenQ - -parseBuildTool :: ReadP r Dependency -parseBuildTool = do name <- parseBuildToolNameQ - skipSpaces - ver <- parseVersionRangeQ <++ return anyVersion - skipSpaces - return $ Dependency name ver - -parseBuildToolNameQ :: ReadP r PackageName -parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName - --- like parsePackageName but accepts symbols in components -parseBuildToolName :: ReadP r PackageName -parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-') - return (PackageName (intercalate "-" ns)) - where component = do - cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_') - if all isDigit cs then pfail else return cs - --- pkg-config allows versions and other letters in package names, --- eg "gtk+-2.0" is a valid pkg-config package _name_. --- It then has a package version number like 2.10.13 -parsePkgconfigDependency :: ReadP r Dependency -parsePkgconfigDependency = do name <- munch1 (\c -> isAlphaNum c || c `elem` "+-._") - skipSpaces - ver <- parseVersionRangeQ <++ return anyVersion - skipSpaces - return $ Dependency (PackageName name) ver - -parsePackageNameQ :: ReadP r PackageName -parsePackageNameQ = parseQuoted parse <++ parse - -parseVersionRangeQ :: ReadP r VersionRange -parseVersionRangeQ = parseQuoted parse <++ parse - -parseOptVersion :: ReadP r Version -parseOptVersion = parseQuoted ver <++ ver - where ver :: ReadP r Version - ver = parse <++ return noVersion - noVersion = Version{ versionBranch=[], versionTags=[] } - -parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) -parseTestedWithQ = parseQuoted tw <++ tw - where - tw :: ReadP r (CompilerFlavor,VersionRange) - tw = do compiler <- parseCompilerFlavorCompat - skipSpaces - version <- parse <++ return anyVersion - skipSpaces - return (compiler,version) - -parseLicenseQ :: ReadP r License -parseLicenseQ = parseQuoted parse <++ parse - --- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a --- because the "compat" version of ReadP isn't quite powerful enough. In --- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a --- Hence the trick above to make 'lic' polymorphic. - -parseLanguageQ :: ReadP r Language -parseLanguageQ = parseQuoted parse <++ parse - -parseExtensionQ :: ReadP r Extension -parseExtensionQ = parseQuoted parse <++ parse - -parseHaskellString :: ReadP r String -parseHaskellString = readS_to_P reads - -parseTokenQ :: ReadP r String -parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') - -parseTokenQ' :: ReadP r String -parseTokenQ' = parseHaskellString <++ munch1 (\x -> not (isSpace x)) - -parseSepList :: ReadP r b - -> ReadP r a -- ^The parser for the stuff between commas - -> ReadP r [a] -parseSepList sepr p = sepBy p separator - where separator = skipSpaces >> sepr >> skipSpaces - -parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas - -> ReadP r [a] -parseSpaceList p = sepBy p skipSpaces - -parseCommaList :: ReadP r a -- ^The parser for the stuff between commas - -> ReadP r [a] -parseCommaList = parseSepList (ReadP.char ',') - -parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas - -> ReadP r [a] -parseOptCommaList = parseSepList (optional (ReadP.char ',')) - -parseQuoted :: ReadP r a -> ReadP r a -parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p - -parseFreeText :: ReadP.ReadP s String -parseFreeText = ReadP.munch (const True) - --- -------------------------------------------- --- ** Pretty printing - -showFilePath :: FilePath -> Doc -showFilePath = showToken - -showToken :: String -> Doc -showToken str - | not (any dodgy str) && - not (null str) = text str - | otherwise = text (show str) - where dodgy c = isSpace c || c == ',' - -showTestedWith :: (CompilerFlavor,VersionRange) -> Doc -showTestedWith (compiler, version) = text (show compiler) <+> disp version - --- | Pretty-print free-format text, ensuring that it is vertically aligned, --- and with blank lines replaced by dots for correct re-parsing. -showFreeText :: String -> Doc -showFreeText "" = empty -showFreeText ('\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 --- characters. The resulting strings do not contain newlines. -lines_ :: String -> [String] -lines_ [] = [""] -lines_ s = let (l, s') = break (== '\n') s - in l : case s' of - [] -> [] - (_:s'') -> lines_ s'' diff --git a/cabal/cabal/Distribution/ReadE.hs b/cabal/cabal/Distribution/ReadE.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/ReadE.hs +++ /dev/null @@ -1,81 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.ReadE --- Copyright : Jose Iborra 2008 --- --- 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 - ReadE(..), succeedReadE, failReadE, - -- * Projections - parseReadE, readEOrFail, - readP_to_E - ) where - -import Distribution.Compat.ReadP -import Data.Char ( isSpace ) - --- | Parser with simple error reporting -newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a} -type ErrorMsg = String - -instance Functor ReadE where - fmap f (ReadE p) = ReadE $ \txt -> case p txt of - Right a -> Right (f a) - Left err -> Left err - -succeedReadE :: (String -> a) -> ReadE a -succeedReadE f = ReadE (Right . f) - -failReadE :: ErrorMsg -> ReadE a -failReadE = ReadE . const Left - -parseReadE :: ReadE a -> ReadP r a -parseReadE (ReadE p) = do - txt <- look - either fail return (p txt) - -readEOrFail :: ReadE a -> (String -> a) -readEOrFail r = either error id . runReadE r - -readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a -readP_to_E err r = - ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt - , all isSpace s ] - of [] -> Left (err txt) - (p:_) -> Right p diff --git a/cabal/cabal/Distribution/Simple.hs b/cabal/cabal/Distribution/Simple.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple.hs +++ /dev/null @@ -1,677 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is the command line front end to the Simple build system. When given --- the parsed command-line args and package information, is able to perform --- basic commands like configure, build, install, register, etc. --- --- This module exports the main functions that Setup.hs scripts use. It --- re-exports the 'UserHooks' type, the standard entry points like --- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of --- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own --- behaviour. --- --- This module isn't called \"Simple\" because it's simple. Far from --- it. It's called \"Simple\" because it does complicated things to --- simple software. --- --- The original idea was that there could be different build systems that all --- 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: - Warning: In the use of `runTests' - (imported from Distribution.Simple.UserHooks): - Deprecated: "Please use the new testing interface instead!" --} -{-# OPTIONS_GHC -fno-warn-deprecations #-} - -module Distribution.Simple ( - module Distribution.Package, - module Distribution.Version, - module Distribution.License, - module Distribution.Simple.Compiler, - module Language.Haskell.Extension, - -- * Simple interface - defaultMain, defaultMainNoRead, defaultMainArgs, - -- * Customization - UserHooks(..), Args, - defaultMainWithHooks, defaultMainWithHooksArgs, - -- ** Standard sets of hooks - simpleUserHooks, - autoconfUserHooks, - defaultUserHooks, emptyUserHooks, - -- ** Utils - defaultHookedPackageDesc - ) where - --- 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.PackageDescription - ( PackageDescription(..), GenericPackageDescription, Executable(..) - , updatePackageDescription, hasLibs - , HookedBuildInfo, emptyHookedBuildInfo ) -import Distribution.PackageDescription.Parse - ( readPackageDescription, readHookedBuildInfo ) -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) -import Distribution.Simple.Program - ( defaultProgramConfiguration, addKnownPrograms, builtinPrograms - , restoreProgramConfiguration, reconfigurePrograms ) -import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler) -import Distribution.Simple.Setup -import Distribution.Simple.Command - -import Distribution.Simple.Build ( build ) -import Distribution.Simple.SrcDist ( sdist ) -import Distribution.Simple.Register - ( register, unregister ) - -import Distribution.Simple.Configure - ( getPersistBuildConfig, maybeGetPersistBuildConfig - , writePersistBuildConfig, checkPersistBuildConfigOutdated - , configure, checkForeignDeps ) - -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) -import Distribution.Simple.BuildPaths ( srcPref) -import Distribution.Simple.Test (test) -import Distribution.Simple.Install (install) -import Distribution.Simple.Haddock (haddock, hscolour) -import Distribution.Simple.Utils - (die, notice, info, warn, setupMessage, chattyTry, - defaultPackageDesc, defaultHookedPackageDesc, - rawSystemExitWithEnv, cabalVersion, topHandler ) -import Distribution.System - ( OS(..), buildOS ) -import Distribution.Verbosity -import Language.Haskell.Extension -import Distribution.Version -import Distribution.License -import Distribution.Text - ( display ) - --- Base -import System.Environment(getArgs, getProgName, getEnvironment) -import System.Directory(removeFile, doesFileExist, - doesDirectoryExist, removeDirectoryRecursive) -import System.Exit -import System.IO.Error (isDoesNotExistError) -import Distribution.Compat.Exception (catchIO, throwIOIO) - -import Control.Monad (when) -import Data.List (intersperse, unionBy, nub, (\\)) - --- | A simple implementation of @main@ for a Cabal setup script. --- It reads the package description file using IO, and performs the --- action specified on the command line. -defaultMain :: IO () -defaultMain = getArgs >>= defaultMainHelper simpleUserHooks - --- | A version of 'defaultMain' that is passed the command line --- arguments, rather than getting them from the environment. -defaultMainArgs :: [String] -> IO () -defaultMainArgs = defaultMainHelper simpleUserHooks - --- | A customizable version of 'defaultMain'. -defaultMainWithHooks :: UserHooks -> IO () -defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks - --- | A customizable version of 'defaultMain' that also takes the command --- line arguments. -defaultMainWithHooksArgs :: UserHooks -> [String] -> IO () -defaultMainWithHooksArgs = defaultMainHelper - --- | Like 'defaultMain', but accepts the package description as input --- rather than using IO to read it. -defaultMainNoRead :: GenericPackageDescription -> IO () -defaultMainNoRead pkg_descr = - getArgs >>= - defaultMainHelper simpleUserHooks { readDesc = return (Just pkg_descr) } - -defaultMainHelper :: UserHooks -> Args -> IO () -defaultMainHelper hooks args = topHandler $ - case commandsRun globalCommand commands args of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (flags, commandParse) -> - case commandParse of - _ | fromFlag (globalVersion flags) -> printVersion - | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action - - where - printHelp help = getProgName >>= putStr . help - printOptionsList = putStr . unlines - printErrors errs = do - putStr (concat (intersperse "\n" errs)) - exitWith (ExitFailure 1) - printNumericVersion = putStrLn $ display cabalVersion - printVersion = putStrLn $ "Cabal library version " - ++ display cabalVersion - - progs = addKnownPrograms (hookedPrograms hooks) defaultProgramConfiguration - commands = - [configureCommand progs `commandAddAction` \fs as -> - configureAction hooks fs as >> return () - ,buildCommand progs `commandAddAction` buildAction hooks - ,installCommand `commandAddAction` installAction hooks - ,copyCommand `commandAddAction` copyAction hooks - ,haddockCommand `commandAddAction` haddockAction hooks - ,cleanCommand `commandAddAction` cleanAction hooks - ,sdistCommand `commandAddAction` sdistAction hooks - ,hscolourCommand `commandAddAction` hscolourAction hooks - ,registerCommand `commandAddAction` registerAction hooks - ,unregisterCommand `commandAddAction` unregisterAction hooks - ,testCommand `commandAddAction` testAction hooks - ] - --- | Combine the preprocessors in the given hooks with the --- preprocessors built into cabal. -allSuffixHandlers :: UserHooks - -> [PPSuffixHandler] -allSuffixHandlers hooks - = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers - where - overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] - overridesPP = unionBy (\x y -> fst x == fst y) - -configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo -configureAction hooks flags args = do - let distPref = fromFlag $ configDistPref flags - pbi <- preConf hooks args flags - - (mb_pd_file, pkg_descr0) <- confPkgDescr - - -- get_pkg_descr (configVerbosity flags') - --let pkg_descr = updatePackageDescription pbi pkg_descr0 - let epkg_descr = (pkg_descr0, pbi) - - --(warns, ers) <- sanityCheckPackage pkg_descr - --errorOut (configVerbosity flags') warns ers - - localbuildinfo0 <- confHook hooks epkg_descr flags - - -- remember the .cabal filename if we know it - -- 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) - -buildAction :: UserHooks -> BuildFlags -> Args -> IO () -buildAction hooks flags args = do - let distPref = fromFlag $ buildDistPref flags - verbosity = fromFlag $ buildVerbosity flags - - lbi <- getBuildConfig hooks verbosity distPref - progs <- reconfigurePrograms verbosity - (buildProgramPaths flags) - (buildProgramArgs flags) - (withPrograms lbi) - - hookedAction preBuild buildHook postBuild - (return lbi { withPrograms = progs }) - hooks flags args - -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 - -haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () -haddockAction hooks flags args = do - let distPref = fromFlag $ haddockDistPref flags - verbosity = fromFlag $ haddockVerbosity flags - - lbi <- getBuildConfig hooks verbosity distPref - progs <- reconfigurePrograms verbosity - (haddockProgramPaths flags) - (haddockProgramArgs flags) - (withPrograms lbi) - - hookedAction preHaddock haddockHook postHaddock - (return lbi { withPrograms = progs }) - hooks flags args - -cleanAction :: UserHooks -> CleanFlags -> Args -> IO () -cleanAction hooks flags args = do - pbi <- preClean hooks args 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 - -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 - -sdistAction :: UserHooks -> SDistFlags -> Args -> IO () -sdistAction hooks flags args = do - let distPref = fromFlag $ sDistDistPref flags - 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 - - 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 - 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 - (getBuildConfig hooks verbosity distPref) - 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 - -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 - -hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo) - -> (UserHooks -> PackageDescription -> LocalBuildInfo - -> UserHooks -> flags -> IO ()) - -> (UserHooks -> Args -> flags -> PackageDescription - -> LocalBuildInfo -> IO ()) - -> IO LocalBuildInfo - -> UserHooks -> flags -> Args -> IO () -hookedAction pre_hook cmd_hook post_hook get_build_config hooks flags args = do - pbi <- pre_hook hooks args flags - localbuildinfo <- get_build_config - let pkg_descr0 = localPkgDescr localbuildinfo - --pkg_descr0 <- get_pkg_descr (get_verbose flags) - sanityCheckHookedBuildInfo pkg_descr0 pbi - let pkg_descr = updatePackageDescription pbi pkg_descr0 - -- TODO: should we write the modified package descr back to the - -- localbuildinfo? - cmd_hook hooks pkg_descr localbuildinfo hooks flags - post_hook hooks args flags pkg_descr localbuildinfo - -sanityCheckHookedBuildInfo :: PackageDescription -> HookedBuildInfo -> IO () -sanityCheckHookedBuildInfo PackageDescription { library = Nothing } (Just _,_) - = die $ "The buildinfo contains info for a library, " - ++ "but the package does not have a library." - -sanityCheckHookedBuildInfo pkg_descr (_, hookExes) - | not (null nonExistant) - = die $ "The buildinfo contains info for an executable called '" - ++ head nonExistant ++ "' but the package does not have a " - ++ "executable with that name." - where - pkgExeNames = nub (map exeName (executables pkg_descr)) - hookExeNames = nub (map fst hookExes) - nonExistant = hookExeNames \\ pkgExeNames - -sanityCheckHookedBuildInfo _ _ = return () - - -getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo -getBuildConfig hooks verbosity distPref = do - lbi_wo_programs <- getPersistBuildConfig distPref - -- Restore info about unconfigured programs, since it is not serialized - let lbi = lbi_wo_programs { - withPrograms = restoreProgramConfiguration - (builtinPrograms ++ hookedPrograms hooks) - (withPrograms lbi_wo_programs) - } - - case pkgDescrFile lbi of - Nothing -> return lbi - Just pkg_descr_file -> do - outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file - if outdated - then reconfigure pkg_descr_file lbi - else return lbi - - where - reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo - reconfigure pkg_descr_file lbi = do - notice verbosity $ pkg_descr_file ++ " has been changed. " - ++ "Re-configuring with most recently used options. " - ++ "If this fails, please run configure manually.\n" - let cFlags = configFlags lbi - 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: - configPrograms = restoreProgramConfiguration - (builtinPrograms ++ hookedPrograms hooks) - (configPrograms cFlags), - - -- Use the current, not saved verbosity level: - configVerbosity = Flag verbosity - } - configureAction hooks cFlags' (extraConfigArgs lbi) - - --- -------------------------------------------------------------------------- --- Cleaning - -clean :: PackageDescription -> CleanFlags -> IO () -clean pkg_descr flags = do - let distPref = fromFlag $ cleanDistPref flags - notice verbosity "cleaning..." - - maybeConfig <- if fromFlag (cleanSaveConf flags) - then maybeGetPersistBuildConfig distPref - else return Nothing - - -- remove the whole dist/ directory rather than tracking exactly what files - -- we created in there. - chattyTry "removing dist/" $ do - exists <- doesDirectoryExist distPref - when exists (removeDirectoryRecursive distPref) - - -- Any extra files the user wants to remove - mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr) - - -- If the user wanted to save the config, write it back - maybe (return ()) (writePersistBuildConfig distPref) maybeConfig - - where - removeFileOrDirectory :: FilePath -> IO () - removeFileOrDirectory fname = do - isDir <- doesDirectoryExist fname - isFile <- doesFileExist fname - if isDir then removeDirectoryRecursive fname - else if isFile then removeFile fname - else return () - verbosity = fromFlag (cleanVerbosity flags) - --- -------------------------------------------------------------------------- --- Default hooks - --- | Hooks that correspond to a plain instantiation of the --- \"simple\" build system -simpleUserHooks :: UserHooks -simpleUserHooks = - emptyUserHooks { - confHook = configure, - postConf = finalChecks, - buildHook = defaultBuildHook, - copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params - testHook = defaultTestHook, - instHook = defaultInstallHook, - sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h), - cleanHook = \p _ _ f -> clean p f, - hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f, - haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f, - regHook = defaultRegHook, - unregHook = \p l _ f -> unregister p l f - } - where - finalChecks _args flags pkg_descr lbi = - checkForeignDeps pkg_descr lbi (lessVerbose verbosity) - where - verbosity = fromFlag (configVerbosity flags) - --- | Basic autoconf 'UserHooks': --- --- * 'postConf' runs @.\/configure@, if present. --- --- * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst', --- 'preReg' and 'preUnreg' read additional build information from --- /package/@.buildinfo@, if present. --- --- Thus @configure@ can use local system information to generate --- /package/@.buildinfo@ and possibly other files. - -{-# DEPRECATED defaultUserHooks - "Use simpleUserHooks or autoconfUserHooks, unless you need Cabal-1.2\n compatibility in which case you must stick with defaultUserHooks" #-} -defaultUserHooks :: UserHooks -defaultUserHooks = autoconfUserHooks { - confHook = \pkg flags -> do - let verbosity = fromFlag (configVerbosity flags) - warn verbosity $ - "defaultUserHooks in Setup script is deprecated." - confHook autoconfUserHooks pkg flags, - postConf = oldCompatPostConf - } - -- This is the annoying old version that only runs configure if it exists. - -- It's here for compatibility with existing Setup.hs scripts. See: - -- http://hackage.haskell.org/trac/hackage/ticket/165 - where oldCompatPostConf args flags pkg_descr lbi - = do let verbosity = fromFlag (configVerbosity flags) - noExtraFlags args - confExists <- doesFileExist "configure" - when confExists $ - runConfigureScript verbosity - backwardsCompatHack flags lbi - - pbi <- getHookedBuildInfo verbosity - sanityCheckHookedBuildInfo pkg_descr pbi - let pkg_descr' = updatePackageDescription pbi pkg_descr - postConf simpleUserHooks args flags pkg_descr' lbi - - backwardsCompatHack = True - -autoconfUserHooks :: UserHooks -autoconfUserHooks - = simpleUserHooks - { - postConf = defaultPostConf, - preBuild = readHook buildVerbosity, - preClean = readHook cleanVerbosity, - preCopy = readHook copyVerbosity, - preInst = readHook installVerbosity, - preHscolour = readHook hscolourVerbosity, - preHaddock = readHook haddockVerbosity, - preReg = readHook regVerbosity, - preUnreg = readHook regVerbosity - } - where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () - defaultPostConf args flags pkg_descr lbi - = do let verbosity = fromFlag (configVerbosity flags) - noExtraFlags args - confExists <- doesFileExist "configure" - if confExists - then runConfigureScript verbosity - backwardsCompatHack flags lbi - else die "configure script not found." - - pbi <- getHookedBuildInfo verbosity - sanityCheckHookedBuildInfo pkg_descr pbi - let pkg_descr' = updatePackageDescription pbi pkg_descr - postConf simpleUserHooks args flags pkg_descr' lbi - - backwardsCompatHack = False - - readHook :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo - readHook get_verbosity a flags = do - noExtraFlags a - getHookedBuildInfo verbosity - where - verbosity = fromFlag (get_verbosity flags) - -runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo - -> IO () -runConfigureScript verbosity backwardsCompatHack flags lbi = do - - env <- getEnvironment - let programConfig = withPrograms lbi - (ccProg, ccFlags) <- configureCCompiler verbosity programConfig - -- The C compiler's compilation and linker flags (e.g. - -- "C compiler flags" and "Gcc Linker flags" from GHC) have already - -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS - -- to ccFlags - -- We don't try and tell configure which ld to use, as we don't have - -- a way to pass its flags too - let env' = appendToEnvironment ("CFLAGS", unwords ccFlags) - env - args' = args ++ ["--with-gcc=" ++ ccProg] - handleNoWindowsSH $ - rawSystemExitWithEnv verbosity "sh" args' env' - - where - args = "configure" : configureArgs backwardsCompatHack flags - - appendToEnvironment (key, val) [] = [(key, val)] - appendToEnvironment (key, val) (kv@(k, v) : rest) - | key == k = (key, v ++ " " ++ val) : rest - | otherwise = kv : appendToEnvironment (key, val) rest - - handleNoWindowsSH action - | buildOS /= Windows - = action - - | otherwise - = action - `catchIO` \ioe -> if isDoesNotExistError ioe - then die notFoundMsg - else throwIOIO ioe - - notFoundMsg = "The package has a './configure' script. This requires a " - ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin." - -getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo -getHookedBuildInfo verbosity = do - maybe_infoFile <- defaultHookedPackageDesc - case maybe_infoFile of - Nothing -> return emptyHookedBuildInfo - Just infoFile -> do - info verbosity $ "Reading parameters from " ++ infoFile - readHookedBuildInfo verbosity infoFile - -defaultTestHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> TestFlags -> IO () -defaultTestHook pkg_descr localbuildinfo _ flags = - test pkg_descr localbuildinfo flags - -defaultInstallHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> InstallFlags -> IO () -defaultInstallHook pkg_descr localbuildinfo _ flags = do - let copyFlags = defaultCopyFlags { - copyDistPref = installDistPref flags, - copyDest = toFlag NoCopyDest, - copyVerbosity = installVerbosity flags - } - install pkg_descr localbuildinfo copyFlags - let registerFlags = defaultRegisterFlags { - regDistPref = installDistPref flags, - regInPlace = installInPlace flags, - regPackageDB = installPackageDB flags, - regVerbosity = installVerbosity flags - } - when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags - -defaultBuildHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> BuildFlags -> IO () -defaultBuildHook pkg_descr localbuildinfo hooks flags = - build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) - -defaultRegHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> RegisterFlags -> IO () -defaultRegHook pkg_descr localbuildinfo _ flags = - if hasLibs pkg_descr - then register pkg_descr localbuildinfo flags - else setupMessage verbosity - "Package contains no library to register:" (packageId pkg_descr) - where verbosity = fromFlag (regVerbosity flags) diff --git a/cabal/cabal/Distribution/Simple/Build.hs b/cabal/cabal/Distribution/Simple/Build.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Build.hs +++ /dev/null @@ -1,274 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Build --- Copyright : Isaac Jones 2003-2005, --- Ross Paterson 2006, --- Duncan Coutts 2007-2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is the entry point to actually building the modules in a package. It --- doesn't actually do much itself, most of the work is delegated to --- compiler-specific actions. It does do some non-compiler specific bits like --- 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, - - initialBuildSteps, - 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.Build.Macros as Build.Macros -import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule - -import Distribution.Package - ( Package(..), PackageName(..), PackageIdentifier(..) - , thisPackageVersion ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), compilerFlavor, PackageDB(..) ) -import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..) - , TestSuite(..), TestSuiteInterface(..) ) -import qualified Distribution.InstalledPackageInfo as IPI -import qualified Distribution.ModuleName as ModuleName - -import Distribution.Simple.Setup - ( BuildFlags(..), fromFlag ) -import Distribution.Simple.PreProcess - ( preprocessComponent, PPSuffixHandler ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(compiler, buildDir, withPackageDB) - , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI - , inplacePackageId ) -import Distribution.Simple.BuildPaths - ( autogenModulesDir, autogenModuleName, cppHeaderName ) -import Distribution.Simple.Register - ( registerPackage, inplaceInstalledPackageInfo ) -import Distribution.Simple.Test ( stubFilePath, stubName ) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, rewriteFile - , die, info, setupMessage ) - -import Distribution.Verbosity - ( Verbosity ) -import Distribution.Text - ( display ) - -import Data.Maybe - ( maybeToList ) -import Control.Monad - ( unless ) -import System.FilePath - ( (), (<.>) ) -import System.Directory - ( getCurrentDirectory ) - --- ----------------------------------------------------------------------------- --- |Build the libraries and executables in this package. - -build :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build - -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling - -> IO () -build pkg_descr lbi flags suffixes = do - let distPref = fromFlag (buildDistPref flags) - verbosity = fromFlag (buildVerbosity flags) - initialBuildSteps distPref pkg_descr lbi verbosity - setupMessage verbosity "Building" (packageId pkg_descr) - - internalPackageDB <- createInternalPackageDB distPref - - let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes - lbi' = lbi {withPackageDB = withPackageDB lbi ++ [internalPackageDB]} - -- Use the internal package DB for the exes. - withComponentsLBI pkg_descr lbi $ \comp clbi -> do - pre comp - case comp of - CLib lib -> do - info verbosity "Building library..." - buildLib verbosity 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) - } - registerPackage verbosity - installedPkgInfo pkg_descr lbi True -- True meaning inplace - (withPackageDB lbi ++ [internalPackageDB]) - - CExe exe -> do - info verbosity $ "Building executable " ++ exeName exe ++ "..." - buildExe verbosity pkg_descr lbi' exe clbi - - CTest test -> do - case testInterface test of - TestSuiteExeV10 _ f -> do - let exe = Executable - { exeName = testName test - , modulePath = f - , buildInfo = testBuildInfo test - } - info verbosity $ "Building test suite " ++ testName test ++ "..." - buildExe verbosity pkg_descr lbi' exe clbi - TestSuiteLibV09 _ m -> do - pwd <- getCurrentDirectory - let lib = Library - { exposedModules = [ m ] - , libExposed = True - , libBuildInfo = testBuildInfo test - } - pkg = pkg_descr - { package = (package pkg_descr) - { pkgName = PackageName $ testName test - } - , buildDepends = targetBuildDepends $ testBuildInfo test - , executables = [] - , testSuites = [] - , library = Just lib - } - ipi = (inplaceInstalledPackageInfo - pwd distPref pkg lib lbi clbi) - { IPI.installedPackageId = inplacePackageId $ packageId ipi - } - testDir = buildDir lbi' stubName test - stubName test ++ "-tmp" - testLibDep = thisPackageVersion $ package pkg - exe = Executable - { exeName = stubName test - , modulePath = stubFilePath test - , buildInfo = (testBuildInfo test) - { hsSourceDirs = [ testDir ] - , targetBuildDepends = testLibDep - : (targetBuildDepends $ testBuildInfo test) - } - } - -- | The stub executable needs a new 'ComponentLocalBuildInfo' - -- that exposes the relevant test suite library. - exeClbi = clbi - { componentPackageDeps = - (IPI.installedPackageId ipi, packageId ipi) - : (filter (\(_, x) -> let PackageName name = pkgName x in name == "Cabal" || name == "base") - $ componentPackageDeps clbi) - } - info verbosity $ "Building test suite " ++ testName test ++ "..." - buildLib verbosity pkg lbi' lib clbi - registerPackage verbosity ipi pkg lbi' True $ withPackageDB lbi' - buildExe verbosity pkg_descr lbi' exe exeClbi - TestSuiteUnsupported tt -> die $ "No support for building test suite " - ++ "type " ++ display tt - --- | 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 - --- TODO: build separate libs in separate dirs so that we can build --- multiple libs, e.g. for 'LibTest' library-style testsuites -buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity pkg_descr lbi lib clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildLib verbosity 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 - _ -> die "Building is not supported with this compiler." - -buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe verbosity pkg_descr lbi exe clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildExe verbosity 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." - -initialBuildSteps :: FilePath -- ^"dist" prefix - -> PackageDescription -- ^mostly information from the .cabal file - -> LocalBuildInfo -- ^Configuration information - -> Verbosity -- ^The verbosity to use - -> 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 - let name = display (packageId pkg_descr) - die ("Package " ++ name ++ " can't be built on this system.") - - createDirectoryIfMissingVerbose verbosity True (buildDir lbi) - - writeAutogenFiles verbosity pkg_descr lbi - --- | Generate and write out the Paths_.hs and cabal_macros.h files --- -writeAutogenFiles :: Verbosity - -> PackageDescription - -> LocalBuildInfo - -> IO () -writeAutogenFiles verbosity pkg lbi = do - createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi) - - let pathsModulePath = autogenModulesDir lbi - ModuleName.toFilePath (autogenModuleName pkg) <.> "hs" - rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi) - - let cppHeaderPath = autogenModulesDir lbi cppHeaderName - rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi) diff --git a/cabal/cabal/Distribution/Simple/Build/Macros.hs b/cabal/cabal/Distribution/Simple/Build/Macros.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Build/Macros.hs +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Build.Macros --- Copyright : Simon Marlow 2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Generate cabal_macros.h - CPP macros for package version testing --- --- When using CPP you get --- --- > VERSION_ --- > MIN_VERSION_(A,B,C) --- --- for each /package/ in @build-depends@, which is true if the version of --- /package/ in use is @>= A.B.C@, using the normal ordering on version --- numbers. --- -module Distribution.Simple.Build.Macros ( - generate - ) where - -import Distribution.Package - ( PackageIdentifier(PackageIdentifier) ) -import Distribution.Version - ( Version(versionBranch) ) -import Distribution.PackageDescription - ( PackageDescription ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo, externalPackageDeps ) -import Distribution.Text - ( display ) - --- ------------------------------------------------------------ --- * Generate cabal_macros.h --- ------------------------------------------------------------ - -generate :: PackageDescription -> LocalBuildInfo -> String -generate _pkg_descr lbi = concat $ - "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" : - [ concat - ["/* package ",display pkgid," */\n" - ,"#define VERSION_",pkgname," ",show (display version),"\n" - ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n" - ," (major1) < ",major1," || \\\n" - ," (major1) == ",major1," && (major2) < ",major2," || \\\n" - ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" - ,"\n\n" - ] - | (_, pkgid@(PackageIdentifier name version)) <- externalPackageDeps lbi - , let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) - pkgname = map fixchar (display name) - ] - where fixchar '-' = '_' - fixchar c = c - diff --git a/cabal/cabal/Distribution/Simple/Build/PathsModule.hs b/cabal/cabal/Distribution/Simple/Build/PathsModule.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Build/PathsModule.hs +++ /dev/null @@ -1,258 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Build.Macros --- Copyright : Isaac Jones 2003-2005, --- Ross Paterson 2006, --- Duncan Coutts 2007-2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Generating the Paths_pkgname module. --- --- This is a module that Cabal generates for the benefit of packages. It --- enables them to find their version number and find any installed data files --- at runtime. This code should probably be split off into another module. --- -module Distribution.Simple.Build.PathsModule ( - generate, pkgPathEnvVar - ) where - -import Distribution.System - ( OS(Windows), buildOS ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), compilerFlavor, compilerVersion ) -import Distribution.Package - ( packageId, packageName, packageVersion ) -import Distribution.PackageDescription - ( PackageDescription(..), hasLibs ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), InstallDirs(..) - , absoluteInstallDirs, prefixRelativeInstallDirs ) -import Distribution.Simple.Setup ( CopyDest(NoCopyDest) ) -import Distribution.Simple.BuildPaths - ( autogenModuleName ) -import Distribution.Text - ( display ) -import Distribution.Version - ( Version(..), orLaterVersion, withinRange ) - -import System.FilePath - ( pathSeparator ) -import Data.Maybe - ( fromJust, isNothing ) - --- ------------------------------------------------------------ --- * Building Paths_.hs --- ------------------------------------------------------------ - -generate :: PackageDescription -> LocalBuildInfo -> String -generate pkg_descr lbi = - let pragmas - | absolute || isHugs = "" - | supports_language_pragma = - "{-# LANGUAGE ForeignFunctionInterface #-}\n" - | otherwise = - "{-# OPTIONS_GHC -fffi #-}\n"++ - "{-# OPTIONS_JHC -fffi #-}\n" - - foreign_imports - | absolute = "" - | isHugs = "import System.Environment\n" - | otherwise = - "import Foreign\n"++ - "import Foreign.C\n" - - header = - pragmas++ - "module " ++ display paths_modulename ++ " (\n"++ - " version,\n"++ - " getBinDir, getLibDir, getDataDir, getLibexecDir,\n"++ - " getDataFileName\n"++ - " ) where\n"++ - "\n"++ - foreign_imports++ - "import qualified Control.Exception as Exception\n"++ - "import Data.Version (Version(..))\n"++ - "import System.Environment (getEnv)"++ - "\n"++ - "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++ - "catchIO = Exception.catch\n" ++ - "\n"++ - "\nversion :: Version"++ - "\nversion = " ++ show (packageVersion pkg_descr) - - body - | absolute = - "\nbindir, libdir, datadir, libexecdir :: FilePath\n"++ - "\nbindir = " ++ show flat_bindir ++ - "\nlibdir = " ++ show flat_libdir ++ - "\ndatadir = " ++ show flat_datadir ++ - "\nlibexecdir = " ++ show flat_libexecdir ++ - "\n"++ - "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"++ - "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++ - "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++ - "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++ - "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++ - "\n"++ - "getDataFileName :: FilePath -> IO FilePath\n"++ - "getDataFileName name = do\n"++ - " dir <- getDataDir\n"++ - " return (dir ++ "++path_sep++" ++ name)\n" - | otherwise = - "\nprefix, bindirrel :: FilePath" ++ - "\nprefix = " ++ show flat_prefix ++ - "\nbindirrel = " ++ show (fromJust flat_bindirrel) ++ - "\n\n"++ - "getBinDir :: IO FilePath\n"++ - "getBinDir = getPrefixDirRel bindirrel\n\n"++ - "getLibDir :: IO FilePath\n"++ - "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"++ - "getDataDir :: IO FilePath\n"++ - "getDataDir = "++ mkGetEnvOr "datadir" - (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++ - "getLibexecDir :: IO FilePath\n"++ - "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"++ - "getDataFileName :: FilePath -> IO FilePath\n"++ - "getDataFileName name = do\n"++ - " dir <- getDataDir\n"++ - " return (dir `joinFileName` name)\n"++ - "\n"++ - get_prefix_stuff++ - "\n"++ - filename_stuff - in header++body - - where - InstallDirs { - prefix = flat_prefix, - bindir = flat_bindir, - libdir = flat_libdir, - datadir = flat_datadir, - libexecdir = flat_libexecdir - } = absoluteInstallDirs pkg_descr lbi NoCopyDest - InstallDirs { - bindir = flat_bindirrel, - libdir = flat_libdirrel, - datadir = flat_datadirrel, - libexecdir = flat_libexecdirrel, - progdir = flat_progdirrel - } = prefixRelativeInstallDirs (packageId pkg_descr) lbi - - mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel - mkGetDir dir Nothing = "return " ++ show dir - - mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++ - " (\\_ -> "++expr++")" - where var' = pkgPathEnvVar pkg_descr var - - -- In several cases we cannot make relocatable installations - 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 - supportsRelocatableProgs GHC = 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 - - path_sep = show [pathSeparator] - - supports_language_pragma = - compilerFlavor (compiler lbi) == GHC && - (compilerVersion (compiler lbi) - `withinRange` orLaterVersion (Version [6,6,1] [])) - --- | Generates the name of the environment variable controlling the path --- component of interest. -pkgPathEnvVar :: PackageDescription - -> String -- ^ path component; one of \"bindir\", \"libdir\", - -- \"datadir\" or \"libexecdir\" - -> String -- ^ environment variable name -pkgPathEnvVar pkg_descr var = - showPkgName (packageName pkg_descr) ++ "_" ++ var - where - showPkgName = map fixchar . display - fixchar '-' = '_' - fixchar c = c - -get_prefix_win32 :: String -get_prefix_win32 = - "getPrefixDirRel :: FilePath -> IO FilePath\n"++ - "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n"++ - " where\n"++ - " try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n"++ - " ret <- c_GetModuleFileName nullPtr buf size\n"++ - " case ret of\n"++ - " 0 -> return (prefix `joinFileName` dirRel)\n"++ - " _ | ret < size -> do\n"++ - " exePath <- peekCWString buf\n"++ - " let (bindir,_) = splitFileName exePath\n"++ - " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ - " | otherwise -> try_size (size * 2)\n"++ - "\n"++ - "foreign import stdcall unsafe \"windows.h GetModuleFileNameW\"\n"++ - " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" - - -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 = - "minusFileName :: FilePath -> String -> FilePath\n"++ - "minusFileName dir \"\" = dir\n"++ - "minusFileName dir \".\" = dir\n"++ - "minusFileName dir suffix =\n"++ - " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"++ - "\n"++ - "joinFileName :: String -> String -> FilePath\n"++ - "joinFileName \"\" fname = fname\n"++ - "joinFileName \".\" fname = fname\n"++ - "joinFileName dir \"\" = dir\n"++ - "joinFileName dir fname\n"++ - " | isPathSeparator (last dir) = dir++fname\n"++ - " | otherwise = dir++pathSeparator:fname\n"++ - "\n"++ - "splitFileName :: FilePath -> (String, String)\n"++ - "splitFileName p = (reverse (path2++drive), reverse fname)\n"++ - " where\n"++ - " (path,drive) = case p of\n"++ - " (c:':':p') -> (reverse p',[':',c])\n"++ - " _ -> (reverse p ,\"\")\n"++ - " (fname,path1) = break isPathSeparator path\n"++ - " path2 = case path1 of\n"++ - " [] -> \".\"\n"++ - " [_] -> path1 -- don't remove the trailing slash if \n"++ - " -- there is only one character\n"++ - " (c:path') | isPathSeparator c -> path'\n"++ - " _ -> path1\n"++ - "\n"++ - "pathSeparator :: Char\n"++ - (case buildOS of - Windows -> "pathSeparator = '\\\\'\n" - _ -> "pathSeparator = '/'\n") ++ - "\n"++ - "isPathSeparator :: Char -> Bool\n"++ - (case buildOS of - Windows -> "isPathSeparator c = c == '/' || c == '\\\\'\n" - _ -> "isPathSeparator c = c == '/'\n") diff --git a/cabal/cabal/Distribution/Simple/BuildPaths.hs b/cabal/cabal/Distribution/Simple/BuildPaths.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/BuildPaths.hs +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.BuildPaths --- Copyright : Isaac Jones 2003-2004, --- Duncan Coutts 2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- 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, - autogenModulesDir, - - autogenModuleName, - cppHeaderName, - haddockName, - - mkLibName, - mkProfLibName, - mkSharedLibName, - - exeExtension, - objExtension, - dllExtension, - - ) where - - -import System.FilePath ((), (<.>)) - -import Distribution.Package - ( PackageIdentifier, packageName ) -import Distribution.ModuleName (ModuleName) -import qualified Distribution.ModuleName as ModuleName -import Distribution.Compiler - ( CompilerId(..) ) -import Distribution.PackageDescription (PackageDescription) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir)) -import Distribution.Simple.Setup (defaultDistPref) -import Distribution.Text - ( display ) -import Distribution.System (OS(..), buildOS) - --- --------------------------------------------------------------------------- --- Build directories and files - -srcPref :: FilePath -> FilePath -srcPref distPref = distPref "src" - -hscolourPref :: FilePath -> PackageDescription -> FilePath -hscolourPref = haddockPref - -haddockPref :: FilePath -> PackageDescription -> FilePath -haddockPref distPref pkg_descr - = distPref "doc" "html" display (packageName pkg_descr) - --- |The directory in which we put auto-generated modules -autogenModulesDir :: LocalBuildInfo -> String -autogenModulesDir lbi = buildDir lbi "autogen" - -cppHeaderName :: String -cppHeaderName = "cabal_macros.h" - --- |The name of the auto-generated module associated with a package -autogenModuleName :: PackageDescription -> ModuleName -autogenModuleName pkg_descr = - ModuleName.fromString $ - "Paths_" ++ map fixchar (display (packageName pkg_descr)) - where fixchar '-' = '_' - fixchar c = c - -haddockName :: PackageDescription -> FilePath -haddockName pkg_descr = display (packageName pkg_descr) <.> "haddock" - --- --------------------------------------------------------------------------- --- Library file names - -mkLibName :: PackageIdentifier -> String -mkLibName lib = "libHS" ++ display lib <.> "a" - -mkProfLibName :: PackageIdentifier -> String -mkProfLibName lib = "libHS" ++ display lib ++ "_p" <.> "a" - --- Implement proper name mangling for dynamical shared objects --- libHS- --- e.g. libHSbase-2.1-ghc6.6.1.so -mkSharedLibName :: PackageIdentifier -> CompilerId -> String -mkSharedLibName lib (CompilerId compilerFlavor compilerVersion) - = "libHS" ++ display lib ++ "-" ++ comp <.> dllExtension - where comp = display compilerFlavor ++ display compilerVersion - --- ------------------------------------------------------------ --- * Platform file extensions --- ------------------------------------------------------------ - --- ToDo: This should be determined via autoconf (AC_EXEEXT) --- | Extension for executable files --- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) -exeExtension :: String -exeExtension = case buildOS of - 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. -objExtension :: String -objExtension = "o" - --- | Extension for dynamically linked (or shared) libraries --- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows) -dllExtension :: String -dllExtension = case buildOS of - Windows -> "dll" - OSX -> "dylib" - _ -> "so" diff --git a/cabal/cabal/Distribution/Simple/Command.hs b/cabal/cabal/Distribution/Simple/Command.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Command.hs +++ /dev/null @@ -1,545 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Command --- Copyright : Duncan Coutts 2007 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is to do with command line handling. The Cabal command line is --- organised into a number of named sub-commands (much like darcs). The --- 'CommandUI' abstraction represents one of these sub-commands, with a name, --- description, a set of flags. Commands can be associated with actions and --- run. It handles some common stuff automatically, like the @--help@ and --- 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 - CommandUI(..), - commandShowOptions, - CommandParse(..), - commandParseArgs, - - -- ** Constructing commands - ShowOrParseArgs(..), - makeCommand, - - -- ** Associating actions with commands - Command, - commandAddAction, - noExtraFlags, - - -- ** Running commands - commandsRun, - --- * Option Fields - OptionField(..), Name, - --- ** Constructing Option Fields - option, multiOption, - --- ** Liftings & Projections - liftOption, viewAsFieldDescr, - --- * Option Descriptions - OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder, - --- ** OptDescr 'smart' constructors - MkOptDescr, - reqArg, reqArg', optArg, optArg', noArg, - boolOpt, boolOpt', choiceOpt, choiceOptFromEnum - - ) where - -import Control.Monad -import Data.Char (isAlpha, toLower) -import Data.List (sortBy) -import Data.Maybe -import Data.Monoid -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.HughesPJ ( punctuate, cat, comma, text, empty) - -data CommandUI flags = CommandUI { - -- | The name of the command as it would be entered on the command line. - -- For example @\"build\"@. - commandName :: String, - -- | A short, one line description of the command to use in help texts. - commandSynopsis :: String, - -- | The useage line summary for this command - commandUsage :: String -> String, - -- | Additional explanation of the command to use in help texts. - commandDescription :: Maybe (String -> String), - -- | Initial \/ empty flags - commandDefaultFlags :: flags, - -- | All the Option fields for this command - commandOptions :: ShowOrParseArgs -> [OptionField flags] - } - -data ShowOrParseArgs = ShowArgs | ParseArgs - -type Name = String -type Description = String - --- | We usually have a datatype 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. -data OptionField a = OptionField { - optionName :: Name, - optionDescr :: [OptDescr a] } - --- | An OptionField takes one or more OptDescrs, describing the command line interface for the field. -data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a -> [String]) - | OptArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a->a) (a -> [Maybe String]) - | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)] - | BoolOpt Description OptFlags{-True-} OptFlags{-False-} (Bool -> a -> a) (a-> Maybe Bool) - --- | Short command line option strings -type SFlags = [Char] --- | Long command line option strings -type LFlags = [String] -type OptFlags = (SFlags,LFlags) -type ArgPlaceHolder = String - - --- | Create an option taking a single OptDescr. --- No explicit Name is given for the Option, the name is the first LFlag given. -option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a -> OptionField a -option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set] -option _ _ _ _ _ _ = error "Distribution.command.option: An OptionField must have at least one LFlag" - --- | Create an option taking several OptDescrs. --- You will have to give the flags and description individually to the OptDescr constructor. -multiOption :: Name -> get -> set - -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially applied to flags and description. - -> OptionField a -multiOption n get set args = OptionField n [arg get set | arg <- args] - -type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set -> OptDescr a - --- | Create a string-valued command line interface. -reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String]) - -> MkOptDescr (a -> b) (b -> a -> a) a -reqArg ad mkflag showflag sf lf d get set = - ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) (showflag . get) - --- | Create a string-valued command line interface with a default value. -optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String]) - -> MkOptDescr (a -> b) (b -> a -> a) a -optArg ad mkflag def showflag sf lf d get set = - OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) - (\b -> set (get b `mappend` def) b) - (showflag . get) - --- | (String -> a) variant of "reqArg" -reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String]) - -> MkOptDescr (a -> b) (b -> a -> a) a -reqArg' ad mkflag showflag = - reqArg ad (succeedReadE mkflag) showflag - --- | (String -> a) variant of "optArg" -optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) -> (b -> [Maybe String]) - -> MkOptDescr (a -> b) (b -> a -> a) a -optArg' ad mkflag showflag = - 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 flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d - -boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags -> MkOptDescr (a -> b) (b -> a -> a) a -boolOpt g s sfT sfF _sf _lf@(n:_) d get set = - BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get) -boolOpt _ _ _ _ _ _ _ _ _ = error "Distribution.Simple.Setup.boolOpt: unreachable" - -boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags -> MkOptDescr (a -> b) (b -> a -> a) a -boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get) - --- | create a Choice option -choiceOpt :: Eq b => [(b,OptFlags,Description)] -> MkOptDescr (a -> b) (b -> a -> a) a -choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts - where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff] - --- | create a Choice option out of an enumeration type. --- As long flags, the Show output is used. As short flags, the first character --- which does not conflict with a previous one is used. -choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => MkOptDescr (a -> b) (b -> a -> a) a -choiceOptFromEnum _sf _lf d get = choiceOpt [ (x, (sf, [map toLower $ show x]), d') - | (x, sf) <- sflags' - , let d' = d ++ show x] - _sf _lf d get - where sflags' = foldl f [] [firstOne..] - f prev x = let prevflags = concatMap snd prev in - prev ++ take 1 [(x, [toLower sf]) | sf <- show x, isAlpha sf - , toLower sf `notElem` prevflags] - firstOne = minBound `asTypeOf` get undefined - -commandGetOpts :: ShowOrParseArgs -> CommandUI flags -> [GetOpt.OptDescr (flags -> flags)] -commandGetOpts showOrParse command = - concatMap viewAsGetOpt (commandOptions command showOrParse) - -viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)] -viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa - where - optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) = - [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d] - where set' = readEOrFail set - optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) = - [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d] - where set' Nothing = def - 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 _) = - [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) - , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ] - --- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > Choice > Opt) and consider only the first one. -viewAsFieldDescr :: OptionField a -> FieldDescr a -viewAsFieldDescr (OptionField _n []) = error "Distribution.command.viewAsFieldDescr: unexpected" -viewAsFieldDescr (OptionField n dd) = FieldDescr n get set - where optDescr = head $ sortBy cmp dd - ReqArg{} `cmp` ReqArg{} = EQ - ReqArg{} `cmp` _ = GT - BoolOpt{} `cmp` ReqArg{} = LT - BoolOpt{} `cmp` BoolOpt{} = EQ - BoolOpt{} `cmp` _ = GT - ChoiceOpt{} `cmp` ReqArg{} = LT - ChoiceOpt{} `cmp` BoolOpt{} = LT - ChoiceOpt{} `cmp` ChoiceOpt{} = EQ - ChoiceOpt{} `cmp` _ = GT - OptArg{} `cmp` OptArg{} = EQ - OptArg{} `cmp` _ = LT - get t = case optDescr of - ReqArg _ _ _ _ ppr -> - (cat . punctuate comma . map text . ppr) t - OptArg _ _ _ _ _ ppr -> - case ppr t of - [] -> empty - (Nothing : _) -> text "True" - (Just a : _) -> text a - ChoiceOpt alts -> - fromMaybe empty $ listToMaybe - [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t] - BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t - set line val a = - case optDescr of - ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val - -- We parse for a single value instead of a list, - -- as one can't really implement parseList :: ReadE a -> ReadE [a] - -- with the current ReadE definition - ChoiceOpt{} -> case getChoiceByLongFlag optDescr val of - Just f -> return (f a) - _ -> syntaxError line val - BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runP line n parse val - OptArg _ _ _ _readE _ _ -> -- The behaviour in this case is not clear, and it has no use so far, - -- so we avoid future surprises by not implementing it. - error "Command.optionToFieldDescr: feature not implemented" - -getChoiceByLongFlag :: OptDescr b -> String -> Maybe (b->b) -getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe [ set | (_,(_sf,lf:_), set, _) <- alts - , lf == val] - -getChoiceByLongFlag _ _ = error "Distribution.command.getChoiceByLongFlag: expected a choice option" - -getCurrentChoice :: OptDescr a -> a -> [String] -getCurrentChoice (ChoiceOpt alts) a = - [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a] - -getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr" - - -liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b -liftOption get' set' opt = opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt} - - -liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b -liftOptDescr get' set' (ChoiceOpt opts) = - ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get')) - | (d, ff, set, get) <- opts] - -liftOptDescr get' set' (OptArg d ff ad set def get) = - OptArg d ff ad (liftSet get' set' `fmap` set) (liftSet get' set' def) (get . get') - -liftOptDescr get' set' (ReqArg d ff ad set get) = - ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') - -liftOptDescr get' set' (BoolOpt d ffT ffF set get) = - BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') - -liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b -liftSet get' set' set x = set' (set $ get' x) x - --- | Show flags in the standard long option command line format -commandShowOptions :: CommandUI flags -> flags -> [String] -commandShowOptions command v = concat - [ showOptDescr v od | o <- commandOptions command ParseArgs - , od <- optionDescr o] - where - showOptDescr :: a -> OptDescr a -> [String] - showOptDescr x (BoolOpt _ (_,lfT:_) (_,lfF:_) _ enabled) - = case enabled x of - Nothing -> [] - Just True -> ["--" ++ lfT] - Just False -> ["--" ++ lfF] - showOptDescr x c@ChoiceOpt{} - = ["--" ++ val | val <- getCurrentChoice c x] - showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag) - = [ "--"++lf++"="++flag - | flag <- showflag x ] - showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag) - = [ case flag of - Just s -> "--"++lf++"="++s - Nothing -> "--"++lf - | flag <- showflag x ] - showOptDescr _ _ - = error "Distribution.Simple.Command.showOptDescr: unreachable" - - -commandListOptions :: CommandUI flags -> [String] -commandListOptions command = - concatMap listOption $ - addCommonFlags ShowArgs $ -- This is a slight hack, we don't want - -- "--list-options" showing up in the - -- list options output, so use ShowArgs - commandGetOpts ShowArgs command - where - listOption (GetOpt.Option shortNames longNames _ _) = - [ "-" ++ [name] | name <- shortNames ] - ++ [ "--" ++ name | name <- longNames ] - --- | 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 - --- | Make a Command from standard 'GetOpt' options. -makeCommand :: String -- ^ name - -> String -- ^ short description - -> Maybe (String -> String) -- ^ long description - -> 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 - } - where usage pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" - ++ "Flags for " ++ name ++ ":" - --- | Common flags that apply to every command -data CommonFlag = HelpFlag | ListOptionsFlag - -commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag] -commonFlags showOrParseArgs = case showOrParseArgs of - ShowArgs -> [help] - ParseArgs -> [help, list] - where - help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag) - "Show this help text" - helpShortFlags = case showOrParseArgs of - ShowArgs -> ['h'] - ParseArgs -> ['h', '?'] - list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag) - "Print a list of command line flags" - -addCommonFlags :: ShowOrParseArgs - -> [GetOpt.OptDescr a] - -> [GetOpt.OptDescr (Either CommonFlag a)] -addCommonFlags showOrParseArgs options = - map (fmapOptDesc Left) (commonFlags showOrParseArgs) - ++ map (fmapOptDesc Right) options - where fmapOptDesc f (GetOpt.Option s l d m) = - GetOpt.Option s l (fmapArgDesc f d) m - fmapArgDesc f (GetOpt.NoArg a) = GetOpt.NoArg (f a) - fmapArgDesc f (GetOpt.ReqArg s d) = GetOpt.ReqArg (f . s) d - fmapArgDesc f (GetOpt.OptArg s d) = GetOpt.OptArg (f . s) d - --- | Parse a bunch of command line arguments --- -commandParseArgs :: CommandUI flags - -> Bool -- ^ Is the command a global or subcommand? - -> [String] - -> CommandParse (flags -> flags, [String]) -commandParseArgs command global args = - let options = addCommonFlags ParseArgs - $ commandGetOpts ParseArgs command - order | global = GetOpt.RequireOrder - | otherwise = GetOpt.Permute - in case GetOpt.getOpt' order options args of - (flags, _, _, _) - | any listFlag flags -> CommandList (commandListOptions command) - | any helpFlag flags -> CommandHelp (commandHelp command) - where listFlag (Left ListOptionsFlag) = True; listFlag _ = False - helpFlag (Left HelpFlag) = True; helpFlag _ = False - (flags, opts, opts', []) - | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') - | otherwise -> CommandErrors (unrecognised opts') - (_, _, _, errs) -> CommandErrors errs - - 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. - accum flags = foldr (flip (.)) id [ f | Right f <- flags ] - unrecognised opts = [ "unrecognized 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 - -- as sub-command rather than global flags. - mix [] ys = ys - mix (x:xs) ys = x:ys++xs - -data CommandParse flags = CommandHelp (String -> String) - | CommandList [String] - | CommandErrors [String] - | CommandReadyToGo flags -instance Functor CommandParse where - fmap _ (CommandHelp help) = CommandHelp help - fmap _ (CommandList opts) = CommandList opts - fmap _ (CommandErrors errs) = CommandErrors errs - fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags) - - -data Command action = Command String String ([String] -> CommandParse action) - -commandAddAction :: CommandUI flags - -> (flags -> [String] -> action) - -> Command action -commandAddAction command action = - Command (commandName command) - (commandSynopsis command) - (fmap (uncurry applyDefaultArgs) - . commandParseArgs command False) - - where applyDefaultArgs mkflags args = - let flags = mkflags (commandDefaultFlags command) - in action flags args - -commandsRun :: CommandUI a - -> [Command action] - -> [String] - -> CommandParse (a, CommandParse action) -commandsRun globalCommand commands args = - case commandParseArgs globalCommand' True args of - CommandHelp help -> CommandHelp help - CommandList opts -> CommandList (opts ++ commandNames) - CommandErrors errs -> CommandErrors errs - CommandReadyToGo (mkflags, args') -> case args' of - ("help":cmdArgs) -> handleHelpCommand cmdArgs - (name:cmdArgs) -> case lookupCommand name of - [Command _ _ action] -> CommandReadyToGo (flags, action cmdArgs) - _ -> CommandReadyToGo (flags, badCommand name) - [] -> CommandReadyToGo (flags, noCommand) - where flags = mkflags (commandDefaultFlags globalCommand) - - where - lookupCommand cname = [ cmd | cmd@(Command cname' _ _) <- commands' - , cname'==cname ] - noCommand = CommandErrors ["no command given (try --help)\n"] - badCommand cname = CommandErrors ["unrecognised command: " ++ cname - ++ " (try --help)\n"] - commands' = commands ++ [commandAddAction helpCommandUI undefined] - commandNames = [ name | Command name _ _ <- 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 _ <- commands' ] - ++ case commandDescription globalCommand of - Nothing -> "" - Just desc -> '\n': desc pname - } - where maxlen = maximum [ length name | Command name _ _ <- 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" - handleHelpCommand cmdArgs = - case commandParseArgs helpCommandUI True cmdArgs of - CommandHelp help -> CommandHelp help - CommandList list -> CommandList (list ++ commandNames) - CommandErrors _ -> CommandHelp globalHelp - CommandReadyToGo (_,[]) -> CommandHelp globalHelp - CommandReadyToGo (_,(name:cmdArgs')) -> - case lookupCommand name of - [Command _ _ action] -> - case action ("--help":cmdArgs') of - CommandHelp help -> CommandHelp help - CommandList _ -> CommandList [] - _ -> 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:" - } - --- | Utility function, many commands do not accept additional flags. This --- action fails with a helpful error message if the user supplies any extra. --- -noExtraFlags :: [String] -> IO () -noExtraFlags [] = return () -noExtraFlags extraFlags = - 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] diff --git a/cabal/cabal/Distribution/Simple/Compiler.hs b/cabal/cabal/Distribution/Simple/Compiler.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Compiler.hs +++ /dev/null @@ -1,194 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Compiler --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This should be a much more sophisticated abstraction than it is. Currently --- it's just a bit of data about the compiler, like it's flavour and name and --- version. The reason it's just data is because currently it has to be in --- 'Read' and 'Show' so it can be saved along with the 'LocalBuildInfo'. The --- only interesting bit of info it contains is a mapping between language --- extensions and compiler command line flags. This module also defines a --- 'PackageDB' type which is used to refer to package databases. Most compilers --- only know about a single global package collection but GHC has a global and --- 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, - - -- * Support for package databases - PackageDB(..), - PackageDBStack, - registrationPackageDB, - - -- * Support for optimisation levels - OptimisationLevel(..), - flagToOptimisationLevel, - - -- * Support for language extensions - Flag, - languageToFlags, - unsupportedLanguages, - extensionsToFlags, - unsupportedExtensions - ) where - -import Distribution.Compiler -import Distribution.Version (Version(..)) -import Distribution.Text (display) -import Language.Haskell.Extension (Language(Haskell98), Extension) - -import Data.List (nub) -import Data.Maybe (catMaybes, isNothing) - -data Compiler = Compiler { - compilerId :: CompilerId, - compilerLanguages :: [(Language, Flag)], - compilerExtensions :: [(Extension, Flag)] - } - deriving (Show, Read) - -showCompilerId :: Compiler -> String -showCompilerId = display . compilerId - -compilerFlavor :: Compiler -> CompilerFlavor -compilerFlavor = (\(CompilerId f _) -> f) . compilerId - -compilerVersion :: Compiler -> Version -compilerVersion = (\(CompilerId _ v) -> v) . compilerId - --- ------------------------------------------------------------ --- * Package databases --- ------------------------------------------------------------ - --- |Some compilers have a notion of a database of available packages. --- For some there is just one global db of packages, other compilers --- support a per-user or an arbitrary db specified at some location in --- the file system. This can be used to build isloated environments of --- packages, for example to build a collection of related packages --- without installing them globally. --- -data PackageDB = GlobalPackageDB - | UserPackageDB - | SpecificPackageDB FilePath - deriving (Eq, Ord, Show, Read) - --- | 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: --- --- > [GlobalPackageDB] --- > [GlobalPackageDB, UserPackageDB] --- > [GlobalPackageDB, SpecificPackageDB "package.conf.inplace"] --- --- Note that the 'GlobalPackageDB' is invariably at the bottom since it --- contains the rts, base and other special compiler-specific packages. --- --- We are not restricted to using just the above combinations. In particular --- we can use several custom package dbs and the user package db together. --- --- When it comes to writing, the top most (last) package is used. --- -type PackageDBStack = [PackageDB] - --- | Return the package that we should register into. This is the package db at --- the top of the stack. --- -registrationPackageDB :: PackageDBStack -> PackageDB -registrationPackageDB [] = error "internal error: empty package db set" -registrationPackageDB dbs = last dbs - --- ------------------------------------------------------------ --- * Optimisation levels --- ------------------------------------------------------------ - --- | Some compilers support optimising. Some have different levels. --- For compliers 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) - -flagToOptimisationLevel :: Maybe String -> OptimisationLevel -flagToOptimisationLevel Nothing = NormalOptimisation -flagToOptimisationLevel (Just s) = case reads s of - [(i, "")] - | i >= fromEnum (minBound :: OptimisationLevel) - && i <= fromEnum (maxBound :: OptimisationLevel) - -> toEnum i - | otherwise -> error $ "Bad optimisation level: " ++ show i - ++ ". Valid values are 0..2" - _ -> error $ "Can't parse optimisation level " ++ s - --- ------------------------------------------------------------ --- * Languages and Extensions --- ------------------------------------------------------------ - -unsupportedLanguages :: Compiler -> [Language] -> [Language] -unsupportedLanguages comp langs = - [ lang | lang <- langs - , isNothing (languageToFlag comp lang) ] - -languageToFlags :: Compiler -> Maybe Language -> [Flag] -languageToFlags comp = filter (not . null) - . catMaybes . map (languageToFlag comp) - . maybe [Haskell98] (\x->[x]) - -languageToFlag :: Compiler -> Language -> Maybe Flag -languageToFlag comp ext = lookup ext (compilerLanguages comp) - - --- |For the given compiler, return the extensions it does not support. -unsupportedExtensions :: Compiler -> [Extension] -> [Extension] -unsupportedExtensions comp exts = - [ ext | ext <- exts - , isNothing (extensionToFlag comp ext) ] - -type Flag = String - --- |For the given compiler, return the flags for the supported extensions. -extensionsToFlags :: Compiler -> [Extension] -> [Flag] -extensionsToFlags comp = nub . filter (not . null) - . catMaybes . map (extensionToFlag comp) - -extensionToFlag :: Compiler -> Extension -> Maybe Flag -extensionToFlag comp ext = lookup ext (compilerExtensions comp) diff --git a/cabal/cabal/Distribution/Simple/Configure.hs b/cabal/cabal/Distribution/Simple/Configure.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Configure.hs +++ /dev/null @@ -1,1036 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Configure --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This deals with the /configure/ phase. It provides the 'configure' action --- which is given the package description and configure flags. It then tries --- to: configure the compiler; resolves any conditionals in the package --- description; resolve the package dependencies; check if all the extensions --- used by this package are supported by the compiler; check that all the build --- tools are available (including version checks if appropriate); checks for --- any required @pkg-config@ packages (updating the 'BuildInfo' with the --- results) --- --- Then based on all this it saves the info in the 'LocalBuildInfo' and writes --- it out to the @dist\/setup-config@ file. It also displays various details to --- the user, the amount of information displayed depending on the verbosity --- level. - -{- 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, - getPersistBuildConfig, - checkPersistBuildConfigOutdated, - maybeGetPersistBuildConfig, - localBuildInfoFile, - getInstalledPackages, - configCompiler, configCompilerAux, - ccLdOptionsBuildInfo, - tryGetConfigStateFile, - checkForeignDeps, - ) - where - -import Distribution.Simple.Compiler - ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion - , showCompilerId, unsupportedLanguages, unsupportedExtensions - , PackageDB(..), PackageDBStack ) -import Distribution.Package - ( PackageName(PackageName), PackageIdentifier(..), PackageId - , packageName, packageVersion, Package(..) - , Dependency(Dependency), simplifyDependency - , InstalledPackageId(..) ) -import Distribution.InstalledPackageInfo as Installed - ( InstalledPackageInfo, InstalledPackageInfo_(..) - , emptyInstalledPackageInfo ) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) -import Distribution.PackageDescription as PD - ( PackageDescription(..), specVersion, GenericPackageDescription(..) - , Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions - , HookedBuildInfo, updatePackageDescription, allBuildInfo - , FlagName(..), TestSuite(..) ) -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 - , configureAllKnownPrograms, knownPrograms, lookupKnownProgram, addKnownProgram - , userSpecifyArgss, userSpecifyPaths - , requireProgram, requireProgramVersion - , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf ) -import Distribution.Simple.Setup - ( ConfigFlags(..), CopyDest(..), fromFlag, fromFlagOrDefault, flagToMaybe ) -import Distribution.Simple.InstallDirs - ( InstallDirs(..), defaultInstallDirs, combineInstallDirs ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) - , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId - , allComponentsBy, Component(..), foldComponent, ComponentName(..) ) -import Distribution.Simple.BuildPaths - ( autogenModulesDir ) -import Distribution.Simple.Utils - ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose - , intercalate, cabalVersion - , withFileContents, writeFileAtomic - , withTempFile ) -import Distribution.System - ( OS(..), buildOS, 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 Control.Monad - ( when, unless, foldM, filterM, forM ) -import Data.List - ( nub, partition, isPrefixOf, inits, find ) -import Data.Maybe - ( isNothing, catMaybes, mapMaybe ) -import Data.Monoid - ( Monoid(..) ) -import Data.Graph - ( SCC(..), graphFromEdges, transposeG, vertices, stronglyConnCompR ) -import System.Directory - ( doesFileExist, getModificationTime, createDirectoryIfMissing, getTemporaryDirectory ) -import System.Exit - ( ExitCode(..), exitWith ) -import System.FilePath - ( (), isAbsolute ) -import qualified System.Info - ( compilerName, compilerVersion ) -import System.IO - ( hPutStrLn, stderr, hClose ) -import Distribution.Text - ( Text(disp), display, simpleParse ) -import Text.PrettyPrint.HughesPJ - ( comma, punctuate, render, nest, sep ) -import Distribution.Compat.Exception ( catchExit, catchIO ) - -import Prelude hiding (catch) - -tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a) -tryGetConfigStateFile filename = do - exists <- doesFileExist filename - if not exists - then return (Left missing) - else withFileContents filename $ \str -> - case lines str of - [headder, rest] -> case checkHeader headder of - Just msg -> return (Left msg) - Nothing -> case reads rest of - [(bi,_)] -> return (Right bi) - _ -> return (Left cantParse) - _ -> return (Left cantParse) - where - checkHeader :: String -> Maybe String - checkHeader header = case parseHeader header of - Just (cabalId, compId) - | cabalId - == currentCabalId -> Nothing - | otherwise -> Just (badVersion cabalId compId) - Nothing -> Just cantParse - - 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." - --- internal function -tryGetPersistBuildConfig :: FilePath -> IO (Either String LocalBuildInfo) -tryGetPersistBuildConfig distPref - = tryGetConfigStateFile (localBuildInfoFile distPref) - --- |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 return lbi - --- |Try to read the 'localBuildInfoFile'. -maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo) -maybeGetPersistBuildConfig distPref = do - lbi <- tryGetPersistBuildConfig distPref - return $ either (const Nothing) Just lbi - --- |After running configure, output the 'LocalBuildInfo' to the --- 'localBuildInfoFile'. -writePersistBuildConfig :: FilePath -> LocalBuildInfo -> IO () -writePersistBuildConfig distPref lbi = do - createDirectoryIfMissing False distPref - writeFileAtomic (localBuildInfoFile distPref) - (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 - where - -currentCabalId :: PackageIdentifier -currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion - -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 - --- |Check that localBuildInfoFile is up-to-date with respect to the --- .cabal file. -checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool -checkPersistBuildConfigOutdated distPref pkg_descr_file = do - t0 <- getModificationTime pkg_descr_file - t1 <- getModificationTime $ localBuildInfoFile distPref - return (t0 > t1) - --- |@dist\/setup-config@ -localBuildInfoFile :: FilePath -> FilePath -localBuildInfoFile distPref = distPref "setup-config" - --- ----------------------------------------------------------------------------- --- * Configuration --- ----------------------------------------------------------------------------- - --- |Perform the \"@.\/setup configure@\" action. --- Returns the @.setup-config@ file. -configure :: (GenericPackageDescription, HookedBuildInfo) - -> ConfigFlags -> IO LocalBuildInfo -configure (pkg_descr0, pbi) cfg - = do let distPref = fromFlag (configDistPref cfg) - buildDir' = distPref "build" - verbosity = fromFlag (configVerbosity cfg) - - setupMessage verbosity "Configuring" (packageId pkg_descr0) - - createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref - - let programsConfig = userSpecifyArgss (configProgramArgs cfg) - . userSpecifyPaths (configProgramPaths cfg) - $ configPrograms cfg - userInstall = fromFlag (configUserInstall cfg) - packageDbs = implicitPackageDbStack userInstall - (flagToMaybe $ configPackageDB cfg) - - -- detect compiler - (comp, programsConfig') <- configCompiler - (flagToMaybe $ configHcFlavor cfg) - (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg) - programsConfig (lessVerbose verbosity) - let version = compilerVersion comp - flavor = compilerFlavor comp - - -- Create a PackageIndex that makes *any libraries that might be* - -- defined internally to this package look like installed packages, in - -- case an executable should refer to any of them as dependencies. - -- - -- It must be *any libraries that might be* defined rather than the - -- actual definitions, because these depend on conditionals in the .cabal - -- file, and we haven't resolved them yet. finalizePackageDescription - -- does the resolution of conditionals, and it takes internalPackageSet - -- as part of its input. - -- - -- Currently a package can define no more than one library (which has - -- the same name as the package) but we could extend this later. - -- If we later allowed private internal libraries, then here we would - -- need to pre-scan the conditional data to make a list of all private - -- libraries that could possibly be defined by the .cabal file. - let pid = packageId pkg_descr0 - internalPackage = emptyInstalledPackageInfo { - --TODO: should use a per-compiler method to map the source - -- package ID into an installed package id we can use - -- for the internal package set. The open-codes use of - -- InstalledPackageId . display here is a hack. - Installed.installedPackageId = InstalledPackageId $ display $ pid, - Installed.sourcePackageId = pid - } - internalPackageSet = PackageIndex.fromList [internalPackage] - installedPackageSet <- getInstalledPackages (lessVerbose verbosity) comp - packageDbs programsConfig' - - let -- Constraint test function for the solver - dependencySatisfiable = - not . null . PackageIndex.lookupDependency pkgs' - where - pkgs' = PackageIndex.insert internalPackage installedPackageSet - enableTest t = t { testEnabled = fromFlag (configTests cfg) } - flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t)) - (condTestSuites pkg_descr0) - pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests } - - (pkg_descr0', flags) <- - case finalizePackageDescription - (configConfigurationsFlags cfg) - dependencySatisfiable - Distribution.System.buildPlatform - (compilerId comp) - (configConstraints cfg) - pkg_descr0'' - of Right r -> return r - Left missing -> - die $ "At least the following dependencies are missing:\n" - ++ (render . nest 4 . sep . punctuate comma - . map (disp . simplifyDependency) - $ missing) - - -- add extra include/lib dirs as specified in cfg - -- we do it here so that those get checked too - let pkg_descr = - enableCoverage (fromFlag (configLibCoverage cfg)) distPref - $ addExtraIncludeLibDirs pkg_descr0' - - when (not (null flags)) $ - info verbosity $ "Flags chosen: " - ++ intercalate ", " [ name ++ "=" ++ display value - | (FlagName name, value) <- flags ] - - checkPackageProblems verbosity pkg_descr0 - (updatePackageDescription pbi pkg_descr) - - let selectDependencies = - (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ])) - . map (selectDependency internalPackageSet installedPackageSet) - - (failedDeps, allPkgDeps) = selectDependencies (buildDepends pkg_descr) - - internalPkgDeps = [ pkgid | InternalDependency _ pkgid <- allPkgDeps ] - externalPkgDeps = [ pkg | ExternalDependency _ pkg <- allPkgDeps ] - - when (not (null internalPkgDeps) && not (newPackageDepsBehaviour pkg_descr)) $ - die $ "The field 'build-depends: " - ++ intercalate ", " (map (display . packageName) internalPkgDeps) - ++ "' refers to a library which is defined within the same " - ++ "package. To use this feature the package must specify at " - ++ "least 'cabal-version: >= 1.8'." - - reportFailedDependencies failedDeps - reportSelectedDependencies verbosity allPkgDeps - - packageDependsIndex <- - case PackageIndex.dependencyClosure installedPackageSet - (map Installed.installedPackageId externalPkgDeps) of - Left packageDependsIndex -> return packageDependsIndex - Right broken -> - die $ "The following installed packages are broken because other" - ++ " packages they depend on are missing. These broken " - ++ "packages must be rebuilt before they can be used.\n" - ++ unlines [ "package " - ++ display (packageId pkg) - ++ " is broken due to missing package " - ++ intercalate ", " (map display deps) - | (pkg, deps) <- broken ] - - let pseudoTopPkg = emptyInstalledPackageInfo { - Installed.installedPackageId = InstalledPackageId (display (packageId pkg_descr)), - Installed.sourcePackageId = packageId pkg_descr, - Installed.depends = map Installed.installedPackageId externalPkgDeps - } - case PackageIndex.dependencyInconsistencies - . PackageIndex.insert pseudoTopPkg - $ packageDependsIndex of - [] -> return () - inconsistencies -> - warn verbosity $ - "This package indirectly depends on multiple versions of the same " - ++ "package. This is highly likely to cause a compile failure.\n" - ++ unlines [ "package " ++ display pkg ++ " requires " - ++ display (PackageIdentifier name ver) - | (name, uses) <- inconsistencies - , (pkg, ver) <- uses ] - - -- installation directories - defaultDirs <- defaultInstallDirs flavor userInstall (hasLibs pkg_descr) - let installDirs = combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs cfg) - - -- check languages and extensions - let langlist = nub $ catMaybes $ map defaultLanguage (allBuildInfo pkg_descr) - let langs = unsupportedLanguages comp langlist - when (not (null langs)) $ - die $ "The package " ++ display (packageId pkg_descr0) - ++ " requires the following languages which are not " - ++ "supported by " ++ display (compilerId comp) ++ ": " - ++ intercalate ", " (map display langs) - let extlist = nub $ concatMap allExtensions (allBuildInfo pkg_descr) - let exts = unsupportedExtensions comp extlist - when (not (null exts)) $ - die $ "The package " ++ display (packageId pkg_descr0) - ++ " requires the following language extensions which are not " - ++ "supported by " ++ display (compilerId comp) ++ ": " - ++ intercalate ", " (map display exts) - - -- configured known/required programs & build tools - let requiredBuildTools = concatMap buildTools (allBuildInfo pkg_descr) - - -- add all exes built by this package ("internal exes") to the program - -- conf; this makes the namespace of build-tools include intrapackage - -- references to executables - let programsConfig'' = foldr (addInternalExe buildDir') programsConfig' - (executables pkg_descr) - - programsConfig''' <- - configureAllKnownPrograms (lessVerbose verbosity) programsConfig'' - >>= configureRequiredPrograms verbosity requiredBuildTools - - (pkg_descr', programsConfig'''') <- - configurePkgconfigPackages verbosity pkg_descr programsConfig''' - - split_objs <- - if not (fromFlag $ configSplitObjs cfg) - then return False - else case flavor of - GHC | version >= Version [6,5] [] -> return True - _ -> do warn verbosity - ("this compiler does not support " ++ - "--enable-split-objs; ignoring") - return False - - -- The allPkgDeps contains all the package deps for the whole package - -- but we need to select the subset for this specific component. - -- we just take the subset for the package names this component - -- needs. Note, this only works because we cannot yet depend on two - -- versions of the same package. - let configLib lib = configComponent (libBuildInfo lib) - configExe exe = (exeName exe, configComponent (buildInfo exe)) - configTest test = (testName test, - configComponent(testBuildInfo test)) - configComponent bi = ComponentLocalBuildInfo { - componentPackageDeps = - if newPackageDepsBehaviour pkg_descr' - then [ (installedPackageId pkg, packageId pkg) - | pkg <- selectSubset bi externalPkgDeps ] - ++ [ (inplacePackageId pkgid, pkgid) - | pkgid <- selectSubset bi internalPkgDeps ] - else [ (installedPackageId pkg, packageId pkg) - | pkg <- externalPkgDeps ] - } - selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg] - selectSubset bi pkgs = - [ pkg | pkg <- pkgs, packageName pkg `elem` names ] - where - names = [ name | Dependency name _ <- targetBuildDepends bi ] - - -- Obtains the intrapackage dependencies for the given component - let ipDeps component = - mapMaybe exeDepToComp (buildTools bi) - ++ mapMaybe libDepToComp (targetBuildDepends bi) - where - bi = foldComponent libBuildInfo buildInfo testBuildInfo component - exeDepToComp (Dependency (PackageName name) _) = - CExe `fmap` find ((==) name . exeName) - (executables pkg_descr') - libDepToComp (Dependency pn _) - | pn `elem` map packageName internalPkgDeps = - CLib `fmap` library pkg_descr' - libDepToComp _ = Nothing - - let sccs = (stronglyConnCompR . map lkup . vertices . transposeG) g - where (g, lkup, _) = graphFromEdges - $ allComponentsBy pkg_descr' - $ \c -> (c, key c, map key (ipDeps c)) - key = foldComponent (const "library") exeName testName - - -- check for cycles in the dependency graph - buildOrder <- forM sccs $ \scc -> case scc of - AcyclicSCC (c,_,_) -> return (foldComponent (const CLibName) - (CExeName . exeName) - (CTestName . testName) - c) - CyclicSCC vs -> - die $ "Found cycle in intrapackage dependency graph:\n " - ++ intercalate " depends on " - (map (\(_,k,_) -> "'" ++ k ++ "'") (vs ++ [head vs])) - - let lbi = LocalBuildInfo { - configFlags = cfg, - extraConfigArgs = [], -- Currently configure does not - -- take extra args, but if it - -- did they would go here. - installDirTemplates = installDirs, - compiler = comp, - buildDir = buildDir', - scratchDir = fromFlagOrDefault - (distPref "scratch") - (configScratchDir cfg), - libraryConfig = configLib `fmap` library pkg_descr', - executableConfigs = configExe `fmap` executables pkg_descr', - testSuiteConfigs = configTest `fmap` testSuites pkg_descr', - compBuildOrder = buildOrder, - installedPkgs = packageDependsIndex, - pkgDescrFile = Nothing, - localPkgDescr = pkg_descr', - withPrograms = programsConfig'''', - withVanillaLib = fromFlag $ configVanillaLib cfg, - withProfLib = fromFlag $ configProfLib cfg, - withSharedLib = fromFlag $ configSharedLib cfg, - withDynExe = fromFlag $ configDynExe cfg, - withProfExe = fromFlag $ configProfExe cfg, - withOptimization = fromFlag $ configOptimization cfg, - withGHCiLib = fromFlag $ configGHCiLib cfg, - splitObjs = split_objs, - stripExes = fromFlag $ configStripExes cfg, - withPackageDB = packageDbs, - progPrefix = fromFlag $ configProgPrefix cfg, - progSuffix = fromFlag $ configProgSuffix cfg - } - - let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest - relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi - - unless (isAbsolute (prefix dirs)) $ die $ - "expected an absolute directory name for --prefix: " ++ prefix dirs - - info verbosity $ "Using " ++ display currentCabalId - ++ " compiled by " ++ display currentCompilerId - info verbosity $ "Using compiler: " ++ showCompilerId comp - info verbosity $ "Using install prefix: " ++ prefix dirs - - let dirinfo name dir isPrefixRelative = - info verbosity $ name ++ " installed in: " ++ dir ++ relNote - where relNote = case buildOS of - Windows | not (hasLibs pkg_descr) - && isNothing isPrefixRelative - -> " (fixed location)" - _ -> "" - - dirinfo "Binaries" (bindir dirs) (bindir relative) - dirinfo "Libraries" (libdir dirs) (libdir relative) - dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative) - dirinfo "Data files" (datadir dirs) (datadir relative) - dirinfo "Documentation" (docdir dirs) (docdir relative) - - sequence_ [ reportProgram verbosity prog configuredProg - | (prog, configuredProg) <- knownPrograms programsConfig'''' ] - - return lbi - - where - addInternalExe bd exe = - let nm = exeName exe in - addKnownProgram Program { - programName = nm, - programFindLocation = \_ -> return $ Just $ bd nm nm, - programFindVersion = \_ _ -> return Nothing, - programPostConf = \_ _ -> return [] - } - - addExtraIncludeLibDirs pkg_descr = - let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg - , PD.includeDirs = configExtraIncludeDirs cfg} - modifyLib l = l{ libBuildInfo = libBuildInfo l `mappend` extraBi } - modifyExecutable e = e{ buildInfo = buildInfo e `mappend` extraBi} - in pkg_descr{ library = modifyLib `fmap` library pkg_descr - , executables = modifyExecutable `map` executables pkg_descr} - --- ----------------------------------------------------------------------------- --- Configuring package dependencies - -reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () -reportProgram verbosity prog Nothing - = info verbosity $ "No " ++ programName prog ++ " found" -reportProgram verbosity prog (Just configuredProg) - = info verbosity $ "Using " ++ programName prog ++ version ++ location - where location = case programLocation configuredProg of - FoundOnSystem p -> " found on system at: " ++ p - UserSpecified p -> " given by user at: " ++ p - version = case programVersion configuredProg of - Nothing -> "" - Just v -> " version " ++ display v - -hackageUrl :: String -hackageUrl = "http://hackage.haskell.org/package/" - -data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo - | InternalDependency Dependency PackageId -- should be a lib name - -data FailedDependency = DependencyNotExists PackageName - | DependencyNoVersion Dependency - --- | Test for a package dependency and record the version we have installed. -selectDependency :: PackageIndex -- ^ Internally defined packages - -> PackageIndex -- ^ Installed packages - -> Dependency - -> Either FailedDependency ResolvedDependency -selectDependency internalIndex installedIndex - dep@(Dependency pkgname vr) = - -- If the dependency specification matches anything in the internal package - -- index, then we prefer that match to anything in the second. - -- For example: - -- - -- Name: MyLibrary - -- Version: 0.1 - -- Library - -- .. - -- Executable my-exec - -- build-depends: MyLibrary - -- - -- We want "build-depends: MyLibrary" always to match the internal library - -- even if there is a newer installed library "MyLibrary-0.2". - -- However, "build-depends: MyLibrary >= 0.2" should match the installed one. - case PackageIndex.lookupPackageName internalIndex pkgname of - [(_,[pkg])] | packageVersion pkg `withinRange` vr - -> Right $ InternalDependency dep (packageId pkg) - - _ -> case PackageIndex.lookupDependency installedIndex dep of - [] -> Left $ DependencyNotExists pkgname - pkgs -> Right $ ExternalDependency dep $ - -- by default we just pick the latest - case last pkgs of - (_ver, instances) -> head instances -- the first preference - -reportSelectedDependencies :: Verbosity - -> [ResolvedDependency] -> IO () -reportSelectedDependencies verbosity deps = - info verbosity $ unlines - [ "Dependency " ++ display (simplifyDependency dep) - ++ ": using " ++ display pkgid - | resolved <- deps - , let (dep, pkgid) = case resolved of - ExternalDependency dep' pkg' -> (dep', packageId pkg') - InternalDependency dep' pkgid' -> (dep', pkgid') ] - -reportFailedDependencies :: [FailedDependency] -> IO () -reportFailedDependencies [] = return () -reportFailedDependencies failed = - die (intercalate "\n\n" (map reportFailedDependency failed)) - - where - reportFailedDependency (DependencyNotExists pkgname) = - "there is no version of " ++ display pkgname ++ " installed.\n" - ++ "Perhaps you need to download and install it from\n" - ++ hackageUrl ++ display pkgname ++ "?" - - reportFailedDependency (DependencyNoVersion dep) = - "cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n" - -getInstalledPackages :: Verbosity -> Compiler - -> PackageDBStack -> ProgramConfiguration - -> IO PackageIndex -getInstalledPackages verbosity comp packageDBs progconf = do - 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 - flv -> die $ "don't know how to find the installed packages for " - ++ display flv - --- | Currently the user interface specifies the package dbs to use with just a --- single valued option, a 'PackageDB'. However internally we represent the --- stack of 'PackageDB's explictly as a list. This function converts encodes --- the package db stack implicit in a single packagedb. --- -implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack -implicitPackageDbStack userInstall maybePackageDB - | userInstall = GlobalPackageDB : UserPackageDB : extra - | otherwise = GlobalPackageDB : extra - where - extra = case maybePackageDB of - Just (SpecificPackageDB db) -> [SpecificPackageDB db] - _ -> [] - -newPackageDepsBehaviourMinVersion :: Version -newPackageDepsBehaviourMinVersion = Version { versionBranch = [1,7,1], versionTags = [] } - --- In older cabal versions, there was only one set of package dependencies for --- the whole package. In this version, we can have separate dependencies per --- target, but we only enable this behaviour if the minimum cabal version --- specified is >= a certain minimum. Otherwise, for compatibility we use the --- old behaviour. -newPackageDepsBehaviour :: PackageDescription -> Bool -newPackageDepsBehaviour pkg = - specVersion pkg >= newPackageDepsBehaviourMinVersion - --- ----------------------------------------------------------------------------- --- Configuring program dependencies - -configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration -> IO ProgramConfiguration -configureRequiredPrograms verbosity deps conf = - foldM (configureRequiredProgram verbosity) conf deps - -configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency -> IO ProgramConfiguration -configureRequiredProgram verbosity conf (Dependency (PackageName progName) verRange) = - case lookupKnownProgram progName conf of - Nothing -> die ("Unknown build tool " ++ progName) - Just prog - -- requireProgramVersion always requires the program have a version - -- but if the user says "build-depends: foo" ie no version constraint - -- then we should not fail if we cannot discover the program version. - | verRange == anyVersion -> do - (_, conf') <- requireProgram verbosity prog conf - return conf' - | otherwise -> do - (_, _, conf') <- requireProgramVersion verbosity prog verRange conf - return conf' - --- ----------------------------------------------------------------------------- --- Configuring pkg-config package dependencies - -configurePkgconfigPackages :: Verbosity -> PackageDescription - -> ProgramConfiguration - -> IO (PackageDescription, ProgramConfiguration) -configurePkgconfigPackages verbosity pkg_descr conf - | null allpkgs = return (pkg_descr, conf) - | otherwise = do - (_, _, conf') <- requireProgramVersion - (lessVerbose verbosity) pkgConfigProgram - (orLaterVersion $ Version [0,9,0] []) conf - mapM_ requirePkg allpkgs - lib' <- updateLibrary (library pkg_descr) - exes' <- mapM updateExecutable (executables pkg_descr) - let pkg_descr' = pkg_descr { library = lib', executables = exes' } - return (pkg_descr', conf') - - where - allpkgs = concatMap pkgconfigDepends (allBuildInfo pkg_descr) - pkgconfig = rawSystemProgramStdoutConf (lessVerbose verbosity) - pkgConfigProgram conf - - requirePkg dep@(Dependency (PackageName pkg) range) = do - version <- pkgconfig ["--modversion", pkg] - `catchIO` (\_ -> die notFound) - `catchExit` (\_ -> die notFound) - case simpleParse version of - Nothing -> die "parsing output of pkg-config --modversion failed" - Just v | not (withinRange v range) -> die (badVersion v) - | otherwise -> info verbosity (depSatisfied v) - where - notFound = "The pkg-config package " ++ pkg ++ versionRequirement - ++ " is required but it could not be found." - badVersion v = "The pkg-config package " ++ pkg ++ versionRequirement - ++ " is required but the version installed on the" - ++ " system is version " ++ display v - depSatisfied v = "Dependency " ++ display dep - ++ ": using version " ++ display v - - versionRequirement - | isAnyVersion range = "" - | otherwise = " version " ++ display range - - updateLibrary Nothing = return Nothing - updateLibrary (Just lib) = do - bi <- pkgconfigBuildInfo (pkgconfigDepends (libBuildInfo lib)) - return $ Just lib { libBuildInfo = libBuildInfo lib `mappend` bi } - - updateExecutable exe = do - bi <- pkgconfigBuildInfo (pkgconfigDepends (buildInfo exe)) - return exe { buildInfo = buildInfo exe `mappend` bi } - - pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo - pkgconfigBuildInfo [] = return mempty - pkgconfigBuildInfo pkgdeps = do - let pkgs = nub [ display pkg | Dependency pkg _ <- pkgdeps ] - ccflags <- pkgconfig ("--cflags" : pkgs) - ldflags <- pkgconfig ("--libs" : pkgs) - return (ccLdOptionsBuildInfo (words ccflags) (words ldflags)) - --- | Makes a 'BuildInfo' from C compiler and linker flags. --- --- This can be used with the output from configuration programs like pkg-config --- and similar package-specific programs like mysql-config, freealut-config etc. --- For example: --- --- > ccflags <- rawSystemProgramStdoutConf verbosity prog conf ["--cflags"] --- > ldflags <- rawSystemProgramStdoutConf verbosity prog conf ["--libs"] --- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags)) --- -ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo -ccLdOptionsBuildInfo cflags ldflags = - let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags - (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags - (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' - in mempty { - PD.includeDirs = map (drop 2) includeDirs', - PD.extraLibs = map (drop 2) extraLibs', - PD.extraLibDirs = map (drop 2) extraLibDirs', - PD.ccOptions = cflags', - PD.ldOptions = ldflags'' - } - --- ----------------------------------------------------------------------------- --- Determining the compiler details - -configCompilerAux :: ConfigFlags -> IO (Compiler, ProgramConfiguration) -configCompilerAux cfg = configCompiler (flagToMaybe $ configHcFlavor cfg) - (flagToMaybe $ configHcPath cfg) - (flagToMaybe $ configHcPkg cfg) - programsConfig - (fromFlag (configVerbosity cfg)) - where - programsConfig = userSpecifyArgss (configProgramArgs cfg) - . userSpecifyPaths (configProgramPaths cfg) - $ defaultProgramConfiguration - -configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> Verbosity - -> IO (Compiler, ProgramConfiguration) -configCompiler Nothing _ _ _ _ = die "Unknown compiler" -configCompiler (Just hcFlavor) hcPath hcPkg conf verbosity = do - 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 - _ -> die "Unknown compiler" - - --- Try to build a test C program which includes every header and links every --- lib. If that fails, try to narrow it down by preprocessing (only) and linking --- with individual headers and libs. If none is the obvious culprit then give a --- generic error message. --- TODO: produce a log file from the compiler errors, if any. -checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () -checkForeignDeps pkg lbi verbosity = do - ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling lucky - (return ()) - (do missingLibs <- findMissingLibs - missingHdr <- findOffendingHdr - explainErrors missingHdr missingLibs) - where - allHeaders = collectField PD.includes - allLibs = collectField PD.extraLibs - - ifBuildsWith headers args success failure = do - ok <- builds (makeProgram headers) args - if ok then success else failure - - findOffendingHdr = - ifBuildsWith allHeaders ccArgs - (return Nothing) - (go . tail . inits $ allHeaders) - where - go [] = return Nothing -- cannot happen - go (hdrs:hdrsInits) = - -- Try just preprocessing first - ifBuildsWith hdrs cppArgs - -- If that works, try compiling too - (ifBuildsWith hdrs ccArgs - (go hdrsInits) - (return . Just . Right . last $ hdrs)) - (return . Just . Left . last $ hdrs) - - cppArgs = "-E":commonCppArgs -- preprocess only - ccArgs = "-c":commonCcArgs -- don't try to link - - findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs) - (return []) - (filterM (fmap not . libExists) allLibs) - - libExists lib = builds (makeProgram []) (makeLdArgs [lib]) - - commonCppArgs = hcDefines (compiler lbi) - ++ [ "-I" ++ autogenModulesDir lbi ] - ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ] - ++ ["-I."] - ++ collectField PD.cppOptions - ++ collectField PD.ccOptions - ++ [ "-I" ++ dir - | dep <- deps - , dir <- Installed.includeDirs dep ] - ++ [ opt - | dep <- deps - , opt <- Installed.ccOptions dep ] - - commonCcArgs = commonCppArgs - ++ collectField PD.ccOptions - ++ [ opt - | dep <- deps - , opt <- Installed.ccOptions dep ] - - commonLdArgs = [ "-L" ++ dir | dir <- collectField PD.extraLibDirs ] - ++ collectField PD.ldOptions - ++ [ "-L" ++ dir - | dep <- deps - , dir <- Installed.libraryDirs dep ] - --TODO: do we also need dependent packages' ld options? - makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs - - makeProgram hdrs = unlines $ - [ "#include \"" ++ hdr ++ "\"" | hdr <- hdrs ] ++ - ["int main(int argc, char** argv) { return 0; }"] - - collectField f = concatMap f allBi - allBi = allBuildInfo pkg - deps = PackageIndex.topologicalOrder (installedPkgs lbi) - - builds program args = do - tempDir <- getTemporaryDirectory - withTempFile tempDir ".c" $ \cName cHnd -> - withTempFile tempDir "" $ \oNname oHnd -> do - hPutStrLn cHnd program - hClose cHnd - hClose oHnd - _ <- rawSystemProgramStdoutConf verbosity - gccProgram (withPrograms lbi) (cName:"-o":oNname:args) - return True - `catchIO` (\_ -> return False) - `catchExit` (\_ -> return False) - - explainErrors Nothing [] = return () -- should be impossible! - explainErrors hdr libs = die $ unlines $ - [ if plural - then "Missing dependencies on foreign libraries:" - else "Missing dependency on a foreign library:" - | missing ] - ++ case hdr of - Just (Left h) -> ["* Missing (or bad) header file: " ++ h ] - _ -> [] - ++ case libs of - [] -> [] - [lib] -> ["* Missing C library: " ++ lib] - _ -> ["* Missing C libraries: " ++ intercalate ", " libs] - ++ [if plural then messagePlural else messageSingular | missing] - ++ case hdr of - Just (Left _) -> [ headerCppMessage ] - Just (Right h) -> [ (if missing then "* " else "") - ++ "Bad header file: " ++ h - , headerCcMessage ] - _ -> [] - - where - plural = length libs >= 2 - -- Is there something missing? (as opposed to broken) - missing = not (null libs) - || case hdr of Just (Left _) -> True; _ -> False - - messageSingular = - "This problem can usually be solved by installing the system " - ++ "package that provides this library (you may need the " - ++ "\"-dev\" version). If the library is already installed " - ++ "but in a non-standard location then you can use the flags " - ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " - ++ "where it is." - messagePlural = - "This problem can usually be solved by installing the system " - ++ "packages that provide these libraries (you may need the " - ++ "\"-dev\" versions). If the libraries are already installed " - ++ "but in a non-standard location then you can use the flags " - ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " - ++ "where they are." - headerCppMessage = - "If the header file does exist, it may contain errors that " - ++ "are caught by the C compiler at the preprocessing stage. " - ++ "In this case you can re-run configure with the verbosity " - ++ "flag -v3 to see the error messages." - headerCcMessage = - "The header file contains a compile error. " - ++ "You can re-run configure with the verbosity flag " - ++ "-v3 to see the error messages from the C compiler." - - --FIXME: share this with the PreProcessor module - hcDefines :: Compiler -> [String] - hcDefines comp = - case compilerFlavor comp of - GHC -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version] - JHC -> ["-D__JHC__=" ++ versionInt version] - NHC -> ["-D__NHC__=" ++ versionInt version] - Hugs -> ["-D__HUGS__"] - _ -> [] - where - version = compilerVersion 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. - versionInt :: Version -> String - versionInt (Version { versionBranch = [] }) = "1" - versionInt (Version { versionBranch = [n] }) = show n - versionInt (Version { versionBranch = n1:n2:_ }) - = -- 6.8.x -> 608 - -- 6.10.x -> 610 - let s1 = show n1 - s2 = show n2 - middle = case s2 of - _ : _ : _ -> "" - _ -> "0" - in s1 ++ middle ++ s2 - --- | Output package check warnings and errors. Exit if any errors. -checkPackageProblems :: Verbosity - -> GenericPackageDescription - -> PackageDescription - -> IO () -checkPackageProblems verbosity gpkg pkg = do - ioChecks <- checkPackageFiles pkg "." - let pureChecks = checkPackage gpkg (Just pkg) - errors = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ] - warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ] - if null errors - then mapM_ (warn verbosity) warnings - else do mapM_ (hPutStrLn stderr . ("Error: " ++)) errors - exitWith (ExitFailure 1) diff --git a/cabal/cabal/Distribution/Simple/GHC.hs b/cabal/cabal/Distribution/Simple/GHC.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/GHC.hs +++ /dev/null @@ -1,1079 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 ( - configure, getInstalledPackages, - buildLib, buildExe, - installLib, installExe, - libAbiHash, - registerPackage, - ghcOptions, - ghcVerbosityOptions, - ghcPackageDbOptions, - ghcLibDir, - ) 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, 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(..) - , absoluteInstallDirs ) -import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Package - ( PackageIdentifier, Package(..), PackageName(..) ) -import qualified Distribution.ModuleName as ModuleName -import Distribution.Simple.Program - ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg - , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf - , rawSystemProgramStdout, rawSystemProgramStdoutConf - , requireProgramVersion, requireProgram, getProgramOutput - , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram - , ghcProgram, ghcPkgProgram, hsc2hsProgram - , arProgram, ranlibProgram, 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 Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion - , OptimisationLevel(..), PackageDB(..), PackageDBStack - , Flag, languageToFlags, extensionsToFlags ) -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, liftM ) -import Data.Char ( isSpace ) -import Data.List -import Data.Maybe ( catMaybes ) -import Data.Monoid ( Monoid(..) ) -import System.Directory - ( removeFile, getDirectoryContents, doesFileExist - , getTemporaryDirectory ) -import System.FilePath ( (), (<.>), takeExtension, - takeDirectory, replaceExtension, splitExtension ) -import System.IO (hClose, hPutStrLn) -import Distribution.Compat.Exception (catchExit, catchIO) - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> IO (Compiler, 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 <- if ghcVersion >= Version [6,7] [] - then do xs <- getProgramOutput verbosity ghcProg ["--info"] - case reads xs of - [(i, ss)] - | all isSpace ss -> - return i - _ -> - die "Can't parse --info output of GHC" - else return [] - - let comp = Compiler { - compilerId = CompilerId GHC ghcVersion, - compilerLanguages = languages, - compilerExtensions = extensions - } - conf4 = configureToolchain ghcProg ghcInfo conf3 -- configure gcc and ld - return (comp, 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 :: FilePath -> ConfiguredProgram -> Verbosity - -> IO (Maybe FilePath) -guessToolFromGhcPath tool ghcProg verbosity - = do let path = programPath ghcProg - dir = takeDirectory path - versionSuffix = takeVersionSuffix (dropExeExtension path) - guessNormal = dir tool <.> exeExtension - guessGhcVersioned = dir (tool ++ "-ghc" ++ versionSuffix) <.> exeExtension - guessVersioned = dir (tool ++ versionSuffix) <.> exeExtension - guesses | null versionSuffix = [guessNormal] - | otherwise = [guessGhcVersioned, - guessVersioned, - guessNormal] - info verbosity $ "looking for tool " ++ show tool ++ " near compiler in " ++ dir - exists <- mapM doesFileExist guesses - case [ file | (file, True) <- zip guesses exists ] of - [] -> return Nothing - (fp:_) -> do info verbosity $ "found " ++ tool ++ " 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 -> IO (Maybe FilePath) -guessGhcPkgFromGhcPath = guessToolFromGhcPath "ghc-pkg" - --- | 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 -> IO (Maybe FilePath) -guessHsc2hsFromGhcPath = guessToolFromGhcPath "hsc2hs" - --- | Adjust the way we find and configure gcc and ld --- -configureToolchain :: ConfiguredProgram -> [(String, String)] - -> ProgramConfiguration - -> ProgramConfiguration -configureToolchain ghcProg ghcInfo = - addKnownProgram gccProgram { - programFindLocation = findProg gccProgram - [ if ghcVersion >= Version [6,12] [] - then mingwBinDir "gcc.exe" - else baseDir "gcc.exe" ], - programPostConf = configureGcc - } - . addKnownProgram ldProgram { - programFindLocation = findProg ldProgram - [ if ghcVersion >= Version [6,12] [] - then mingwBinDir "ld.exe" - else libDir "ld.exe" ], - programPostConf = configureLd - } - . addKnownProgram arProgram { - programFindLocation = findProg arProgram - [ if ghcVersion >= Version [6,12] [] - then mingwBinDir "ar.exe" - else libDir "ar.exe" ] - } - 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 - - -- on Windows finding and configuring ghc's gcc and ld is a bit special - findProg :: Program -> [FilePath] -> Verbosity -> IO (Maybe FilePath) - findProg prog locations - | isWindows = \verbosity -> look locations verbosity - | otherwise = programFindLocation prog - where - look [] verbosity = do - warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.") - programFindLocation prog verbosity - look (f:fs) verbosity = do - exists <- doesFileExist f - if exists then return (Just f) - else look fs verbosity - - ccFlags = getFlags "C compiler flags" - gccLinkerFlags = getFlags "Gcc Linker flags" - ldLinkerFlags = getFlags "Ld Linker flags" - - getFlags key = case lookup key ghcInfo of - Nothing -> [] - Just flags -> - case reads flags of - [(args, "")] -> args - _ -> [] -- XXX Should should be an error really - - configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg] - configureGcc v cp = liftM (++ (ccFlags ++ gccLinkerFlags)) - $ configureGcc' v cp - - configureGcc' :: Verbosity -> ConfiguredProgram -> IO [ProgArg] - 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 ["-B" ++ libDir, "-I" ++ includeDir] - _ -> return [] - | otherwise = \_ _ -> return [] - - configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg] - configureLd v cp = liftM (++ ldLinkerFlags) $ configureLd' v cp - - -- we need to find out if ld supports the -x flag - configureLd' :: Verbosity -> ConfiguredProgram -> IO [ProgArg] - configureLd' verbosity ldProg = do - tempDir <- getTemporaryDirectory - ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> - withTempFile tempDir ".o" $ \testofile testohnd -> do - hPutStrLn testchnd "int foo() {}" - 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 ["-x"] - else return [] - -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 - -getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] -getExtensions verbosity ghcProg - | ghcVersion >= Version [6,7] [] = do - - str <- rawSystemStdout verbosity (programPath 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) - ] - -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration - -> IO PackageIndex -getInstalledPackages verbosity packagedbs conf = do - checkPackageDbStack packagedbs - pkgss <- getInstalledPackages' verbosity packagedbs conf - topDir <- ghcLibDir' verbosity ghcProg - let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) - | (_, pkgs) <- pkgss ] - return $! hackRtsPackage (mconcat indexes) - - where - -- On Windows, various fields have $topdir/foo rather than full - -- paths. We need to substitute the right value in so that when - -- we, for example, call gcc, we have proper paths to give it - Just ghcProg = lookupProgram ghcProgram conf - - 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. - -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"] - -checkPackageDbStack :: PackageDBStack -> IO () -checkPackageDbStack (GlobalPackageDB:rest) - | GlobalPackageDB `notElem` rest = return () -checkPackageDbStack _ = - die $ "GHC.getInstalledPackages: the global package db 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 :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity pkg_descr lbi lib clbi = do - let pref = buildDir lbi - pkgid = packageId pkg_descr - runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi) - ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) - ifProfLib = when (withProfLib lbi) - ifSharedLib = when (withSharedLib lbi) - ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) - comp = compiler lbi - - libBi <- hackThreadedFlag verbosity - comp (withProfLib lbi) (libBuildInfo lib) - - let libTargetDir = pref - forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi - -- 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? - let ghcArgs = - "--make" - : ["-package-name", display pkgid ] - ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity - ++ map display (libModules lib) - ghcArgsProf = ghcArgs - ++ ["-prof", - "-hisuf", "p_hi", - "-osuf", "p_o" - ] - ++ ghcProfOptions libBi - ghcArgsShared = ghcArgs - ++ ["-dynamic", - "-hisuf", "dyn_hi", - "-osuf", "dyn_o", "-fPIC" - ] - ++ ghcSharedOptions libBi - unless (null (libModules lib)) $ - do ifVanillaLib forceVanillaLib (runGhcProg ghcArgs) - ifProfLib (runGhcProg ghcArgsProf) - ifSharedLib (runGhcProg ghcArgsShared) - - -- build any C sources - unless (null (cSources libBi)) $ do - info verbosity "Building C Sources..." - sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref - filename verbosity - False - (withProfLib lbi) - createDirectoryIfMissingVerbose verbosity True odir - runGhcProg args - ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"])) - | filename <- cSources libBi] - - -- link: - info verbosity "Linking..." - let cObjs = map (`replaceExtension` objExtension) (cSources libBi) - cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) - vanillaLibFilePath = libTargetDir mkLibName pkgid - profileLibFilePath = libTargetDir mkProfLibName pkgid - sharedLibFilePath = libTargetDir mkSharedLibName pkgid - (compilerId (compiler lbi)) - ghciLibFilePath = libTargetDir mkGHCiLibName pkgid - libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest - sharedLibInstallPath = libInstallPath mkSharedLibName pkgid - (compilerId (compiler lbi)) - - stubObjs <- fmap catMaybes $ sequence - [ findFileWithExtension [objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | x <- libModules lib ] - stubProfObjs <- fmap catMaybes $ sequence - [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | x <- libModules lib ] - stubSharedObjs <- fmap catMaybes $ sequence - [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | x <- libModules lib ] - - hObjs <- getHaskellObjects lib lbi - pref objExtension True - hProfObjs <- - if (withProfLib lbi) - then getHaskellObjects lib lbi - pref ("p_" ++ objExtension) True - else return [] - hSharedObjs <- - if (withSharedLib lbi) - then getHaskellObjects lib lbi - pref ("dyn_" ++ objExtension) False - else return [] - - unless (null hObjs && null cObjs && null stubObjs) $ do - -- first remove library files if they exists - sequence_ - [ removeFile libFilePath `catchIO` \_ -> return () - | libFilePath <- [vanillaLibFilePath, profileLibFilePath - ,sharedLibFilePath, ghciLibFilePath] ] - - let staticObjectFiles = - hObjs - ++ map (pref ) cObjs - ++ stubObjs - profObjectFiles = - hProfObjs - ++ map (pref ) cObjs - ++ stubProfObjs - ghciObjFiles = - hObjs - ++ map (pref ) cObjs - ++ stubObjs - dynamicObjectFiles = - hSharedObjs - ++ map (pref ) 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 = - [ "-no-auto-link-packages", - "-shared", - "-dynamic", - "-o", sharedLibFilePath ] - -- For dynamic libs, Mac OS/X needs to know the install location - -- at build time. - ++ (if buildOS == OSX - then ["-dylib-install-name", sharedLibInstallPath] - else []) - ++ dynamicObjectFiles - ++ ["-package-name", display pkgid ] - ++ ghcPackageFlags lbi clbi - ++ ["-l"++extraLib | extraLib <- extraLibs libBi] - ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi] - - ifVanillaLib False $ do - (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi) - Ar.createArLibArchive verbosity arProg - vanillaLibFilePath staticObjectFiles - - ifProfLib $ do - (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi) - Ar.createArLibArchive verbosity arProg - profileLibFilePath profObjectFiles - - ifGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity ldProg - ghciLibFilePath ghciObjFiles - - ifSharedLib $ - runGhcProg ghcSharedLinkArgs - - --- | Build an executable with GHC. --- -buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe verbosity _pkg_descr lbi - exe@Executable { exeName = exeName', modulePath = modPath } clbi = do - let pref = buildDir lbi - runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi) - - exeBi <- hackThreadedFlag verbosity - (compiler lbi) (withProfExe lbi) (buildInfo exe) - - -- exeNameReal, the name that GHC really uses (with .exe on Windows) - let exeNameReal = exeName' <.> - (if null $ takeExtension exeName' then exeExtension else "") - - let targetDir = pref exeName' - let exeDir = targetDir (exeName' ++ "-tmp") - createDirectoryIfMissingVerbose verbosity True targetDir - createDirectoryIfMissingVerbose verbosity True exeDir - -- TODO: do we need to put hs-boot files into place for mutually recursive modules? - -- FIX: what about exeName.hi-boot? - - -- build executables - unless (null (cSources exeBi)) $ do - info verbosity "Building C Sources." - sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi - exeDir filename verbosity - (withDynExe lbi) (withProfExe lbi) - createDirectoryIfMissingVerbose verbosity True odir - runGhcProg args - | filename <- cSources exeBi] - - srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath - - let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) - let binArgs linkExe dynExe profExe = - "--make" - : (if linkExe - then ["-o", targetDir exeNameReal] - else ["-c"]) - ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity - ++ [exeDir x | x <- cObjs] - ++ [srcMainFile] - ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi] - ++ ["-l"++lib | lib <- extraLibs exeBi] - ++ ["-L"++libDir | libDir <- extraLibDirs exeBi] - ++ concat [["-framework", f] | f <- PD.frameworks exeBi] - ++ if dynExe - then ["-dynamic"] - else [] - ++ if profExe - then ["-prof", - "-hisuf", "p_hi", - "-osuf", "p_o" - ] ++ ghcProfOptions exeBi - else [] - - -- For building exe's for profiling that use TH we actually - -- have to build twice, once without profiling and the again - -- with profiling. 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. - when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi) - (runGhcProg (binArgs False (withDynExe lbi) False)) - - runGhcProg (binArgs True (withDynExe lbi) (withProfExe lbi)) - --- | 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 ] - --- 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 - ghcArgs = - "--abi-hash" - : ["-package-name", display (packageId pkg_descr) ] - ++ constructGHCCmdLine lbi libBi clbi (buildDir lbi) verbosity - ++ map display (exposedModules lib) - -- - rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ghcArgs - - -constructGHCCmdLine - :: LocalBuildInfo - -> BuildInfo - -> ComponentLocalBuildInfo - -> FilePath - -> Verbosity - -> [String] -constructGHCCmdLine lbi bi clbi odir verbosity = - ghcVerbosityOptions verbosity - -- Unsupported extensions have already been checked by configure - ++ ghcOptions lbi bi clbi odir - -ghcVerbosityOptions :: Verbosity -> [String] -ghcVerbosityOptions verbosity - | verbosity >= deafening = ["-v"] - | verbosity >= normal = [] - | otherwise = ["-w", "-v0"] - -ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> [String] -ghcOptions lbi bi clbi odir - = ["-hide-all-packages"] - ++ ["-fbuilding-cabal-package" | ghcVer >= Version [6,11] [] ] - ++ ghcPackageDbOptions (withPackageDB lbi) - ++ ["-split-objs" | splitObjs lbi ] - ++ ["-i"] - ++ ["-i" ++ odir] - ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] - ++ ["-i" ++ autogenModulesDir lbi] - ++ ["-I" ++ autogenModulesDir lbi] - ++ ["-I" ++ odir] - ++ ["-I" ++ dir | dir <- PD.includeDirs bi] - ++ ["-optP" ++ opt | opt <- cppOptions bi] - ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] - ++ [ "-#include \"" ++ inc ++ "\"" | ghcVer < Version [6,11] [] - , inc <- PD.includes bi ] - ++ [ "-odir", odir, "-hidir", odir ] - ++ concat [ ["-stubdir", odir] | ghcVer >= Version [6,8] [] ] - ++ ghcPackageFlags lbi clbi - ++ (case withOptimization lbi of - NoOptimisation -> [] - NormalOptimisation -> ["-O"] - MaximumOptimisation -> ["-O2"]) - ++ hcOptions GHC bi - ++ languageToFlags (compiler lbi) (defaultLanguage bi) - ++ extensionsToFlags (compiler lbi) (usedExtensions bi) - where - ghcVer = compilerVersion (compiler lbi) - -ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String] -ghcPackageFlags lbi clbi - | ghcVer >= Version [6,11] [] - = concat [ ["-package-id", display ipkgid] - | (ipkgid, _) <- componentPackageDeps clbi ] - - | otherwise = concat [ ["-package", display pkgid] - | (_, pkgid) <- componentPackageDeps clbi ] - where - ghcVer = compilerVersion (compiler lbi) - -ghcPackageDbOptions :: PackageDBStack -> [String] -ghcPackageDbOptions dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs - (GlobalPackageDB:dbs) -> "-no-user-package-conf" - : concatMap specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = [ "-package-conf", db ] - specific _ = ierror - ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) - -constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath -> Verbosity -> Bool -> Bool - ->(FilePath,[String]) -constructCcCmdLine lbi bi clbi pref filename verbosity dynamic profiling - = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref - | otherwise = pref takeDirectory filename - -- ghc 6.4.1 fixed a bug in -odir handling - -- for C compilations. - in - (odir, - ghcCcOptions lbi bi clbi odir - ++ (if verbosity >= deafening then ["-v"] else []) - ++ ["-c",filename] - -- Note: When building with profiling enabled, we pass the -prof - -- option to ghc here when compiling C code, so that the PROFILING - -- macro gets defined. The macro is used in ghc's Rts.h in the - -- definitions of closure layouts (Closures.h). - ++ ["-dynamic" | dynamic] - ++ ["-prof" | profiling]) - -ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> [String] -ghcCcOptions lbi bi clbi odir - = ["-I" ++ dir | dir <- odir : PD.includeDirs bi] - ++ ghcPackageDbOptions (withPackageDB lbi) - ++ ghcPackageFlags lbi clbi - ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] - ++ (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-optc-O2"]) - ++ ["-odir", odir] - -mkGHCiLibName :: PackageIdentifier -> String -mkGHCiLibName lib = "HS" ++ display 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) - stripExe verbosity lbi exeFileName (dest <.> exeExtension) - installBinary (binDir fixedExeBaseName) - -stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () -stripExe verbosity lbi name path = when (stripExes lbi) $ - case lookupProgram stripProgram (withPrograms lbi) of - Just strip -> rawSystemProgram verbosity strip args - Nothing -> unless (buildOS == Windows) $ - -- Don't bother warning on windows, we don't expect them to - -- have the strip program anyway. - warn verbosity $ "Unable to strip executable '" ++ name - ++ "' (missing the 'strip' program)" - where - args = path : case buildOS 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. - _ -> [] - --- |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 - -> IO () -installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do - -- copy .hi files over: - let copyHelper installFun src dst n = do - createDirectoryIfMissingVerbose verbosity True dst - installFun verbosity (src n) (dst n) - copy = copyHelper installOrdinaryFile - copyShared = copyHelper installExecutableFile - copyModuleFiles ext = - findModuleFiles [builtDir] [ext] (libModules lib) - >>= installOrdinaryFiles verbosity targetDir - ifVanilla $ copyModuleFiles "hi" - ifProf $ copyModuleFiles "p_hi" - ifShared $ copyModuleFiles "dyn_hi" - - -- copy the built library files over: - ifVanilla $ copy builtDir targetDir vanillaLibName - ifProf $ copy builtDir targetDir profileLibName - ifGHCi $ copy builtDir targetDir ghciLibName - ifShared $ copyShared builtDir dynlibTargetDir sharedLibName - - -- run ranlib if necessary: - ifVanilla $ updateLibArchive verbosity lbi - (targetDir vanillaLibName) - ifProf $ updateLibArchive verbosity lbi - (targetDir profileLibName) - - where - vanillaLibName = mkLibName pkgid - profileLibName = mkProfLibName pkgid - ghciLibName = mkGHCiLibName pkgid - sharedLibName = mkSharedLibName pkgid (compilerId (compiler lbi)) - - pkgid = packageId pkg - - hasLib = not $ null (libModules lib) - && null (cSources (libBuildInfo lib)) - ifVanilla = when (hasLib && withVanillaLib lbi) - ifProf = when (hasLib && withProfLib lbi) - ifGHCi = when (hasLib && withGHCiLib lbi) - ifShared = when (hasLib && withSharedLib lbi) - --- | On MacOS X we have to call @ranlib@ to regenerate the archive index after --- copying. This is because the silly MacOS X linker checks that the archive --- index is not older than the file itself, which means simply --- copying/installing the file breaks it!! --- -updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO () -updateLibArchive verbosity lbi path - | buildOS == OSX = do - (ranlib, _) <- requireProgram verbosity ranlibProgram (withPrograms lbi) - rawSystemProgram verbosity ranlib [path] - | otherwise = return () - - --- ----------------------------------------------------------------------------- --- Registering - -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) diff --git a/cabal/cabal/Distribution/Simple/GHC/IPI641.hs b/cabal/cabal/Distribution/Simple/GHC/IPI641.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/GHC/IPI641.hs +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.GHC.IPI641 --- Copyright : (c) The University of Glasgow 2004 --- --- 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, - toCurrent, - ) where - -import qualified Distribution.InstalledPackageInfo as Current -import qualified Distribution.Package as Current hiding (depends) -import Distribution.Text (display) - -import Distribution.Simple.GHC.IPI642 - ( PackageIdentifier, convertPackageId - , License, convertLicense, convertModuleName ) - --- | This is the InstalledPackageInfo type used by ghc-6.4 and 6.4.1. --- --- It's here purely for the 'Read' instance so that we can read the package --- database used by those ghc versions. It is a little hacky to read the --- package db directly, but we do need the info and until ghc-6.9 there was --- no better method. --- --- In ghc-6.4.2 the format changed a bit. See "Distribution.Simple.GHC.IPI642" --- -data InstalledPackageInfo = InstalledPackageInfo { - package :: PackageIdentifier, - license :: License, - copyright :: String, - maintainer :: String, - author :: String, - stability :: String, - homepage :: String, - pkgUrl :: String, - description :: String, - category :: String, - exposed :: Bool, - exposedModules :: [String], - hiddenModules :: [String], - importDirs :: [FilePath], - libraryDirs :: [FilePath], - hsLibraries :: [String], - extraLibraries :: [String], - includeDirs :: [FilePath], - includes :: [String], - depends :: [PackageIdentifier], - hugsOptions :: [String], - ccOptions :: [String], - ldOptions :: [String], - frameworkDirs :: [FilePath], - frameworks :: [String], - haddockInterfaces :: [FilePath], - haddockHTMLs :: [FilePath] - } - deriving Read - -mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId -mkInstalledPackageId = Current.InstalledPackageId . display - -toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo -toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo { - Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)), - Current.sourcePackageId = convertPackageId (package ipi), - Current.license = convertLicense (license ipi), - Current.copyright = copyright ipi, - Current.maintainer = maintainer ipi, - Current.author = author ipi, - Current.stability = stability ipi, - Current.homepage = homepage ipi, - Current.pkgUrl = pkgUrl ipi, - Current.synopsis = "", - Current.description = description ipi, - Current.category = category ipi, - Current.exposed = exposed ipi, - Current.exposedModules = map convertModuleName (exposedModules ipi), - Current.hiddenModules = map convertModuleName (hiddenModules ipi), - Current.trusted = False, - Current.importDirs = importDirs ipi, - Current.libraryDirs = libraryDirs ipi, - 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 - } diff --git a/cabal/cabal/Distribution/Simple/GHC/IPI642.hs b/cabal/cabal/Distribution/Simple/GHC/IPI642.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/GHC/IPI642.hs +++ /dev/null @@ -1,164 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.GHC.IPI642 --- Copyright : (c) The University of Glasgow 2004 --- --- 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, - toCurrent, - - -- Don't use these, they're only for conversion purposes - PackageIdentifier, convertPackageId, - License, convertLicense, - convertModuleName - ) where - -import qualified Distribution.InstalledPackageInfo as Current -import qualified Distribution.Package as Current hiding (depends) -import qualified Distribution.License as Current - -import Distribution.Version (Version) -import Distribution.ModuleName (ModuleName) -import Distribution.Text (simpleParse,display) - -import Data.Maybe - --- | This is the InstalledPackageInfo type used by ghc-6.4.2 and later. --- --- It's here purely for the 'Read' instance so that we can read the package --- database used by those ghc versions. It is a little hacky to read the --- package db directly, but we do need the info and until ghc-6.9 there was --- no better method. --- --- In ghc-6.4.1 and before the format was slightly different. --- See "Distribution.Simple.GHC.IPI642" --- -data InstalledPackageInfo = InstalledPackageInfo { - package :: PackageIdentifier, - license :: License, - copyright :: String, - maintainer :: String, - author :: String, - stability :: String, - homepage :: String, - pkgUrl :: String, - description :: String, - category :: String, - exposed :: Bool, - exposedModules :: [String], - hiddenModules :: [String], - importDirs :: [FilePath], - libraryDirs :: [FilePath], - hsLibraries :: [String], - extraLibraries :: [String], - extraGHCiLibraries:: [String], - includeDirs :: [FilePath], - includes :: [String], - depends :: [PackageIdentifier], - hugsOptions :: [String], - ccOptions :: [String], - ldOptions :: [String], - frameworkDirs :: [FilePath], - frameworks :: [String], - haddockInterfaces :: [FilePath], - haddockHTMLs :: [FilePath] - } - deriving Read - -data PackageIdentifier = PackageIdentifier { - pkgName :: String, - pkgVersion :: Version - } - deriving Read - -data License = GPL | LGPL | BSD3 | BSD4 - | PublicDomain | AllRightsReserved | OtherLicense - deriving Read - -convertPackageId :: PackageIdentifier -> Current.PackageIdentifier -convertPackageId PackageIdentifier { pkgName = n, pkgVersion = v } = - Current.PackageIdentifier (Current.PackageName n) v - -mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId -mkInstalledPackageId = Current.InstalledPackageId . display - -convertModuleName :: String -> ModuleName -convertModuleName s = fromJust $ simpleParse s - -convertLicense :: License -> Current.License -convertLicense GPL = Current.GPL Nothing -convertLicense LGPL = Current.LGPL Nothing -convertLicense BSD3 = Current.BSD3 -convertLicense BSD4 = Current.BSD4 -convertLicense PublicDomain = Current.PublicDomain -convertLicense AllRightsReserved = Current.AllRightsReserved -convertLicense OtherLicense = Current.OtherLicense - -toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo -toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo { - Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)), - Current.sourcePackageId = convertPackageId (package ipi), - Current.license = convertLicense (license ipi), - Current.copyright = copyright ipi, - Current.maintainer = maintainer ipi, - Current.author = author ipi, - Current.stability = stability ipi, - Current.homepage = homepage ipi, - Current.pkgUrl = pkgUrl ipi, - Current.synopsis = "", - Current.description = description ipi, - Current.category = category ipi, - Current.exposed = exposed ipi, - Current.exposedModules = map convertModuleName (exposedModules ipi), - Current.hiddenModules = map convertModuleName (hiddenModules ipi), - Current.trusted = False, - Current.importDirs = importDirs ipi, - Current.libraryDirs = libraryDirs ipi, - 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 - } diff --git a/cabal/cabal/Distribution/Simple/Haddock.hs b/cabal/cabal/Distribution/Simple/Haddock.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Haddock.hs +++ /dev/null @@ -1,629 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Haddock --- Copyright : Isaac Jones 2003-2005 --- --- 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 for haddock 0.x which involves --- \'unlit\'ing and using @-DHADDOCK@ 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. --- --- 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 - ) where - --- local -import Distribution.Package - ( PackageIdentifier, Package(..), packageName ) -import qualified Distribution.ModuleName as ModuleName -import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), allExtensions - , Library(..), hasLibs, Executable(..) ) -import Distribution.Simple.Compiler - ( Compiler(..), compilerVersion ) -import Distribution.Simple.GHC ( ghcLibDir ) -import Distribution.Simple.Program - ( ConfiguredProgram(..), requireProgramVersion - , rawSystemProgram, rawSystemProgramStdout - , hscolourProgram, haddockProgram ) -import Distribution.Simple.PreProcess (ppCpp', ppUnlit - , PPSuffixHandler, runSimplePreProcessor - , preprocessComponent) -import Distribution.Simple.Setup - ( defaultHscolourFlags, Flag(..), flagToMaybe, fromFlag - , HaddockFlags(..), HscolourFlags(..) ) -import Distribution.Simple.Build (initialBuildSteps) -import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate, - PathTemplateVariable(..), - toPathTemplate, fromPathTemplate, - substPathTemplate, - initialPathTemplateEnv) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), externalPackageDeps - , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI ) -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_(..) ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) -import Distribution.Simple.Utils - ( die, warn, notice, intercalate, setupMessage - , createDirectoryIfMissingVerbose, withTempFile, copyFileVerbose - , withTempDirectory - , findFileWithExtension, findFile ) -import Distribution.Simple.GHC (ghcOptions) -import Distribution.Text - ( display, simpleParse ) - -import Distribution.Verbosity -import Language.Haskell.Extension --- Base -import System.Directory(removeFile, doesFileExist, createDirectoryIfMissing) - -import Control.Monad ( when, guard ) -import Control.Exception (assert) -import Data.Monoid -import Data.Maybe ( fromMaybe, listToMaybe ) - -import System.FilePath((), (<.>), splitFileName, splitExtension, - normalise, splitPath, joinPath) -import System.IO (hClose, hPutStrLn) -import Distribution.Version - --- Types - --- | 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. - argVerbose :: Any, - argOutput :: Flag [Output], -- ^ Html or Hoogle doc or both? required. - argInterfaces :: [(FilePath, Maybe FilePath)], -- ^ [(interface file, path 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. - argGhcFlags :: [String], -- ^ 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. -} - --- | the FilePath of a directory, it's a monoid under () -newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord) - -unDir :: Directory -> FilePath -unDir = joinPath . filter (\p -> p /="./" && p /= ".") . splitPath . unDir' - -type Template = String - -data Output = Html | Hoogle - --- -------------------------------------------------------------------------- --- Haddock support - -haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO () -haddock pkg_descr _ _ haddockFlags - | not (hasLibs pkg_descr) - && not (fromFlag $ haddockExecutables haddockFlags) = - warn (fromFlag $ haddockVerbosity haddockFlags) $ - "No documentation was generated as this package does not contain " - ++ "a library. Perhaps you want to use the --executables flag." - -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) - - -- 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 (compiler lbi) - - -- 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 - - args <- fmap mconcat . sequence $ - [ getInterfaces verbosity lbi (flagToMaybe (haddockHtmlLocation flags)) - , getGhcLibDir verbosity lbi isVersion2 ] - ++ map return - [ fromFlags flags - , fromPackageDescription pkg_descr ] - - let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes - withComponentsLBI pkg_descr lbi $ \comp clbi -> do - pre comp - case comp of - CLib lib -> do - withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do - let bi = libBuildInfo lib - libArgs <- fromLibrary tmp lbi lib clbi - libArgs' <- prepareSources verbosity tmp - lbi isVersion2 bi (args `mappend` libArgs) - runHaddock verbosity confHaddock libArgs' - CExe exe -> when (flag haddockExecutables) $ do - withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do - let bi = buildInfo exe - exeArgs <- fromExecutable tmp lbi exe clbi - exeArgs' <- prepareSources verbosity tmp - lbi isVersion2 bi (args `mappend` exeArgs) - runHaddock verbosity confHaddock exeArgs' - _ -> return () - where - verbosity = flag haddockVerbosity - flag f = fromFlag $ f 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 - -> Bool -- haddock == 2.* - -> BuildInfo - -> HaddockArgs - -> IO HaddockArgs -prepareSources verbosity tmp lbi isVersion2 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 - defines | isVersion2 = [] - | otherwise = ["-D__HADDOCK__"] - --------------------------------------------------------------------------------------------------- --- constributions to HaddockArgs - -fromFlags :: HaddockFlags -> HaddockArgs -fromFlags 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}") - else NoFlag, - argCssFile = haddockCss flags, - argVerbose = maybe mempty (Any . (>= deafening)) . flagToMaybe $ haddockVerbosity flags, - argOutput = - Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++ - [ Hoogle | Flag True <- [haddockHoogle flags] ] - of [] -> [ Html ] - os -> os, - argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags - } - -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 - } - where - desc = PD.description pkg_descr - showPkg = display (packageId pkg_descr) - subtitle | null (synopsis pkg_descr) = "" - | otherwise = ": " ++ synopsis pkg_descr - -fromLibrary :: FilePath - -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo - -> IO HaddockArgs -fromLibrary tmp lbi lib clbi = - do inFiles <- map snd `fmap` getLibSourceFiles lbi lib - return $ mempty { - argHideModules = (mempty,otherModules $ bi), - argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi) - -- Noooooooooo!!!!!111 - -- haddock stomps on our precious .hi - -- and .o files. Workaround by telling - -- haddock to write them elsewhere. - ++ [ "-odir", tmp, "-hidir", tmp - , "-stubdir", tmp ], - argTargets = inFiles - } - where - bi = libBuildInfo lib - -fromExecutable :: FilePath - -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo - -> IO HaddockArgs -fromExecutable tmp lbi exe clbi = - do inFiles <- map snd `fmap` getExeSourceFiles lbi exe - return $ mempty { - argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi) - -- Noooooooooo!!!!!111 - -- haddock stomps on our precious .hi - -- and .o files. Workaround by telling - -- haddock to write them elsewhere. - ++ [ "-odir", tmp, "-hidir", tmp - , "-stubdir", tmp ], - argOutputDir = Dir (exeName exe), - argTitle = Flag (exeName exe), - argTargets = inFiles - } - where - bi = buildInfo exe - -getInterfaces :: Verbosity - -> LocalBuildInfo - -> Maybe String -- ^ template for html location - -> IO HaddockArgs -getInterfaces verbosity lbi location = do - let htmlTemplate = fmap toPathTemplate $ location - (packageFlags, warnings) <- haddockPackageFlags lbi htmlTemplate - maybe (return ()) (warn verbosity) warnings - return $ mempty { - argInterfaces = packageFlags - } - -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 - ----------------------------------------------------------------------------------------------- - --- | Call haddock with the specified arguments. -runHaddock :: Verbosity -> ConfiguredProgram -> HaddockArgs -> IO () -runHaddock verbosity confHaddock args = do - let haddockVersion = fromMaybe (error "unable to determine haddock version") - (programVersion confHaddock) - renderArgs verbosity haddockVersion args $ \(flags,result)-> do - - rawSystemProgram verbosity confHaddock flags - - notice verbosity $ "Documentation created: " ++ result - - -renderArgs :: Verbosity - -> Version - -> HaddockArgs - -> (([[Char]], FilePath) -> IO a) - -> IO a -renderArgs verbosity version args k = do - createDirectoryIfMissingVerbose verbosity True outputDir - withTempFile outputDir "haddock-prolog.txt" $ \prologFileName h -> do - do - hPutStrLn h $ fromFlag $ argPrologue args - hClose h - let pflag = (:[]).("--prologue="++) $ prologFileName - k $ (pflag ++ renderPureArgs version args, result) - where - isVersion2 = version >= Version [2,0] [] - outputDir = (unDir $ argOutputDir args) - result = intercalate ", " - . map (\o -> outputDir - case o of - Html -> "index.html" - Hoogle -> pkgstr <.> "txt") - $ arg argOutput - where - pkgstr | isVersion2 = display $ packageName pkgid - | otherwise = display pkgid - pkgid = arg argPackageName - arg f = fromFlag $ f args - -renderPureArgs :: Version -> HaddockArgs -> [[Char]] -renderPureArgs version args = concat - [ - (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) f) - . fromFlag . argInterfaceFile $ args, - (\pkgName -> if isVersion2 - then ["--optghc=-package-name", "--optghc=" ++ pkgName] - else ["--package=" ++ pkgName]) . 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, - 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, - bool id (const []) isVersion2 . map ("--optghc=" ++) . argGhcFlags $ args, - maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and 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] [] - verbosityFlag - | isVersion2_5 = "--verbosity=1" - | otherwise = "--verbose" - ------------------------------------------------------------------------------------------------------------ - -haddockPackageFlags :: LocalBuildInfo - -> Maybe PathTemplate - -> IO ([(FilePath,Maybe FilePath)], Maybe String) -haddockPackageFlags lbi htmlTemplate = do - let allPkgs = installedPkgs lbi - directDeps = map fst (externalPackageDeps lbi) - transitiveDeps <- case dependencyClosure allPkgs directDeps of - Left x -> return x - Right _ -> die "Can't find transitive deps for haddock" - interfaces <- sequence - [ case interfaceAndHtmlPath ipkg of - Nothing -> return (Left (packageId ipkg)) - Just (interface, html) -> do - exists <- doesFileExist interface - if exists - then return (Right (interface, html)) - else return (Left (packageId ipkg)) - | ipkg <- PackageIndex.allPackages transitiveDeps ] - - 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 ] - - return (flags, if null missing then Nothing else Just warning) - - where - interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (FilePath, FilePath) - interfaceAndHtmlPath pkg = do - interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) - html <- case htmlTemplate of - Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) - Just htmlPathTemplate -> Just (expandTemplateVars htmlPathTemplate) - return (interface, html) - - where expandTemplateVars = fromPathTemplate . substPathTemplate env - env = (PrefixVar, prefix (installDirTemplates lbi)) - : initialPathTemplateEnv (packageId pkg) (compilerId (compiler lbi)) - --- -------------------------------------------------------------------------- --- hscolour support - -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 - where - verbosity = fromFlag (hscolourVerbosity flags) - distPref = fromFlag $ hscolourDistPref flags - -hscolour' :: 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) - - 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 - withComponentsLBI pkg_descr lbi $ \comp _ -> do - pre comp - case comp of - CLib lib -> do - let outputDir = hscolourPref distPref pkg_descr "src" - runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib - CExe exe | fromFlag (hscolourExecutables flags) -> do - let outputDir = hscolourPref distPref pkg_descr exeName exe "src" - runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe - _ -> return () - where - stylesheet = flagToMaybe (hscolourCSS flags) - - verbosity = fromFlag (hscolourVerbosity flags) - - runHsColour prog outputDir moduleFiles = do - createDirectoryIfMissingVerbose verbosity True outputDir - - case stylesheet of -- copy the CSS file - Nothing | programVersion prog >= Just (Version [1,9] []) -> - rawSystemProgram verbosity prog - ["-print-css", "-o" ++ outputDir "hscolour.css"] - | otherwise -> return () - Just s -> copyFileVerbose verbosity s (outputDir "hscolour.css") - - flip mapM_ moduleFiles $ \(m, inFile) -> - rawSystemProgram verbosity prog - ["-css", "-anchor", "-o" ++ outFile m, inFile] - where - outFile m = outputDir intercalate "-" (ModuleName.components m) <.> "html" - -haddockToHscolour :: HaddockFlags -> HscolourFlags -haddockToHscolour flags = - HscolourFlags { - hscolourCSS = haddockHscolourCss flags, - hscolourExecutables = haddockExecutables flags, - hscolourVerbosity = haddockVerbosity flags, - hscolourDistPref = haddockDistPref flags - } ----------------------------------------------------------------------------------------------- --- TODO these should be moved elsewhere. - -getLibSourceFiles :: LocalBuildInfo - -> Library - -> IO [(ModuleName.ModuleName, FilePath)] -getLibSourceFiles lbi lib = getSourceFiles searchpaths modules - where - bi = libBuildInfo lib - modules = PD.exposedModules lib ++ otherModules bi - searchpaths = autogenModulesDir lbi : buildDir lbi : hsSourceDirs bi - -getExeSourceFiles :: LocalBuildInfo - -> Executable - -> IO [(ModuleName.ModuleName, FilePath)] -getExeSourceFiles lbi exe = do - moduleFiles <- getSourceFiles searchpaths modules - srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe) - return ((ModuleName.main, srcMainPath) : moduleFiles) - where - bi = buildInfo exe - modules = otherModules bi - searchpaths = autogenModulesDir lbi : exeBuildDir lbi exe : hsSourceDirs bi - -getSourceFiles :: [FilePath] - -> [ModuleName.ModuleName] - -> IO [(ModuleName.ModuleName, FilePath)] -getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $ - findFileWithExtension ["hs", "lhs"] dirs (ModuleName.toFilePath m) - >>= maybe (notFound m) (return . normalise) - where - notFound module_ = die $ "can't find source for module " ++ display module_ - --- | The directory where we put build results for an executable -exeBuildDir :: LocalBuildInfo -> Executable -> FilePath -exeBuildDir lbi exe = buildDir lbi exeName exe exeName exe ++ "-tmp" - ---------------------------------------------------------------------------------------------- - - - - --- boilerplate monoid instance. -instance Monoid HaddockArgs where - mempty = HaddockArgs { - argInterfaceFile = mempty, - argPackageName = mempty, - argHideModules = mempty, - argIgnoreExports = mempty, - argLinkSource = mempty, - argCssFile = mempty, - argVerbose = mempty, - argOutput = mempty, - argInterfaces = mempty, - argOutputDir = mempty, - argTitle = mempty, - argPrologue = mempty, - argGhcFlags = mempty, - argGhcLibDir = mempty, - argTargets = mempty - } - mappend a b = HaddockArgs { - argInterfaceFile = mult argInterfaceFile, - argPackageName = mult argPackageName, - argHideModules = mult argHideModules, - argIgnoreExports = mult argIgnoreExports, - argLinkSource = mult argLinkSource, - argCssFile = mult argCssFile, - argVerbose = mult argVerbose, - argOutput = mult argOutput, - argInterfaces = mult argInterfaces, - argOutputDir = mult argOutputDir, - argTitle = mult argTitle, - argPrologue = mult argPrologue, - argGhcFlags = mult argGhcFlags, - argGhcLibDir = mult argGhcLibDir, - argTargets = mult argTargets - } - where mult f = f a `mappend` f b - -instance Monoid Directory where - mempty = Dir "." - mappend (Dir m) (Dir n) = Dir $ m n diff --git a/cabal/cabal/Distribution/Simple/Hpc.hs b/cabal/cabal/Distribution/Simple/Hpc.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Hpc.hs +++ /dev/null @@ -1,185 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Hpc --- Copyright : Thomas Tuegel 2011 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides functions for locating various HPC-related paths and --- 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 - ( hpcDir - , enableCoverage - , tixDir - , tixFilePath - , doHpcMarkup - , findTixFiles - ) where - -import Control.Exception ( bracket ) -import Control.Monad ( unless, when ) -import Distribution.Compiler ( CompilerFlavor(..) ) -import Distribution.ModuleName ( main ) -import Distribution.PackageDescription - ( BuildInfo(..) - , Library(..) - , PackageDescription(..) - , TestSuite(..) - , testModules - ) -import Distribution.Simple.Utils ( die, notice ) -import Distribution.Text -import Distribution.Verbosity ( Verbosity() ) -import System.Directory ( doesFileExist, getDirectoryContents, removeFile ) -import System.Exit ( ExitCode(..) ) -import System.FilePath -import System.IO ( hClose, IOMode(..), openFile, openTempFile ) -import System.Process ( runProcess, waitForProcess ) - --- ------------------------------------------------------------------------- --- 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", hpcDir 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) } - -hpcDir :: FilePath -- ^ \"dist/\" prefix - -> FilePath -- ^ Component subdirectory name - -> FilePath -- ^ Directory containing component's HPC .mix files -hpcDir distPref name = distPref "hpc" name - -tixDir :: FilePath -- ^ \"dist/\" prefix - -> TestSuite -- ^ Test suite - -> FilePath -- ^ Directory containing test suite's .tix files -tixDir distPref suite = distPref "test" testName suite - --- | Path to the .tix file containing a test suite's sum statistics. -tixFilePath :: FilePath -- ^ \"dist/\" prefix - -> TestSuite -- ^ Test suite - -> FilePath -- Path to test suite's .tix file -tixFilePath distPref suite = tixDir distPref suite testName suite <.> "tix" - --- | Returns a list of all the .tix files in a test suite's .tix file --- directory. Returned paths are the complete relative path to each file. -findTixFiles :: FilePath -- ^ \"dist/\" prefix - -> TestSuite -- ^ Test suite - -> IO [FilePath] -- ^ All .tix files belonging to test suite -findTixFiles distPref suite = do - files <- getDirectoryContents $ tixDir distPref suite - let tixFiles = flip filter files $ \x -> takeExtension x == ".tix" - return $ map (tixDir distPref suite ) tixFiles - --- | Generate the HTML markup for a test suite. -doHpcMarkup :: Verbosity - -> FilePath -- ^ \"dist/\" prefix - -> String -- ^ Library name - -> TestSuite - -> IO () -doHpcMarkup verbosity distPref libName suite = do - tixFiles <- findTixFiles distPref suite - when (not $ null tixFiles) $ do - let hpcOptions = map (\x -> "--exclude=" ++ display x) excluded - unionOptions = [ "sum" - , "--union" - , "--output=" ++ tixFilePath distPref suite - ] - ++ hpcOptions ++ tixFiles - markupOptions = [ "markup" - , tixFilePath distPref suite - , "--hpcdir=" ++ hpcDir distPref libName - , "--destdir=" ++ tixDir distPref suite - ] - ++ hpcOptions - excluded = testModules suite ++ [ main ] - --TODO: use standard process utilities from D.S.Utils - runHpc opts h = runProcess "hpc" opts Nothing Nothing Nothing - (Just h) (Just h) - bracket (openHpcTemp $ tixDir distPref suite) deleteIfExists - $ \hpcOut -> do - hUnion <- openFile hpcOut AppendMode - procUnion <- runHpc unionOptions hUnion - exitUnion <- waitForProcess procUnion - success <- case exitUnion of - ExitSuccess -> do - hMarkup <- openFile hpcOut AppendMode - procMarkup <- runHpc markupOptions hMarkup - exitMarkup <- waitForProcess procMarkup - case exitMarkup of - ExitSuccess -> return True - _ -> return False - _ -> return False - unless success $ do - errs <- readFile hpcOut - die $ "HPC failed:\n" ++ errs - when success $ notice verbosity - $ "Test coverage report written to " - ++ tixDir distPref suite "hpc_index" - <.> "html" - return () - where openHpcTemp dir = do - (f, h) <- openTempFile dir $ "cabal-test-hpc-" <.> "log" - hClose h >> return f - deleteIfExists path = do - exists <- doesFileExist path - when exists $ removeFile path diff --git a/cabal/cabal/Distribution/Simple/Hugs.hs b/cabal/cabal/Distribution/Simple/Hugs.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Hugs.hs +++ /dev/null @@ -1,632 +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 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 - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> IO (Compiler, 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 - } - return (comp, conf'') - - where - hugsProgram' = hugsProgram { programFindVersion = getVersion } - -getVersion :: Verbosity -> FilePath -> IO (Maybe Version) -getVersion verbosity hugsPath = do - (output, _err, exit) <- rawSystemStdInOut verbosity hugsPath [] - (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 \\/lib\/hugs\/packages\/\ --- (i.e. \\/lib\/hugs\/packages\/\ on the target system). --- Each executable goes in \\/lib\/hugs\/programs\/\ --- (i.e. \\/lib\/hugs\/programs\/\ on the target system) --- with a script \\/bin\/\ pointing at --- \\/lib\/hugs\/programs\/\. -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 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) diff --git a/cabal/cabal/Distribution/Simple/Install.hs b/cabal/cabal/Distribution/Simple/Install.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Install.hs +++ /dev/null @@ -1,214 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Install --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is the entry point into installing a built package. Performs the --- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into --- 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 - -import Distribution.PackageDescription ( - PackageDescription(..), BuildInfo(..), Library(..), - hasLibs, withLib, hasExes, withExe ) -import Distribution.Package (Package(..)) -import Distribution.Simple.LocalBuildInfo ( - LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs, - substPathTemplate) -import Distribution.Simple.BuildPaths (haddockName, haddockPref) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, installDirectoryContents - , installOrdinaryFile, die, info, notice, matchDirFileGlob ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), compilerFlavor ) -import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..), 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 Control.Monad (when, unless) -import System.Directory - ( doesDirectoryExist, doesFileExist ) -import System.FilePath - ( takeFileName, takeDirectory, (), isAbsolute ) - -import Distribution.Verbosity -import Distribution.Text - ( display ) - --- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" --- actions. Move files into place based on the prefix argument. FIX: --- nhc isn't implemented yet. - -install :: PackageDescription -- ^information from the .cabal file - -> LocalBuildInfo -- ^information from the configure step - -> CopyFlags -- ^flags sent to copy or install - -> IO () -install pkg_descr lbi flags = do - let distPref = fromFlag (copyDistPref flags) - verbosity = fromFlag (copyVerbosity flags) - copydest = fromFlag (copyDest flags) - installDirs@(InstallDirs { - bindir = binPref, - libdir = libPref, --- dynlibdir = dynlibPref, --see TODO below - datadir = dataPref, - progdir = progPref, - docdir = docPref, - htmldir = htmlPref, - haddockdir = interfacePref, - includedir = incPref}) - = absoluteInstallDirs pkg_descr lbi copydest - - --TODO: decide if we need the user to be able to control the libdir - -- for shared libs independently of the one for static libs. If so - -- it should also have a flag in the command line UI - -- For the moment use dynlibdir = libdir - dynlibPref = libPref - progPrefixPref = substPathTemplate (packageId pkg_descr) lbi (progPrefix lbi) - progSuffixPref = substPathTemplate (packageId pkg_descr) lbi (progSuffix lbi) - - docExists <- doesDirectoryExist $ haddockPref distPref pkg_descr - info verbosity ("directory " ++ haddockPref distPref pkg_descr ++ - " does exist: " ++ show docExists) - - installDataFiles verbosity pkg_descr dataPref - - when docExists $ do - createDirectoryIfMissingVerbose verbosity True htmlPref - installDirectoryContents verbosity - (haddockPref distPref pkg_descr) htmlPref - -- setPermissionsRecursive [Read] htmlPref - -- The haddock interface file actually already got installed - -- in the recursive copy, but now we install it where we actually - -- want it to be (normally the same place). We could remove the - -- copy in htmlPref first. - let haddockInterfaceFileSrc = haddockPref distPref pkg_descr - haddockName pkg_descr - haddockInterfaceFileDest = interfacePref haddockName pkg_descr - -- We only generate the haddock interface file for libs, So if the - -- package consists only of executables there will not be one: - exists <- doesFileExist haddockInterfaceFileSrc - when exists $ do - createDirectoryIfMissingVerbose verbosity True interfacePref - installOrdinaryFile verbosity haddockInterfaceFileSrc - haddockInterfaceFileDest - - let lfile = licenseFile pkg_descr - unless (null lfile) $ do - createDirectoryIfMissingVerbose verbosity True docPref - installOrdinaryFile verbosity lfile (docPref takeFileName lfile) - - let buildPref = buildDir lbi - when (hasLibs pkg_descr) $ - notice verbosity ("Installing library in " ++ libPref) - when (hasExes pkg_descr) $ - notice verbosity ("Installing executable(s) in " ++ binPref) - - -- install include files for all compilers - they may be needed to compile - -- haskell files (using the CPP extension) - when (hasLibs pkg_descr) $ installIncludeFiles verbosity pkg_descr incPref - - case compilerFlavor (compiler lbi) of - GHC -> do withLib pkg_descr $ - GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr - withExe pkg_descr $ - GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr - LHC -> do withLib pkg_descr $ - LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr - withExe pkg_descr $ - LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr - JHC -> do withLib pkg_descr $ - 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 withLib pkg_descr $ 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 - _ -> die $ "installing with " - ++ display (compilerFlavor (compiler lbi)) - ++ " is not implemented" - return () - -- register step should be performed by caller. - --- | Install the files listed in data-files --- -installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO () -installDataFiles verbosity pkg_descr destDataDir = - flip mapM_ (dataFiles pkg_descr) $ \ file -> do - let srcDataDir = dataDir pkg_descr - files <- matchDirFileGlob srcDataDir file - let dir = takeDirectory file - createDirectoryIfMissingVerbose verbosity True (destDataDir dir) - sequence_ [ installOrdinaryFile verbosity (srcDataDir file') - (destDataDir file') - | file' <- files ] - --- | Install the files listed in install-includes --- -installIncludeFiles :: Verbosity -> PackageDescription -> FilePath -> IO () -installIncludeFiles verbosity - PackageDescription { library = Just lib } destIncludeDir = do - - incs <- mapM (findInc relincdirs) (installIncludes lbi) - sequence_ - [ do createDirectoryIfMissingVerbose verbosity True destDir - installOrdinaryFile verbosity srcFile destFile - | (relFile, srcFile) <- incs - , let destFile = destIncludeDir relFile - destDir = takeDirectory destFile ] - where - relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) - lbi = libBuildInfo lib - - findInc [] file = die ("can't find include file " ++ file) - findInc (dir:dirs) file = do - let path = dir file - exists <- doesFileExist path - if exists then return (file, path) else findInc dirs file -installIncludeFiles _ _ _ = die "installIncludeFiles: Can't happen?" diff --git a/cabal/cabal/Distribution/Simple/InstallDirs.hs b/cabal/cabal/Distribution/Simple/InstallDirs.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/InstallDirs.hs +++ /dev/null @@ -1,600 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp -fffi #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.InstallDirs --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This manages everything to do with where files get installed (though does --- not get involved with actually doing any installation). It provides an --- 'InstallDirs' type which is a set of directories for where to install --- things. It also handles the fact that we use templates in these install --- dirs. For example most install dirs are relative to some @$prefix@ and by --- changing the prefix all other dirs still end up changed appropriately. So it --- 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, - defaultInstallDirs, - combineInstallDirs, - absoluteInstallDirs, - CopyDest(..), - prefixRelativeInstallDirs, - substituteInstallDirTemplates, - - PathTemplate, - PathTemplateVariable(..), - toPathTemplate, - fromPathTemplate, - substPathTemplate, - initialPathTemplateEnv, - platformTemplateEnv, - compilerTemplateEnv, - packageTemplateEnv, - installDirsTemplateEnv, - ) where - - -import Data.List (isPrefixOf) -import Data.Maybe (fromMaybe) -import Data.Monoid (Monoid(..)) -import System.Directory (getAppUserDataDirectory) -import System.FilePath ((), isPathSeparator, pathSeparator) -#if __HUGS__ || __GLASGOW_HASKELL__ > 606 -import System.FilePath (dropDrive) -#endif - -import Distribution.Package - ( PackageIdentifier, packageName, packageVersion ) -import Distribution.System - ( OS(..), buildOS, Platform(..), buildPlatform ) -import Distribution.Compiler - ( CompilerId, CompilerFlavor(..) ) -import Distribution.Text - ( display ) - -#if mingw32_HOST_OS || mingw32_TARGET_OS -import Foreign -import Foreign.C -#endif - --- --------------------------------------------------------------------------- --- Instalation 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. --- -data InstallDirs dir = InstallDirs { - prefix :: dir, - bindir :: dir, - libdir :: dir, - libsubdir :: dir, - dynlibdir :: dir, - libexecdir :: dir, - progdir :: dir, - includedir :: dir, - datadir :: dir, - datasubdir :: dir, - docdir :: dir, - mandir :: dir, - htmldir :: dir, - haddockdir :: dir - } deriving (Read, Show) - -instance Functor InstallDirs where - fmap f dirs = InstallDirs { - prefix = f (prefix dirs), - bindir = f (bindir dirs), - libdir = f (libdir dirs), - 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), - docdir = f (docdir dirs), - mandir = f (mandir dirs), - htmldir = f (htmldir dirs), - haddockdir = f (haddockdir dirs) - } - -instance Monoid dir => Monoid (InstallDirs dir) where - mempty = InstallDirs { - prefix = mempty, - bindir = mempty, - libdir = mempty, - libsubdir = mempty, - dynlibdir = mempty, - libexecdir = mempty, - progdir = mempty, - includedir = mempty, - datadir = mempty, - datasubdir = mempty, - docdir = mempty, - mandir = mempty, - htmldir = mempty, - haddockdir = mempty - } - mappend = combineInstallDirs mappend - -combineInstallDirs :: (a -> b -> c) - -> InstallDirs a - -> InstallDirs b - -> InstallDirs c -combineInstallDirs combine a b = InstallDirs { - prefix = prefix a `combine` prefix b, - bindir = bindir a `combine` bindir b, - libdir = libdir a `combine` libdir b, - 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, - docdir = docdir a `combine` docdir b, - mandir = mandir a `combine` mandir b, - htmldir = htmldir a `combine` htmldir b, - haddockdir = haddockdir a `combine` haddockdir b - } - -appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a -appendSubdirs append dirs = dirs { - libdir = libdir dirs `append` libsubdir dirs, - datadir = datadir dirs `append` datasubdir dirs, - libsubdir = error "internal error InstallDirs.libsubdir", - datasubdir = error "internal error InstallDirs.datasubdir" - } - --- | The installation directories in terms of 'PathTemplate's that contain --- variables. --- --- The defaults for most of the directories are relative to each other, in --- particular they are all relative to a single prefix. This makes it --- 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'). --- --- 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 --- 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@. --- --- An additional complication is the need to support relocatable packages on --- systems which support such things, like Windows. --- -type InstallDirTemplates = InstallDirs PathTemplate - --- --------------------------------------------------------------------------- --- Default installation directories - -defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates -defaultInstallDirs comp userInstall _hasLibs = do - installPrefix <- - if userInstall - then getAppUserDataDirectory "cabal" - else case buildOS of - Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir - return (windowsProgramFilesDir "Haskell") - _ -> return "/usr/local" - installLibDir <- - case buildOS of - Windows -> return "$prefix" - _ -> case comp of - LHC | userInstall -> getAppUserDataDirectory "lhc" - _ -> return ("$prefix" "lib") - return $ fmap toPathTemplate $ InstallDirs { - prefix = installPrefix, - bindir = "$prefix" "bin", - libdir = installLibDir, - libsubdir = case comp of - Hugs -> "hugs" "packages" "$pkg" - JHC -> "$compiler" - LHC -> "$compiler" - UHC -> "$pkgid" - _other -> "$pkgid" "$compiler", - dynlibdir = "$libdir", - libexecdir = case buildOS of - Windows -> "$prefix" "$pkgid" - _other -> "$prefix" "libexec", - progdir = "$libdir" "hugs" "programs", - includedir = "$libdir" "$libsubdir" "include", - datadir = case buildOS of - Windows -> "$prefix" - _other -> "$prefix" "share", - datasubdir = "$pkgid", - docdir = "$datadir" "doc" "$pkgid", - mandir = "$datadir" "man", - htmldir = "$docdir" "html", - haddockdir = "$htmldir" - } - --- --------------------------------------------------------------------------- --- Converting directories, absolute or prefix-relative - --- | Substitute the install dir templates into each other. --- --- To prevent cyclic substitutions, only some variables are allowed in --- particular dir templates. If out of scope vars are present, they are not --- substituted for. Checking for any remaining unsubstituted vars can be done --- as a subsequent operation. --- --- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we --- can replace 'prefix' with the 'PrefixVar' and get resulting --- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it --- each to check which paths are relative to the $prefix. --- -substituteInstallDirTemplates :: PathTemplateEnv - -> InstallDirTemplates -> InstallDirTemplates -substituteInstallDirTemplates env dirs = dirs' - where - dirs' = InstallDirs { - -- So this specifies exactly which vars are allowed in each template - prefix = subst prefix [], - bindir = subst bindir [prefixVar], - libdir = subst libdir [prefixVar, bindirVar], - 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 [], - docdir = subst docdir prefixBinLibDataVars, - mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]), - htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]), - haddockdir = subst haddockdir (prefixBinLibDataVars ++ - [docdirVar, htmldirVar]) - } - subst dir env' = substPathTemplate (env'++env) (dir dirs) - - prefixVar = (PrefixVar, prefix dirs') - bindirVar = (BindirVar, bindir dirs') - libdirVar = (LibdirVar, libdir dirs') - libsubdirVar = (LibsubdirVar, libsubdir dirs') - datadirVar = (DatadirVar, datadir dirs') - datasubdirVar = (DatasubdirVar, datasubdir dirs') - docdirVar = (DocdirVar, docdir dirs') - htmldirVar = (HtmldirVar, htmldir dirs') - prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar] - prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] - --- | 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 - -> InstallDirs PathTemplate - -> InstallDirs FilePath -absoluteInstallDirs pkgId compilerId copydest dirs = - (case copydest of - CopyTo destdir -> fmap ((destdir ) . dropDrive) - _ -> id) - . appendSubdirs () - . fmap fromPathTemplate - $ substituteInstallDirTemplates env dirs - where - env = initialPathTemplateEnv pkgId compilerId - - --- |The location prefix for the /copy/ command. -data CopyDest - = NoCopyDest - | CopyTo FilePath - deriving (Eq, Show) - --- | Check which of the paths are relative to the installation $prefix. --- --- If any of the paths are not relative, ie they are absolute paths, then it --- prevents us from making a relocatable package (also known as a \"prefix --- independent\" package). --- -prefixRelativeInstallDirs :: PackageIdentifier -> CompilerId - -> InstallDirTemplates - -> InstallDirs (Maybe FilePath) -prefixRelativeInstallDirs pkgId compilerId dirs = - fmap relative - . appendSubdirs combinePathTemplate - $ -- substitute the path template into each other, except that we map - -- \$prefix back to $prefix. We're trying to end up with templates that - -- mention no vars except $prefix. - substituteInstallDirTemplates env dirs { - prefix = PathTemplate [Variable PrefixVar] - } - where - env = initialPathTemplateEnv pkgId compilerId - - -- If it starts with $prefix then it's relative and produce the relative - -- path by stripping off $prefix/ or $prefix - relative dir = case dir of - PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) - relative' (Variable PrefixVar : Ordinary (s:rest) : rest') - | isPathSeparator s = Just (Ordinary rest : rest') - relative' (Variable PrefixVar : rest) = Just rest - relative' _ = Nothing - --- --------------------------------------------------------------------------- --- Path templates - --- | An abstract path, posibly containing variables that need to be --- substituted for to get a real 'FilePath'. --- -newtype PathTemplate = PathTemplate [PathComponent] - -data PathComponent = - Ordinary FilePath - | Variable PathTemplateVariable - deriving Eq - -data PathTemplateVariable = - PrefixVar -- ^ The @$prefix@ path variable - | BindirVar -- ^ The @$bindir@ path variable - | LibdirVar -- ^ The @$libdir@ path variable - | LibsubdirVar -- ^ The @$libsubdir@ path variable - | DatadirVar -- ^ The @$datadir@ path variable - | DatasubdirVar -- ^ The @$datasubdir@ path variable - | DocdirVar -- ^ The @$docdir@ path variable - | HtmldirVar -- ^ The @$htmldir@ path variable - | 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@ - | 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@ - | 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@. - deriving Eq - -type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] - --- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. --- -toPathTemplate :: FilePath -> PathTemplate -toPathTemplate = PathTemplate . read - --- | Convert back to a path, any remaining vars are included --- -fromPathTemplate :: PathTemplate -> FilePath -fromPathTemplate (PathTemplate template) = show template - -combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate -combinePathTemplate (PathTemplate t1) (PathTemplate t2) = - PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2) - -substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate -substPathTemplate environment (PathTemplate template) = - PathTemplate (concatMap subst template) - - where subst component@(Ordinary _) = [component] - subst component@(Variable variable) = - case lookup variable environment of - Just (PathTemplate components) -> components - Nothing -> [component] - --- | The initial environment has all the static stuff but no paths -initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> PathTemplateEnv -initialPathTemplateEnv pkgId compilerId = - packageTemplateEnv pkgId - ++ compilerTemplateEnv compilerId - ++ platformTemplateEnv buildPlatform -- platform should be param if we want - -- to do cross-platform configuation - -packageTemplateEnv :: PackageIdentifier -> PathTemplateEnv -packageTemplateEnv pkgId = - [(PkgNameVar, PathTemplate [Ordinary $ display (packageName pkgId)]) - ,(PkgVerVar, PathTemplate [Ordinary $ display (packageVersion pkgId)]) - ,(PkgIdVar, PathTemplate [Ordinary $ display pkgId]) - ] - -compilerTemplateEnv :: CompilerId -> PathTemplateEnv -compilerTemplateEnv compilerId = - [(CompilerVar, PathTemplate [Ordinary $ display compilerId]) - ] - -platformTemplateEnv :: Platform -> PathTemplateEnv -platformTemplateEnv (Platform arch os) = - [(OSVar, PathTemplate [Ordinary $ display os]) - ,(ArchVar, PathTemplate [Ordinary $ display arch]) - ] - -installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv -installDirsTemplateEnv dirs = - [(PrefixVar, prefix dirs) - ,(BindirVar, bindir dirs) - ,(LibdirVar, libdir dirs) - ,(LibsubdirVar, libsubdir dirs) - ,(DatadirVar, datadir dirs) - ,(DatasubdirVar, datasubdir dirs) - ,(DocdirVar, docdir dirs) - ,(HtmldirVar, htmldir dirs) - ] - - --- --------------------------------------------------------------------------- --- Parsing and showing path templates: - --- The textual format is that of an ordinary Haskell String, eg --- "$prefix/bin" --- and this gets parsed to the internal representation as a sequence of path --- spans which are either strings or variables, eg: --- PathTemplate [Variable PrefixVar, Ordinary "/bin" ] - -instance Show PathTemplateVariable where - show PrefixVar = "prefix" - show BindirVar = "bindir" - show LibdirVar = "libdir" - show LibsubdirVar = "libsubdir" - show DatadirVar = "datadir" - show DatasubdirVar = "datasubdir" - show DocdirVar = "docdir" - show HtmldirVar = "htmldir" - show PkgNameVar = "pkg" - show PkgVerVar = "version" - show PkgIdVar = "pkgid" - show CompilerVar = "compiler" - show OSVar = "os" - show ArchVar = "arch" - show ExecutableNameVar = "executablename" - show TestSuiteNameVar = "test-suite" - show TestSuiteResultVar = "result" - -instance Read PathTemplateVariable where - readsPrec _ s = - take 1 - [ (var, drop (length varStr) s) - | (varStr, var) <- vars - , varStr `isPrefixOf` s ] - where vars = [("prefix", PrefixVar) - ,("bindir", BindirVar) - ,("libdir", LibdirVar) - ,("libsubdir", LibsubdirVar) - ,("datadir", DatadirVar) - ,("datasubdir", DatasubdirVar) - ,("docdir", DocdirVar) - ,("htmldir", HtmldirVar) - ,("pkgid", PkgIdVar) - ,("pkg", PkgNameVar) - ,("version", PkgVerVar) - ,("compiler", CompilerVar) - ,("os", OSVar) - ,("arch", ArchVar) - ,("executablename", ExecutableNameVar) - ,("test-suite", TestSuiteNameVar) - ,("result", TestSuiteResultVar)] - -instance Show PathComponent where - show (Ordinary path) = path - show (Variable var) = '$':show var - showList = foldr (\x -> (shows x .)) id - -instance Read PathComponent where - -- for some reason we colapse multiple $ symbols here - readsPrec _ = lex0 - where lex0 [] = [] - lex0 ('$':'$':s') = lex0 ('$':s') - lex0 ('$':s') = case [ (Variable var, s'') - | (var, s'') <- reads s' ] of - [] -> lex1 "$" s' - ok -> ok - lex0 s' = lex1 [] s' - lex1 "" "" = [] - lex1 acc "" = [(Ordinary (reverse acc), "")] - lex1 acc ('$':'$':s) = lex1 acc ('$':s) - lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)] - lex1 acc (c:s) = lex1 (c:acc) s - readList [] = [([],"")] - readList s = [ (component:components, s'') - | (component, s') <- reads s - , (components, s'') <- readList s' ] - -instance Show PathTemplate where - show (PathTemplate template) = show (show template) - -instance Read PathTemplate where - readsPrec p s = [ (PathTemplate template, s') - | (path, s') <- readsPrec p s - , (template, "") <- reads path ] - --- --------------------------------------------------------------------------- --- Internal utilities - -getWindowsProgramFilesDir :: IO FilePath -getWindowsProgramFilesDir = do -#if mingw32_HOST_OS || mingw32_TARGET_OS - m <- shGetFolderPath csidl_PROGRAM_FILES -#else - let m = Nothing -#endif - return (fromMaybe "C:\\Program Files" m) - -#if mingw32_HOST_OS || mingw32_TARGET_OS -shGetFolderPath :: CInt -> IO (Maybe FilePath) -shGetFolderPath n = -# if __HUGS__ - return Nothing -# else - allocaArray long_path_size $ \pPath -> do - r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath - if (r /= 0) - then return Nothing - else do s <- peekCWString pPath; return (Just s) - where - long_path_size = 1024 -- MAX_PATH is 260, this should be plenty -# endif - -csidl_PROGRAM_FILES :: CInt -csidl_PROGRAM_FILES = 0x0026 --- csidl_PROGRAM_FILES_COMMON :: CInt --- csidl_PROGRAM_FILES_COMMON = 0x002b - -foreign import stdcall unsafe "shlobj.h SHGetFolderPathW" - c_SHGetFolderPath :: Ptr () - -> CInt - -> Ptr () - -> CInt - -> CWString - -> IO CInt -#endif - -#if !(__HUGS__ || __GLASGOW_HASKELL__ > 606) --- Compat: this function only appears in FilePath > 1.0 --- (which at the time of writing is unreleased) -dropDrive :: FilePath -> FilePath -dropDrive (c:cs) | isPathSeparator c = cs -dropDrive (_:':':c:cs) | isWindows - && isPathSeparator c = cs -- path with drive letter -dropDrive (_:':':cs) | isWindows = cs -dropDrive cs = cs - -isWindows :: Bool -isWindows = case buildOS of - Windows -> True - _ -> False -#endif diff --git a/cabal/cabal/Distribution/Simple/JHC.hs b/cabal/cabal/Distribution/Simple/JHC.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/JHC.hs +++ /dev/null @@ -1,221 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.JHC --- Copyright : Isaac Jones 2003-2006 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- 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, - installLib, installExe - ) where - -import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), Executable(..) - , Library(..), libModules, hcOptions, usedExtensions ) -import Distribution.InstalledPackageInfo - ( emptyInstalledPackageInfo, ) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.Simple.PackageIndex (PackageIndex) -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(..) - , PackageDBStack, Flag, languageToFlags, extensionsToFlags ) -import Language.Haskell.Extension - ( Language(Haskell98), Extension(..), KnownExtension(..)) -import Distribution.Simple.Program - ( ConfiguredProgram(..), jhcProgram, ProgramConfiguration - , userMaybeSpecifyPath, requireProgramVersion, lookupProgram - , rawSystemProgram, rawSystemProgramStdoutConf ) -import Distribution.Version - ( Version(..), orLaterVersion ) -import Distribution.Package - ( Package(..), InstalledPackageId(InstalledPackageId), - pkgName, pkgVersion, ) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, writeFileAtomic - , installOrdinaryFile, installExecutableFile - , intercalate ) -import System.FilePath ( () ) -import Distribution.Verbosity -import Distribution.Text - ( Text(parse), display ) -import Distribution.Compat.ReadP - ( readP_to_S, string, skipSpaces ) - -import Data.List ( nub ) -import Data.Char ( isSpace ) -import Data.Maybe ( fromMaybe ) - - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) -configure verbosity hcPath _hcPkgPath conf = do - - (jhcProg, _, conf') <- requireProgramVersion verbosity - jhcProgram (orLaterVersion (Version [0,7,2] [])) - (userMaybeSpecifyPath "jhc" hcPath conf) - - let Just version = programVersion jhcProg - comp = Compiler { - compilerId = CompilerId JHC version, - compilerLanguages = jhcLanguages, - compilerExtensions = jhcLanguageExtensions - } - return (comp, conf') - -jhcLanguages :: [(Language, Flag)] -jhcLanguages = [(Haskell98, "")] - --- | The flags for the supported extensions -jhcLanguageExtensions :: [(Extension, Flag)] -jhcLanguageExtensions = - [(EnableExtension TypeSynonymInstances , "") - ,(DisableExtension TypeSynonymInstances , "") - ,(EnableExtension ForeignFunctionInterface , "") - ,(DisableExtension ForeignFunctionInterface , "") - ,(EnableExtension ImplicitPrelude , "") -- Wrong - ,(DisableExtension ImplicitPrelude , "--noprelude") - ,(EnableExtension CPP , "-fcpp") - ,(DisableExtension CPP , "-fno-cpp") - ] - -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration - -> IO PackageIndex -getInstalledPackages verbosity _packageDBs conf = do - -- jhc --list-libraries lists all available libraries. - -- How shall I find out, whether they are global or local - -- without checking all files and locations? - str <- rawSystemProgramStdoutConf verbosity jhcProgram conf ["--list-libraries"] - let pCheck :: [(a, String)] -> [a] - pCheck rs = [ r | (r,s) <- rs, all isSpace s ] - let parseLine ln = - pCheck (readP_to_S - (skipSpaces >> string "Name:" >> skipSpaces >> parse) ln) - return $ - PackageIndex.fromList $ - map (\p -> emptyInstalledPackageInfo { - InstalledPackageInfo.installedPackageId = - InstalledPackageId (display p), - InstalledPackageInfo.sourcePackageId = p - }) $ - concatMap parseLine $ - lines str - --- ----------------------------------------------------------------------------- --- Building - --- | Building a package for JHC. --- Currently C source files are not supported. -buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity pkg_descr lbi lib clbi = do - let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) - let libBi = libBuildInfo lib - let args = constructJHCCmdLine lbi libBi clbi (buildDir lbi) verbosity - let pkgid = display (packageId pkg_descr) - pfile = buildDir lbi "jhc-pkg.conf" - hlfile= buildDir lbi (pkgid ++ ".hl") - writeFileAtomic pfile $ jhcPkgConf pkg_descr - rawSystemProgram verbosity jhcProg $ - ["--build-hl="++pfile, "-o", hlfile] ++ - args ++ map display (libModules lib) - --- | Building an executable for JHC. --- Currently C source files are not supported. -buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe verbosity _pkg_descr lbi exe clbi = do - let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) - let exeBi = buildInfo exe - let out = buildDir lbi exeName exe - let args = constructJHCCmdLine lbi exeBi clbi (buildDir lbi) verbosity - rawSystemProgram verbosity jhcProg (["-o",out] ++ args ++ [modulePath exe]) - -constructJHCCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> Verbosity -> [String] -constructJHCCmdLine lbi bi clbi _odir verbosity = - (if verbosity >= deafening then ["-v"] else []) - ++ hcOptions JHC bi - ++ languageToFlags (compiler lbi) (defaultLanguage bi) - ++ extensionsToFlags (compiler lbi) (usedExtensions bi) - ++ ["--noauto","-i-"] - ++ concat [["-i", l] | l <- nub (hsSourceDirs bi)] - ++ ["-i", autogenModulesDir lbi] - ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] - -- It would be better if JHC would accept package names with versions, - -- but JHC-0.7.2 doesn't accept this. - -- Thus, we have to strip the version with 'pkgName'. - ++ (concat [ ["-p", display (pkgName pkgid)] - | (_, pkgid) <- componentPackageDeps clbi ]) - -jhcPkgConf :: PackageDescription -> String -jhcPkgConf pd = - let sline name sel = name ++ ": "++sel pd - lib = fromMaybe (error "no library available") . library - comma = intercalate "," . map display - in unlines [sline "name" (display . pkgName . packageId) - ,sline "version" (display . pkgVersion . packageId) - ,sline "exposed-modules" (comma . PD.exposedModules . lib) - ,sline "hidden-modules" (comma . otherModules . libBuildInfo . lib) - ] - -installLib :: Verbosity -> FilePath -> FilePath -> PackageDescription -> Library -> IO () -installLib verb dest build_dir pkg_descr _ = do - let p = display (packageId pkg_descr)++".hl" - createDirectoryIfMissingVerbose verb True dest - installOrdinaryFile verb (build_dir p) (dest p) - -installExe :: Verbosity -> FilePath -> FilePath -> (FilePath,FilePath) -> PackageDescription -> Executable -> IO () -installExe verb dest build_dir (progprefix,progsuffix) _ exe = do - let exe_name = exeName exe - src = exe_name exeExtension - out = (progprefix ++ exe_name ++ progsuffix) exeExtension - createDirectoryIfMissingVerbose verb True dest - installExecutableFile verb (build_dir src) (dest out) - diff --git a/cabal/cabal/Distribution/Simple/LHC.hs b/cabal/cabal/Distribution/Simple/LHC.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/LHC.hs +++ /dev/null @@ -1,805 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.LHC --- 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.LHC ( - configure, getInstalledPackages, - buildLib, buildExe, - installLib, installExe, - registerPackage, - ghcOptions, - ghcVerbosityOptions - ) where - -import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), Executable(..) - , Library(..), libModules, hcOptions, usedExtensions, allExtensions ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo - , parseInstalledPackageInfo ) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo_(..) ) -import Distribution.Simple.PackageIndex -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.ParseUtils ( ParseResult(..) ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) -import Distribution.Simple.InstallDirs -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Package - ( PackageIdentifier, Package(..) ) -import qualified Distribution.ModuleName as ModuleName -import Distribution.Simple.Program - ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg - , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf - , rawSystemProgramStdout, rawSystemProgramStdoutConf - , requireProgramVersion - , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram - , arProgram, ranlibProgram, ldProgram - , gccProgram, stripProgram - , lhcProgram, lhcPkgProgram ) -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion - , OptimisationLevel(..), PackageDB(..), PackageDBStack - , Flag, languageToFlags, extensionsToFlags ) -import Distribution.Version - ( Version(..), orLaterVersion ) -import Distribution.System - ( OS(..), buildOS ) -import Distribution.Verbosity -import Distribution.Text - ( display, simpleParse ) -import Language.Haskell.Extension - ( Language(Haskell98), Extension(..), KnownExtension(..) ) - -import Control.Monad ( unless, when ) -import Data.List -import Data.Maybe ( catMaybes ) -import Data.Monoid ( Monoid(..) ) -import System.Directory ( removeFile, renameFile, - getDirectoryContents, doesFileExist, - getTemporaryDirectory ) -import System.FilePath ( (), (<.>), takeExtension, - takeDirectory, replaceExtension ) -import System.IO (hClose, hPutStrLn) -import Distribution.Compat.Exception (catchExit, catchIO) - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) -configure verbosity hcPath hcPkgPath conf = do - - (lhcProg, lhcVersion, conf') <- - requireProgramVersion verbosity lhcProgram - (orLaterVersion (Version [0,7] [])) - (userMaybeSpecifyPath "lhc" hcPath conf) - - (lhcPkgProg, lhcPkgVersion, conf'') <- - requireProgramVersion verbosity lhcPkgProgram - (orLaterVersion (Version [0,7] [])) - (userMaybeSpecifyPath "lhc-pkg" hcPkgPath conf') - - when (lhcVersion /= lhcPkgVersion) $ die $ - "Version mismatch between lhc and lhc-pkg: " - ++ programPath lhcProg ++ " is version " ++ display lhcVersion ++ " " - ++ programPath lhcPkgProg ++ " is version " ++ display lhcPkgVersion - - languages <- getLanguages verbosity lhcProg - extensions <- getExtensions verbosity lhcProg - - let comp = Compiler { - compilerId = CompilerId LHC lhcVersion, - compilerLanguages = languages, - compilerExtensions = extensions - } - conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld - return (comp, conf''') - --- | Adjust the way we find and configure gcc and ld --- -configureToolchain :: ConfiguredProgram -> ProgramConfiguration - -> ProgramConfiguration -configureToolchain lhcProg = - addKnownProgram gccProgram { - programFindLocation = findProg gccProgram (baseDir "gcc.exe"), - programPostConf = configureGcc - } - . addKnownProgram ldProgram { - programFindLocation = findProg ldProgram (libDir "ld.exe"), - programPostConf = configureLd - } - where - compilerDir = takeDirectory (programPath lhcProg) - baseDir = takeDirectory compilerDir - libDir = baseDir "gcc-lib" - includeDir = baseDir "include" "mingw" - isWindows = case buildOS of Windows -> True; _ -> False - - -- on Windows finding and configuring ghc's gcc and ld is a bit special - findProg :: Program -> FilePath -> Verbosity -> IO (Maybe FilePath) - findProg prog location | isWindows = \verbosity -> do - exists <- doesFileExist location - if exists then return (Just location) - else do warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.") - programFindLocation prog verbosity - | otherwise = programFindLocation prog - - configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg] - 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 - -- that means we should add this extra flag to tell ghc's gcc - -- where it lives and thus where gcc can find its various files: - FoundOnSystem {} -> return ["-B" ++ libDir, "-I" ++ includeDir] - UserSpecified {} -> return [] - | otherwise = \_ _ -> return [] - - -- we need to find out if ld supports the -x flag - configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg] - configureLd verbosity ldProg = do - tempDir <- getTemporaryDirectory - ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> - withTempFile tempDir ".o" $ \testofile testohnd -> do - hPutStrLn testchnd "int foo() {}" - hClose testchnd; hClose testohnd - rawSystemProgram verbosity lhcProg ["-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 ["-x"] - else return [] - -getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)] -getLanguages _ _ = return [(Haskell98, "")] ---FIXME: does lhc support -XHaskell98 flag? from what version? - -getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] -getExtensions verbosity lhcProg = do - exts <- rawSystemStdout verbosity (programPath lhcProg) - ["--supported-languages"] - -- GHC has the annoying habit of inverting some of the extensions - -- so we have to try parsing ("No" ++ ghcExtensionName) first - let readExtension str = do - ext <- simpleParse ("No" ++ str) - case ext of - UnknownExtension _ -> simpleParse str - _ -> return ext - return $ [ (ext, "-X" ++ display ext) - | Just ext <- map readExtension (lines exts) ] - -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration - -> IO PackageIndex -getInstalledPackages verbosity packagedbs conf = do - checkPackageDbStack packagedbs - pkgss <- getInstalledPackages' verbosity packagedbs conf - let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) - | (_, pkgs) <- pkgss ] - return $! (mconcat indexes) - - where - -- On Windows, various fields have $topdir/foo rather than full - -- paths. We need to substitute the right value in so that when - -- we, for example, call gcc, we have proper paths to give it - Just ghcProg = lookupProgram lhcProgram conf - compilerDir = takeDirectory (programPath ghcProg) - topDir = takeDirectory compilerDir - -checkPackageDbStack :: PackageDBStack -> IO () -checkPackageDbStack (GlobalPackageDB:rest) - | GlobalPackageDB `notElem` rest = return () -checkPackageDbStack _ = - die $ "GHC.getInstalledPackages: the global package db must be " - ++ "specified first and cannot be specified multiple times" - --- | Get the packages from specific PackageDBs, not cumulative. --- -getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration - -> IO [(PackageDB, [InstalledPackageInfo])] -getInstalledPackages' verbosity packagedbs conf - = - sequence - [ do str <- rawSystemProgramStdoutConf verbosity lhcPkgProgram conf - ["dump", packageDbGhcPkgFlag packagedb] - `catchExit` \_ -> die $ "ghc-pkg dump failed" - case parsePackages str of - Left ok -> return (packagedb, ok) - _ -> die "failed to parse output of 'ghc-pkg dump'" - | packagedb <- packagedbs ] - - where - parsePackages str = - let parsed = map parseInstalledPackageInfo (splitPkgs str) - in case [ msg | ParseFailed msg <- parsed ] of - [] -> Left [ pkg | ParseOk _ pkg <- parsed ] - msgs -> Right msgs - - splitPkgs :: String -> [String] - splitPkgs = map unlines . splitWith ("---" ==) . lines - where - splitWith :: (a -> Bool) -> [a] -> [[a]] - splitWith p xs = ys : case zs of - [] -> [] - _:ws -> splitWith p ws - where (ys,zs) = break p xs - - packageDbGhcPkgFlag GlobalPackageDB = "--global" - packageDbGhcPkgFlag UserPackageDB = "--user" - packageDbGhcPkgFlag (SpecificPackageDB path) = "--package-conf=" ++ path - - -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 LHC. --- -buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity pkg_descr lbi lib clbi = do - let pref = buildDir lbi - pkgid = packageId pkg_descr - runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) - ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) - ifProfLib = when (withProfLib lbi) - ifSharedLib = when (withSharedLib lbi) - ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) - - libBi <- hackThreadedFlag verbosity - (compiler lbi) (withProfLib lbi) (libBuildInfo lib) - - let libTargetDir = pref - forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi - -- 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? - let ghcArgs = - ["-package-name", display pkgid ] - ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity - ++ map display (libModules lib) - lhcWrap x = ["--build-library", "--ghc-opts=" ++ unwords x] - ghcArgsProf = ghcArgs - ++ ["-prof", - "-hisuf", "p_hi", - "-osuf", "p_o" - ] - ++ ghcProfOptions libBi - ghcArgsShared = ghcArgs - ++ ["-dynamic", - "-hisuf", "dyn_hi", - "-osuf", "dyn_o", "-fPIC" - ] - ++ ghcSharedOptions libBi - unless (null (libModules lib)) $ - do ifVanillaLib forceVanillaLib (runGhcProg $ lhcWrap ghcArgs) - ifProfLib (runGhcProg $ lhcWrap ghcArgsProf) - ifSharedLib (runGhcProg $ lhcWrap ghcArgsShared) - - -- build any C sources - unless (null (cSources libBi)) $ do - info verbosity "Building C Sources..." - sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref - filename verbosity - createDirectoryIfMissingVerbose verbosity True odir - runGhcProg args - ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"])) - | filename <- cSources libBi] - - -- link: - info verbosity "Linking..." - let cObjs = map (`replaceExtension` objExtension) (cSources libBi) - cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) - vanillaLibFilePath = libTargetDir mkLibName pkgid - profileLibFilePath = libTargetDir mkProfLibName pkgid - sharedLibFilePath = libTargetDir mkSharedLibName pkgid - (compilerId (compiler lbi)) - ghciLibFilePath = libTargetDir mkGHCiLibName pkgid - - stubObjs <- fmap catMaybes $ sequence - [ findFileWithExtension [objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | x <- libModules lib ] - stubProfObjs <- fmap catMaybes $ sequence - [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | x <- libModules lib ] - stubSharedObjs <- fmap catMaybes $ sequence - [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | x <- libModules lib ] - - hObjs <- getHaskellObjects lib lbi - pref objExtension True - hProfObjs <- - if (withProfLib lbi) - then getHaskellObjects lib lbi - pref ("p_" ++ objExtension) True - else return [] - hSharedObjs <- - if (withSharedLib lbi) - then getHaskellObjects lib lbi - pref ("dyn_" ++ objExtension) False - else return [] - - unless (null hObjs && null cObjs && null stubObjs) $ do - -- first remove library files if they exists - sequence_ - [ removeFile libFilePath `catchIO` \_ -> return () - | libFilePath <- [vanillaLibFilePath, profileLibFilePath - ,sharedLibFilePath, ghciLibFilePath] ] - - let arVerbosity | verbosity >= deafening = "v" - | verbosity >= normal = "" - | otherwise = "c" - arArgs = ["q"++ arVerbosity] - ++ [vanillaLibFilePath] - arObjArgs = - hObjs - ++ map (pref ) cObjs - ++ stubObjs - arProfArgs = ["q"++ arVerbosity] - ++ [profileLibFilePath] - arProfObjArgs = - hProfObjs - ++ map (pref ) cObjs - ++ stubProfObjs - ldArgs = ["-r"] - ++ ["-o", ghciLibFilePath <.> "tmp"] - ldObjArgs = - hObjs - ++ map (pref ) cObjs - ++ stubObjs - ghcSharedObjArgs = - hSharedObjs - ++ map (pref ) 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 = - [ "-no-auto-link-packages", - "-shared", - "-dynamic", - "-o", sharedLibFilePath ] - ++ ghcSharedObjArgs - ++ ["-package-name", display pkgid ] - ++ ghcPackageFlags lbi clbi - ++ ["-l"++extraLib | extraLib <- extraLibs libBi] - ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi] - - runLd ldLibName args = do - exists <- doesFileExist ldLibName - -- This method is called iteratively by xargs. The - -- output goes to .tmp, and any existing file - -- named is included when linking. The - -- output is renamed to . - rawSystemProgramConf verbosity ldProgram (withPrograms lbi) - (args ++ if exists then [ldLibName] else []) - renameFile (ldLibName <.> "tmp") ldLibName - - 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 - maxCommandLineSize = 30 * 1024 - - ifVanillaLib False $ xargs maxCommandLineSize - runAr arArgs arObjArgs - - ifProfLib $ xargs maxCommandLineSize - runAr arProfArgs arProfObjArgs - - ifGHCiLib $ xargs maxCommandLineSize - (runLd ghciLibFilePath) ldArgs ldObjArgs - - ifSharedLib $ runGhcProg ghcSharedLinkArgs - - --- | Build an executable with LHC. --- -buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe verbosity _pkg_descr lbi - exe@Executable { exeName = exeName', modulePath = modPath } clbi = do - let pref = buildDir lbi - runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) - - exeBi <- hackThreadedFlag verbosity - (compiler lbi) (withProfExe lbi) (buildInfo exe) - - -- exeNameReal, the name that GHC really uses (with .exe on Windows) - let exeNameReal = exeName' <.> - (if null $ takeExtension exeName' then exeExtension else "") - - let targetDir = pref exeName' - let exeDir = targetDir (exeName' ++ "-tmp") - createDirectoryIfMissingVerbose verbosity True targetDir - createDirectoryIfMissingVerbose verbosity True exeDir - -- TODO: do we need to put hs-boot files into place for mutually recursive modules? - -- FIX: what about exeName.hi-boot? - - -- build executables - unless (null (cSources exeBi)) $ do - info verbosity "Building C Sources." - sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi - exeDir filename verbosity - createDirectoryIfMissingVerbose verbosity True odir - runGhcProg args - | filename <- cSources exeBi] - - srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath - - let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) - let lhcWrap x = ("--ghc-opts\"":x) ++ ["\""] - let binArgs linkExe profExe = - (if linkExe - then ["-o", targetDir exeNameReal] - else ["-c"]) - ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity - ++ [exeDir x | x <- cObjs] - ++ [srcMainFile] - ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi] - ++ ["-l"++lib | lib <- extraLibs exeBi] - ++ ["-L"++libDir | libDir <- extraLibDirs exeBi] - ++ concat [["-framework", f] | f <- PD.frameworks exeBi] - ++ if profExe - then ["-prof", - "-hisuf", "p_hi", - "-osuf", "p_o" - ] ++ ghcProfOptions exeBi - else [] - - -- For building exe's for profiling that use TH we actually - -- have to build twice, once without profiling and the again - -- with profiling. 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. - when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi) - (runGhcProg $ lhcWrap (binArgs False False)) - - runGhcProg (binArgs True (withProfExe lbi)) - --- | 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 ] - --- 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 dirs = [ pref (ModuleName.toFilePath x ++ "_split") - | 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 ] - - -constructGHCCmdLine - :: LocalBuildInfo - -> BuildInfo - -> ComponentLocalBuildInfo - -> FilePath - -> Verbosity - -> [String] -constructGHCCmdLine lbi bi clbi odir verbosity = - ["--make"] - ++ ghcVerbosityOptions verbosity - -- Unsupported extensions have already been checked by configure - ++ ghcOptions lbi bi clbi odir - -ghcVerbosityOptions :: Verbosity -> [String] -ghcVerbosityOptions verbosity - | verbosity >= deafening = ["-v"] - | verbosity >= normal = [] - | otherwise = ["-w", "-v0"] - -ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> [String] -ghcOptions lbi bi clbi odir - = ["-hide-all-packages"] - ++ ghcPackageDbOptions (withPackageDB lbi) - ++ (if splitObjs lbi then ["-split-objs"] else []) - ++ ["-i"] - ++ ["-i" ++ odir] - ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] - ++ ["-i" ++ autogenModulesDir lbi] - ++ ["-I" ++ autogenModulesDir lbi] - ++ ["-I" ++ odir] - ++ ["-I" ++ dir | dir <- PD.includeDirs bi] - ++ ["-optP" ++ opt | opt <- cppOptions bi] - ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] - ++ [ "-#include \"" ++ inc ++ "\"" | inc <- PD.includes bi ] - ++ [ "-odir", odir, "-hidir", odir ] - ++ (if compilerVersion c >= Version [6,8] [] - then ["-stubdir", odir] else []) - ++ ghcPackageFlags lbi clbi - ++ (case withOptimization lbi of - NoOptimisation -> [] - NormalOptimisation -> ["-O"] - MaximumOptimisation -> ["-O2"]) - ++ hcOptions GHC bi - ++ languageToFlags c (defaultLanguage bi) - ++ extensionsToFlags c (usedExtensions bi) - where c = compiler lbi - -ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String] -ghcPackageFlags lbi clbi - | ghcVer >= Version [6,11] [] - = concat [ ["-package-id", display ipkgid] - | (ipkgid, _) <- componentPackageDeps clbi ] - - | otherwise = concat [ ["-package", display pkgid] - | (_, pkgid) <- componentPackageDeps clbi ] - where - ghcVer = compilerVersion (compiler lbi) - -ghcPackageDbOptions :: PackageDBStack -> [String] -ghcPackageDbOptions dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs - (GlobalPackageDB:dbs) -> "-no-user-package-conf" - : concatMap specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = [ "-package-conf", db ] - specific _ = ierror - ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) - -constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath -> Verbosity -> (FilePath,[String]) -constructCcCmdLine lbi bi clbi pref filename verbosity - = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref - | otherwise = pref takeDirectory filename - -- ghc 6.4.1 fixed a bug in -odir handling - -- for C compilations. - in - (odir, - ghcCcOptions lbi bi clbi odir - ++ (if verbosity >= deafening then ["-v"] else []) - ++ ["-c",filename]) - - -ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> [String] -ghcCcOptions lbi bi clbi odir - = ["-I" ++ dir | dir <- PD.includeDirs bi] - ++ ghcPackageDbOptions (withPackageDB lbi) - ++ ghcPackageFlags lbi clbi - ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] - ++ (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-optc-O2"]) - ++ ["-odir", odir] - -mkGHCiLibName :: PackageIdentifier -> String -mkGHCiLibName lib = "HS" ++ display 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) - stripExe verbosity lbi exeFileName (dest <.> exeExtension) - installBinary (binDir fixedExeBaseName) - -stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () -stripExe verbosity lbi name path = when (stripExes lbi) $ - case lookupProgram stripProgram (withPrograms lbi) of - Just strip -> rawSystemProgram verbosity strip args - Nothing -> unless (buildOS == Windows) $ - -- Don't bother warning on windows, we don't expect them to - -- have the strip program anyway. - warn verbosity $ "Unable to strip executable '" ++ name - ++ "' (missing the 'strip' program)" - where - args = path : case buildOS 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. - _ -> [] - --- |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 - -> IO () -installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do - -- copy .hi files over: - let copy src dst n = do - createDirectoryIfMissingVerbose verbosity True dst - installOrdinaryFile verbosity (src n) (dst n) - copyModuleFiles ext = - findModuleFiles [builtDir] [ext] (libModules lib) - >>= installOrdinaryFiles verbosity targetDir - ifVanilla $ copyModuleFiles "hi" - ifProf $ copyModuleFiles "p_hi" - hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (libModules lib) - flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase srcFile] - - -- copy the built library files over: - ifVanilla $ copy builtDir targetDir vanillaLibName - ifProf $ copy builtDir targetDir profileLibName - ifGHCi $ copy builtDir targetDir ghciLibName - ifShared $ copy builtDir dynlibTargetDir sharedLibName - - -- run ranlib if necessary: - ifVanilla $ updateLibArchive verbosity lbi - (targetDir vanillaLibName) - ifProf $ updateLibArchive verbosity lbi - (targetDir profileLibName) - - where - vanillaLibName = mkLibName pkgid - profileLibName = mkProfLibName pkgid - ghciLibName = mkGHCiLibName pkgid - sharedLibName = mkSharedLibName pkgid (compilerId (compiler lbi)) - - pkgid = packageId pkg - - hasLib = not $ null (libModules lib) - && null (cSources (libBuildInfo lib)) - ifVanilla = when (hasLib && withVanillaLib lbi) - ifProf = when (hasLib && withProfLib lbi) - ifGHCi = when (hasLib && withGHCiLib lbi) - ifShared = when (hasLib && withSharedLib lbi) - - runLhc = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) - --- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems --- like MacOS X. If we can't find those, don't worry too much about it. --- -updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO () -updateLibArchive verbosity lbi path = - case lookupProgram ranlibProgram (withPrograms lbi) of - Just ranlib -> rawSystemProgram verbosity ranlib [path] - Nothing -> case lookupProgram arProgram (withPrograms lbi) of - Just ar -> rawSystemProgram verbosity ar ["-s", path] - Nothing -> warn verbosity $ - "Unable to generate a symbol index for the static " - ++ "library '" ++ path - ++ "' (missing the 'ranlib' and 'ar' programs)" - --- ----------------------------------------------------------------------------- --- Registering - -registerPackage - :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo - -> 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) diff --git a/cabal/cabal/Distribution/Simple/LocalBuildInfo.hs b/cabal/cabal/Distribution/Simple/LocalBuildInfo.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/LocalBuildInfo.hs +++ /dev/null @@ -1,306 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.LocalBuildInfo --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Once a package has been configured we have resolved conditionals and --- dependencies, configured the compiler and other needed external programs. --- The 'LocalBuildInfo' is used to hold all this information. It holds the --- install dirs, the compiler, the exact package dependencies, the configured --- programs, the package database to use and a bunch of miscellaneous configure --- 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, - - -- * Buildable package components - Component(..), - foldComponent, - allComponentsBy, - ComponentName(..), - ComponentLocalBuildInfo(..), - withComponentsLBI, - withLibLBI, - withExeLBI, - withTestLBI, - - -- * Installation directories - module Distribution.Simple.InstallDirs, - absoluteInstallDirs, prefixRelativeInstallDirs, - substPathTemplate - ) where - - -import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, - prefixRelativeInstallDirs, - substPathTemplate, ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Simple.Program (ProgramConfiguration) -import Distribution.PackageDescription - ( PackageDescription(..), withLib, Library(libBuildInfo), withExe - , Executable(exeName, buildInfo), withTest, TestSuite(..) - , BuildInfo(buildable) ) -import Distribution.Package - ( PackageId, Package(..), InstalledPackageId(..) ) -import Distribution.Simple.Compiler - ( Compiler(..), PackageDBStack, OptimisationLevel ) -import Distribution.Simple.PackageIndex - ( PackageIndex ) -import Distribution.Simple.Utils - ( die ) -import Distribution.Simple.Setup - ( ConfigFlags ) -import Distribution.Text - ( display ) - -import Data.List (nub, find) - --- | Data cached after configuration step. See also --- 'Distribution.Simple.Setup.ConfigFlags'. -data LocalBuildInfo = LocalBuildInfo { - configFlags :: ConfigFlags, - -- ^ Options passed to the configuration step. - -- Needed to re-run configuration when .cabal is out of date - extraConfigArgs :: [String], - -- ^ Extra args on the command line for the configuration step. - -- Needed to re-run configuration when .cabal is out of date - installDirTemplates :: InstallDirTemplates, - -- ^ The installation directories for the various differnt - -- kinds of files - --TODO: inplaceDirTemplates :: InstallDirs FilePath - compiler :: Compiler, - -- ^ The compiler we're building with - 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. - libraryConfig :: Maybe ComponentLocalBuildInfo, - executableConfigs :: [(String, ComponentLocalBuildInfo)], - compBuildOrder :: [ComponentName], - -- ^ All the components to build, ordered by topological sort - -- over the intrapackage dependency graph - testSuiteConfigs :: [(String, ComponentLocalBuildInfo)], - installedPkgs :: PackageIndex, - -- ^ All the info about the installed packages that the - -- current package depends on (directly or indirectly). - pkgDescrFile :: Maybe FilePath, - -- ^ the filename containing the .cabal file, if available - localPkgDescr :: PackageDescription, - -- ^ The resolved package description, that does not contain - -- any conditionals. - withPrograms :: ProgramConfiguration, -- ^Location and args for all programs - withPackageDB :: PackageDBStack, -- ^What package database to use, global\/user - withVanillaLib:: Bool, -- ^Whether to build normal libs. - withProfLib :: Bool, -- ^Whether to build profiling versions of libs. - withSharedLib :: Bool, -- ^Whether to build shared versions of libs. - withDynExe :: Bool, -- ^Whether to link executables dynamically - withProfExe :: Bool, -- ^Whether to build executables for profiling. - withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (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 - progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables - progSuffix :: PathTemplate -- ^Suffix to be appended to installed executables - } deriving (Read, Show) - --- | External package dependencies for the package as a whole, the union of the --- individual 'targetPackageDeps'. -externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)] -externalPackageDeps lbi = nub $ - -- TODO: what about non-buildable components? - maybe [] componentPackageDeps (libraryConfig lbi) - ++ concatMap (componentPackageDeps . snd) (executableConfigs lbi) - --- | The installed package Id we use for local packages registered in the local --- package db. This is what is used for intra-package deps between components. --- -inplacePackageId :: PackageId -> InstalledPackageId -inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace") - --- ----------------------------------------------------------------------------- --- Buildable components - -data Component = CLib Library - | CExe Executable - | CTest TestSuite - deriving (Show, Eq, Read) - -data ComponentName = CLibName -- currently only a single lib - | CExeName String - | CTestName String - deriving (Show, Eq, Read) - -data ComponentLocalBuildInfo = ComponentLocalBuildInfo { - -- | Resolved internal and external package dependencies for this component. - -- The 'BuildInfo' specifies a set of build dependencies that must be - -- satisfied in terms of version ranges. This field fixes those dependencies - -- to the specific versions available on this machine for this compiler. - componentPackageDeps :: [(InstalledPackageId, PackageId)] - } - deriving (Read, Show) - -foldComponent :: (Library -> a) - -> (Executable -> a) - -> (TestSuite -> a) - -> Component - -> a -foldComponent f _ _ (CLib lib) = f lib -foldComponent _ f _ (CExe exe) = f exe -foldComponent _ _ f (CTest tst) = f tst - --- | Obtains all components (libs, exes, or test suites), transformed by the --- given function. Useful for gathering dependencies with component context. -allComponentsBy :: PackageDescription - -> (Component -> a) - -> [a] -allComponentsBy pkg_descr f = - [ f (CLib lib) | Just lib <- [library pkg_descr] - , buildable (libBuildInfo lib) ] - ++ [ f (CExe exe) | exe <- executables pkg_descr - , buildable (buildInfo exe) ] - ++ [ f (CTest tst) | tst <- testSuites pkg_descr - , buildable (testBuildInfo tst) - , testEnabled tst ] - --- |If the package description has a library section, call the given --- function with the library build info as argument. Extended version of --- 'withLib' that also gives corresponding build info. -withLibLBI :: PackageDescription -> LocalBuildInfo - -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO () -withLibLBI pkg_descr lbi f = withLib pkg_descr $ \lib -> - case libraryConfig lbi of - Just clbi -> f lib clbi - Nothing -> die missingLibConf - --- | Perform the action on each buildable 'Executable' in the package --- description. Extended version of 'withExe' that also gives corresponding --- build info. -withExeLBI :: PackageDescription -> LocalBuildInfo - -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO () -withExeLBI pkg_descr lbi f = withExe pkg_descr $ \exe -> - case lookup (exeName exe) (executableConfigs lbi) of - Just clbi -> f exe clbi - Nothing -> die (missingExeConf (exeName exe)) - -withTestLBI :: PackageDescription -> LocalBuildInfo - -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO () -withTestLBI pkg_descr lbi f = withTest pkg_descr $ \test -> - case lookup (testName test) (testSuiteConfigs lbi) of - Just clbi -> f test clbi - Nothing -> die (missingTestConf (testName test)) - --- | Perform the action on each buildable 'Library' or 'Executable' (Component) --- in the PackageDescription, subject to the build order specified by the --- 'compBuildOrder' field of the given 'LocalBuildInfo' -withComponentsLBI :: PackageDescription -> LocalBuildInfo - -> (Component -> ComponentLocalBuildInfo -> IO ()) - -> IO () -withComponentsLBI pkg_descr lbi f = mapM_ compF (compBuildOrder lbi) - where - compF CLibName = - case library pkg_descr of - Nothing -> die missinglib - Just lib -> case libraryConfig lbi of - Nothing -> die missingLibConf - Just clbi -> f (CLib lib) clbi - where - missinglib = "internal error: component list includes a library " - ++ "but the package description contains no library" - - compF (CExeName name) = - case find (\exe -> exeName exe == name) (executables pkg_descr) of - Nothing -> die missingexe - Just exe -> case lookup name (executableConfigs lbi) of - Nothing -> die (missingExeConf name) - Just clbi -> f (CExe exe) clbi - where - missingexe = "internal error: component list includes an executable " - ++ name ++ " but the package contains no such executable." - - compF (CTestName name) = - case find (\tst -> testName tst == name) (testSuites pkg_descr) of - Nothing -> die missingtest - Just tst -> case lookup name (testSuiteConfigs lbi) of - Nothing -> die (missingTestConf name) - Just clbi -> f (CTest tst) clbi - where - missingtest = "internal error: component list includes a test suite " - ++ name ++ " but the package contains no such test suite." - -missingLibConf :: String -missingExeConf, missingTestConf :: String -> String - -missingLibConf = "internal error: the package contains a library " - ++ "but there is no corresponding configuration data" -missingExeConf name = "internal error: the package contains an executable " - ++ name ++ " but there is no corresponding configuration data" -missingTestConf name = "internal error: the package contains a test suite " - ++ name ++ " but there is no corresponding configuration data" - - --- ----------------------------------------------------------------------------- --- Wrappers for a couple functions from InstallDirs - --- |See 'InstallDirs.absoluteInstallDirs' -absoluteInstallDirs :: PackageDescription -> LocalBuildInfo -> CopyDest - -> InstallDirs FilePath -absoluteInstallDirs pkg lbi copydest = - InstallDirs.absoluteInstallDirs - (packageId pkg) - (compilerId (compiler lbi)) - copydest - (installDirTemplates lbi) - --- |See 'InstallDirs.prefixRelativeInstallDirs' -prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo - -> InstallDirs (Maybe FilePath) -prefixRelativeInstallDirs pkg_descr lbi = - InstallDirs.prefixRelativeInstallDirs - (packageId pkg_descr) - (compilerId (compiler lbi)) - (installDirTemplates lbi) - -substPathTemplate :: PackageId -> LocalBuildInfo - -> PathTemplate -> FilePath -substPathTemplate pkgid lbi = fromPathTemplate - . ( InstallDirs.substPathTemplate env ) - where env = initialPathTemplateEnv - pkgid - (compilerId (compiler lbi)) diff --git a/cabal/cabal/Distribution/Simple/NHC.hs b/cabal/cabal/Distribution/Simple/NHC.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/NHC.hs +++ /dev/null @@ -1,424 +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(..) - , packageId, 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 Data.Monoid ( Monoid(..) ) -import Control.Monad ( when, unless ) -import Distribution.Compat.Exception - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> IO (Compiler, 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 - } - return (comp, 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 - 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 (packageId pkg_descr) - 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 - -> IO () -installLib verbosity pref buildPref pkgid lib - = do let bi = libBuildInfo lib - modules = exposedModules lib ++ otherModules bi - findModuleFiles [buildPref] ["hi"] modules - >>= installOrdinaryFiles verbosity pref - let libName = mkLibName pkgid - installOrdinaryFile verbosity (buildPref libName) (pref libName) diff --git a/cabal/cabal/Distribution/Simple/PackageIndex.hs b/cabal/cabal/Distribution/Simple/PackageIndex.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/PackageIndex.hs +++ /dev/null @@ -1,562 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.PackageIndex --- Copyright : (c) David Himmelstrup 2005, --- Bjorn Bringert 2007, --- Duncan Coutts 2008-2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- An index of packages. --- -module Distribution.Simple.PackageIndex ( - -- * Package index data type - PackageIndex, - - -- * Creating an index - fromList, - - -- * Updates - merge, - - insert, - - deleteInstalledPackageId, - deleteSourcePackageId, - deletePackageName, --- deleteDependency, - - -- * Queries - - -- ** Precise lookups - lookupInstalledPackageId, - lookupSourcePackageId, - lookupPackageName, - lookupDependency, - - -- ** Case-insensitive searches - searchByName, - SearchResult(..), - searchByNameSubstring, - - -- ** Bulk queries - allPackages, - allPackagesByName, - - -- ** Special queries - brokenPackages, - dependencyClosure, - reverseDependencyClosure, - topologicalOrder, - reverseTopologicalOrder, - dependencyInconsistencies, - dependencyCycles, - dependencyGraph, - 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 Data.List as List - ( null, foldl', sort - , groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy ) -import Data.Monoid (Monoid(..)) -import Data.Maybe (isNothing, fromMaybe) - -import Distribution.Package - ( PackageName(..), PackageId - , Package(..), packageName, packageVersion - , Dependency(Dependency)--, --PackageFixedDeps(..) - , InstalledPackageId(..) ) -import Distribution.ModuleName - ( ModuleName ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, installedPackageId ) -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. --- --- Packages are uniquely identified in by their 'InstalledPackageId', they can --- also be effeciently looked up by package name or by name and version. --- -data PackageIndex = PackageIndex - -- The primary index. Each InstalledPackageInfo record is uniquely identified - -- by its InstalledPackageId. - -- - !(Map InstalledPackageId InstalledPackageInfo) - - -- This auxillary 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. - -- - -- It is a three-level index. The first level is the package name, - -- the second is the package version and the final level is instances - -- of the same package version. These are unique by InstalledPackageId - -- and are kept in preference order. - -- - !(Map PackageName (Map Version [InstalledPackageInfo])) - - deriving (Show, Read) - -instance Monoid PackageIndex 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 (PackageIndex pids pnames) = - map installedPackageId (Map.elems pids) - == sort - [ assert pinstOk (installedPackageId pinst) - | (pname, pvers) <- Map.toList pnames - , let pversOk = not (Map.null pvers) - , (pver, pinsts) <- assert pversOk $ Map.toList pvers - , let pinsts' = sortBy (comparing installedPackageId) pinsts - pinstsOk = all (\g -> length g == 1) - (groupBy (equating installedPackageId) pinsts') - , pinst <- assert pinstsOk $ pinsts' - , let pinstOk = packageName pinst == pname - && packageVersion pinst == pver - ] - - --- --- * Internal helpers --- - -mkPackageIndex :: Map InstalledPackageId InstalledPackageInfo - -> Map PackageName (Map Version [InstalledPackageInfo]) - -> PackageIndex -mkPackageIndex pids pnames = assert (invariant index) index - where index = PackageIndex pids pnames - - --- --- * Construction --- - --- | Build an index out of a bunch of packages. --- --- If there are duplicates by 'InstalledPackageId' then later ones mask earlier --- ones. --- -fromList :: [InstalledPackageInfo] -> PackageIndex -fromList pkgs = mkPackageIndex pids pnames - where - pids = Map.fromList [ (installedPackageId pkg, pkg) | pkg <- pkgs ] - pnames = - Map.fromList - [ (packageName (head pkgsN), pvers) - | pkgsN <- groupBy (equating packageName) - . sortBy (comparing packageId) - $ pkgs - , let pvers = - Map.fromList - [ (packageVersion (head pkgsNV), - nubBy (equating installedPackageId) (reverse pkgsNV)) - | pkgsNV <- groupBy (equating packageVersion) pkgsN - ] - ] - --- --- * Updates --- - --- | Merge two indexes. --- --- Packages from the second mask packages from the first if they have the exact --- same 'InstalledPackageId'. --- --- For packages with the same source 'PackageId', packages from the second are --- \"preferred\" over those from the first. Being preferred means they are top --- 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 (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = - mkPackageIndex (Map.union pids1 pids2) - (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) - where - -- Packages in the second list mask those in the first, however preferred - -- packages go first in the list. - mergeBuckets xs ys = ys ++ (xs \\ ys) - (\\) = deleteFirstsBy (equating installedPackageId) - - --- | Inserts a single package into the index. --- --- This is equivalent to (but slightly quicker than) using 'mappend' or --- 'merge' with a singleton index. --- -insert :: InstalledPackageInfo -> PackageIndex -> PackageIndex -insert pkg (PackageIndex pids pnames) = - mkPackageIndex pids' pnames' - - where - pids' = Map.insert (installedPackageId pkg) pkg pids - pnames' = insertPackageName pnames - insertPackageName = - Map.insertWith' (\_ -> insertPackageVersion) - (packageName pkg) - (Map.singleton (packageVersion pkg) [pkg]) - - insertPackageVersion = - Map.insertWith' (\_ -> insertPackageInstance) - (packageVersion pkg) [pkg] - - insertPackageInstance pkgs = - pkg : deleteBy (equating installedPackageId) pkg pkgs - - --- | Removes a single installed package from the index. --- -deleteInstalledPackageId :: InstalledPackageId -> PackageIndex -> PackageIndex -deleteInstalledPackageId ipkgid original@(PackageIndex pids pnames) = - case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of - (Nothing, _) -> original - (Just spkgid, pids') -> mkPackageIndex pids' - (deletePkgName spkgid pnames) - - where - deletePkgName spkgid = - Map.update (deletePkgVersion spkgid) (packageName spkgid) - - deletePkgVersion spkgid = - (\m -> if Map.null m then Nothing else Just m) - . Map.update deletePkgInstance (packageVersion spkgid) - - deletePkgInstance = - (\xs -> if List.null xs then Nothing else Just xs) - . List.deleteBy (\_ pkg -> installedPackageId pkg == ipkgid) undefined - - --- | Removes all packages with this source 'PackageId' from the index. --- -deleteSourcePackageId :: PackageId -> PackageIndex -> PackageIndex -deleteSourcePackageId pkgid original@(PackageIndex pids pnames) = - case Map.lookup (packageName pkgid) pnames of - Nothing -> original - Just pvers -> case Map.lookup (packageVersion pkgid) pvers of - Nothing -> original - Just pkgs -> mkPackageIndex - (foldl' (flip (Map.delete . installedPackageId)) pids pkgs) - (deletePkgName pnames) - where - deletePkgName = - Map.update deletePkgVersion (packageName pkgid) - - deletePkgVersion = - (\m -> if Map.null m then Nothing else Just m) - . Map.delete (packageVersion pkgid) - - --- | Removes all packages with this (case-sensitive) name from the index. --- -deletePackageName :: PackageName -> PackageIndex -> PackageIndex -deletePackageName name original@(PackageIndex pids pnames) = - case Map.lookup name pnames of - Nothing -> original - Just pvers -> mkPackageIndex - (foldl' (flip (Map.delete . installedPackageId)) pids - (concat (Map.elems pvers))) - (Map.delete name pnames) - -{- --- | Removes all packages satisfying this dependency from the index. --- -deleteDependency :: Dependency -> PackageIndex -> PackageIndex -deleteDependency (Dependency name verstionRange) = - delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange) --} - --- --- * Bulk queries --- - --- | Get all the packages from the index. --- -allPackages :: PackageIndex -> [InstalledPackageInfo] -allPackages (PackageIndex pids _) = Map.elems pids - --- | Get all the packages from the index. --- --- They are grouped by package name, case-sensitively. --- -allPackagesByName :: PackageIndex -> [[InstalledPackageInfo]] -allPackagesByName (PackageIndex _ pnames) = - concatMap Map.elems (Map.elems pnames) - --- --- * Lookups --- - --- | Does a lookup by source package id (name & version). --- --- Since multiple package DBs mask each other by 'InstalledPackageId', --- then we get back at most one package. --- -lookupInstalledPackageId :: PackageIndex -> InstalledPackageId - -> Maybe InstalledPackageInfo -lookupInstalledPackageId (PackageIndex pids _) pid = Map.lookup pid pids - - --- | Does a lookup by source package id (name & version). --- --- There can be multiple installed packages with the same source 'PackageId' --- but different 'InstalledPackageId'. They are returned in order of --- preference, with the most preferred first. --- -lookupSourcePackageId :: PackageIndex -> PackageId -> [InstalledPackageInfo] -lookupSourcePackageId (PackageIndex _ pnames) pkgid = - case Map.lookup (packageName pkgid) pnames of - Nothing -> [] - Just pvers -> case Map.lookup (packageVersion pkgid) pvers of - Nothing -> [] - Just pkgs -> pkgs -- in preference order - - --- | Does a lookup by source package name. --- -lookupPackageName :: PackageIndex -> PackageName - -> [(Version, [InstalledPackageInfo])] -lookupPackageName (PackageIndex _ pnames) name = - case Map.lookup name pnames of - Nothing -> [] - Just pvers -> Map.toList pvers - - --- | Does a lookup by source package name and a range of versions. --- --- We get back any number of versions of the specified package name, all --- satisfying the version range constraint. --- -lookupDependency :: PackageIndex -> Dependency - -> [(Version, [InstalledPackageInfo])] -lookupDependency (PackageIndex _ pnames) (Dependency name versionRange) = - case Map.lookup name pnames of - Nothing -> [] - Just pvers -> [ entry - | entry@(ver, _) <- Map.toList pvers - , ver `withinRange` versionRange ] - --- --- * Case insensitive name lookups --- - --- | Does a case-insensitive search by package name. --- --- If there is only one package that compares case-insentiviely 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 --- unambiguous. --- --- If however several match case-insentiviely 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 _ pnames) name = - case [ pkgs | pkgs@(PackageName name',_) <- Map.toList pnames - , lowercase name' == lname ] of - [] -> None - [(_,pvers)] -> Unambiguous (concat (Map.elems pvers)) - pkgss -> case find ((PackageName name==) . fst) pkgss of - Just (_,pvers) -> Unambiguous (concat (Map.elems pvers)) - Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) - where lname = lowercase name - -data SearchResult a = None | Unambiguous a | Ambiguous [a] - --- | Does a case-insensitive substring search by package name. --- --- That is, all packages that contain the given string in their name. --- -searchByNameSubstring :: PackageIndex -> String -> [InstalledPackageInfo] -searchByNameSubstring (PackageIndex _ pnames) searchterm = - [ pkg - | (PackageName name, pvers) <- Map.toList pnames - , lsearchterm `isInfixOf` lowercase name - , pkgs <- Map.elems pvers - , pkg <- pkgs ] - where lsearchterm = lowercase searchterm - - --- --- * Special queries --- - --- None of the stuff below depends on the internal representation of the index. --- - --- | 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 :: PackageIndex -> [[InstalledPackageInfo]] -dependencyCycles index = - [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] - where - adjacencyList = [ (pkg, installedPackageId pkg, IPI.depends pkg) - | pkg <- allPackages index ] - - --- | All packages that have immediate dependencies that are not in the index. --- --- Returns such packages along with the dependencies that they're missing. --- -brokenPackages :: PackageIndex -> [(InstalledPackageInfo, [InstalledPackageId])] -brokenPackages index = - [ (pkg, missing) - | pkg <- allPackages index - , let missing = [ pkg' | pkg' <- IPI.depends 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 --- 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 'PackageId's do not occur in the index. --- -dependencyClosure :: PackageIndex - -> [InstalledPackageId] - -> Either PackageIndex - [(InstalledPackageInfo, [InstalledPackageId])] -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 lookupInstalledPackageId index pkgid of - Nothing -> closure completed (pkgid:failed) pkgids - Just pkg -> case lookupInstalledPackageId completed (installedPackageId pkg) of - Just _ -> closure completed failed pkgids - Nothing -> closure completed' failed pkgids' - where completed' = insert pkg completed - pkgids' = IPI.depends pkg ++ pkgids - --- | Takes the transitive closure of the packages reverse dependencies. --- --- * The given 'PackageId's must be in the index. --- -reverseDependencyClosure :: PackageIndex - -> [InstalledPackageId] - -> [InstalledPackageInfo] -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 :: PackageIndex -> [InstalledPackageInfo] -topologicalOrder index = map toPkgId - . Graph.topSort - $ graph - where (graph, toPkgId, _) = dependencyGraph index - -reverseTopologicalOrder :: PackageIndex -> [InstalledPackageInfo] -reverseTopologicalOrder index = map toPkgId - . Graph.topSort - . Graph.transposeG - $ graph - where (graph, toPkgId, _) = dependencyGraph 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 :: PackageIndex - -> (Graph.Graph, - Graph.Vertex -> InstalledPackageInfo, - 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) ] - | pkg <- pkgs ] - - pkgs = sortBy (comparing packageId) (allPackages index) - vertices = zip (map installedPackageId pkgs) [0..] - vertex_map = Map.fromList vertices - id_to_vertex pid = Map.lookup pid vertex_map - - vertex_to_pkg vertex = pkgTable ! vertex - - pkgTable = Array.listArray bounds pkgs - topBound = length pkgs - 1 - bounds = (0, topBound) - --- | 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 :: PackageIndex - -> [(PackageName, [(PackageId, Version)])] -dependencyInconsistencies index = - [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids]) - | (name, ipid_map) <- Map.toList inverseIndex - , let uses = Map.elems ipid_map - , reallyIsInconsistent (map fst uses) ] - - where -- for each PackageName, - -- 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 - , Just dep <- [lookupInstalledPackageId index ipid] - ] - - reallyIsInconsistent :: [InstalledPackageInfo] -> Bool - reallyIsInconsistent [] = False - reallyIsInconsistent [_p] = False - reallyIsInconsistent [p1, p2] = - installedPackageId p1 `notElem` IPI.depends p2 - && installedPackageId p2 `notElem` IPI.depends p1 - reallyIsInconsistent _ = True - - -moduleNameIndex :: PackageIndex -> Map ModuleName [InstalledPackageInfo] -moduleNameIndex index = - Map.fromListWith (++) - [ (moduleName, [pkg]) - | pkg <- allPackages index - , moduleName <- IPI.exposedModules pkg ] diff --git a/cabal/cabal/Distribution/Simple/PreProcess.hs b/cabal/cabal/Distribution/Simple/PreProcess.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/PreProcess.hs +++ /dev/null @@ -1,596 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.PreProcess --- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defines a 'PreProcessor' abstraction which represents a pre-processor --- that can transform one kind of file into another. There is also a --- 'PPSuffixHandler' which is a combination of a file extension and a function --- for configuring a 'PreProcessor'. It defines a bunch of known built-in --- preprocessors like @cpp@, @cpphs@, @c2hs@, @hsc2hs@, @happy@, @alex@ etc and --- lists them in 'knownSuffixHandlers'. On top of this it provides a function --- for actually preprocessing some sources given a bunch of known suffix --- 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(..), - mkSimplePreProcessor, runSimplePreProcessor, - ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, - ppHappy, ppAlex, ppUnlit - ) - where - - -import Control.Monad -import Distribution.Simple.PreProcess.Unlit (unlit) -import Distribution.Package - ( Package(..), PackageName(..) ) -import qualified Distribution.ModuleName as ModuleName -import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..) - , Executable(..) - , Library(..), libModules - , TestSuite(..), testModules - , TestSuiteInterface(..) ) -import qualified Distribution.InstalledPackageInfo as Installed - ( InstalledPackageInfo_(..) ) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.Compiler - ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), Component(..) ) -import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File - , die, setupMessage, intercalate, copyFileVerbose - , findFileWithExtension, findFileWithExtension' ) -import Distribution.Simple.Program - ( Program(..), ConfiguredProgram(..), programPath - , lookupProgram, requireProgram, requireProgramVersion - , rawSystemProgramConf, rawSystemProgram - , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram - , happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram ) -import Distribution.Simple.Test ( writeSimpleTestStub, stubFilePath, stubName ) -import Distribution.System - ( OS(OSX, Windows), buildOS ) -import Distribution.Text -import Distribution.Version - ( Version(..), anyVersion, orLaterVersion ) -import Distribution.Verbosity - -import Data.Maybe (fromMaybe) -import Data.List (nub) -import System.Directory (getModificationTime, doesFileExist) -import System.Info (os, arch) -import System.FilePath (splitExtension, dropExtensions, (), (<.>), - takeDirectory, normalise, replaceExtension) - --- |The interface to a preprocessor, which may be implemented using an --- external program, but need not be. The arguments are the name of --- the input file, the name of the output file and a verbosity level. --- Here is a simple example that merely prepends a comment to the given --- source file: --- --- > ppTestHandler :: PreProcessor --- > ppTestHandler = --- > PreProcessor { --- > platformIndependent = True, --- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> --- > do info verbosity (inFile++" has been preprocessed to "++outFile) --- > stuff <- readFile inFile --- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) --- > return ExitSuccess --- --- We split the input and output file names into a base directory and the --- rest of the file name. The input base dir is the path in the list of search --- dirs that this file was found in. The output base dir is the build dir where --- all the generated source files are put. --- --- 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 --- .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 --- 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) --- --- Most pre-processors do not care of course, so mkSimplePreProcessor and --- runSimplePreProcessor functions handle the simple case. --- -data PreProcessor = PreProcessor { - - -- Is the output of the pre-processor platform independent? eg happy output - -- is portable haskell but c2hs's output is platform dependent. - -- This matters since only platform independent generated code can be - -- inlcuded into a source tarball. - platformIndependent :: Bool, - - -- TODO: deal with pre-processors that have implementaion dependent output - -- eg alex and happy have --ghc flags. However we can't really inlcude - -- ghc-specific code into supposedly portable source tarballs. - - runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir - -> (FilePath, FilePath) -- Output file name, relative to an output base dir - -> Verbosity -- verbosity - -> IO () -- Should exit if the preprocessor fails - } - -mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ()) - -> (FilePath, FilePath) - -> (FilePath, FilePath) -> Verbosity -> IO () -mkSimplePreProcessor simplePP - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity - where inFile = normalise (inBaseDir inRelativeFile) - outFile = normalise (outBaseDir outRelativeFile) - -runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity - -> IO () -runSimplePreProcessor pp inFile outFile verbosity = - runPreProcessor pp (".", inFile) (".", outFile) verbosity - --- |A preprocessor for turning non-Haskell files with the given extension --- into plain Haskell source files. -type PPSuffixHandler - = (String, BuildInfo -> LocalBuildInfo -> PreProcessor) - --- | Apply preprocessors to the sources from 'hsSourceDirs' for a given --- component (lib, exe, or test suite). -preprocessComponent :: PackageDescription - -> Component - -> LocalBuildInfo - -> Bool - -> Verbosity - -> [PPSuffixHandler] - -> IO () -preprocessComponent pd comp lbi isSrcDist verbosity handlers = case comp of - (CLib lib@Library{ libBuildInfo = bi }) -> do - let dirs = hsSourceDirs bi ++ [autogenModulesDir lbi] - setupMessage verbosity "Preprocessing library" (packageId pd) - forM_ (map ModuleName.toFilePath $ libModules lib) $ - pre dirs (buildDir lbi) (localHandlers bi) - (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do - let exeDir = buildDir lbi nm nm ++ "-tmp" - dirs = hsSourceDirs bi ++ [autogenModulesDir lbi] - setupMessage verbosity ("Preprocessing executable '" ++ nm ++ "' for") (packageId pd) - forM_ (map ModuleName.toFilePath $ otherModules bi) $ - pre dirs exeDir (localHandlers bi) - pre (hsSourceDirs bi) exeDir (localHandlers bi) $ - dropExtensions (modulePath exe) - CTest test@TestSuite{ testName = nm } -> do - setupMessage verbosity ("Preprocessing test suite '" ++ nm ++ "' for") (packageId pd) - case testInterface test of - TestSuiteExeV10 _ f -> - preProcessTest test f $ buildDir lbi testName test - testName test ++ "-tmp" - TestSuiteLibV09 _ _ -> do - let testDir = buildDir lbi stubName test - stubName test ++ "-tmp" - writeSimpleTestStub test testDir - preProcessTest test (stubFilePath test) testDir - TestSuiteUnsupported tt -> die $ "No support for preprocessing test " - ++ "suite type " ++ display tt - where - builtinSuffixes - | NHC == compilerFlavor (compiler lbi) = ["hs", "lhs", "gc"] - | otherwise = ["hs", "lhs"] - localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] - pre dirs dir lhndlrs fp = - preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs - preProcessTest test exePath testDir = do - let bi = testBuildInfo test - biHandlers = localHandlers bi - sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ] - sequence_ [ preprocessFile sourceDirs (buildDir lbi) isSrcDist - (ModuleName.toFilePath modu) verbosity builtinSuffixes - biHandlers - | modu <- testModules test ] - preprocessFile (testDir : (hsSourceDirs bi)) testDir isSrcDist - (dropExtensions $ exePath) verbosity - builtinSuffixes biHandlers - ---TODO: try to list all the modules that could not be found --- not just the first one. It's annoying and slow due to the need --- to reconfigure after editing the .cabal file each time. - --- |Find the first extension of the file that exists, and preprocess it --- if required. -preprocessFile - :: [FilePath] -- ^source directories - -> FilePath -- ^build directory - -> Bool -- ^preprocess for sdist - -> FilePath -- ^module file name - -> Verbosity -- ^verbosity - -> [String] -- ^builtin suffixes - -> [(String, PreProcessor)] -- ^possible preprocessors - -> IO () -preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers = do - -- look for files in the various source dirs with this module name - -- and a file extension of a known preprocessor - psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc baseFile - case psrcFiles of - -- no preprocessor file exists, look for an ordinary source file - -- just to make sure one actually exists at all for this module. - -- Note: by looking in the target/output build dir too, we allow - -- source files to appear magically in the target build dir without - -- any corresponding "real" source file. This lets custom Setup.hs - -- files generate source modules directly into the build dir without - -- the rest of the build system being aware of it (somewhat dodgy) - Nothing -> do - bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : searchLoc) baseFile - case bsrcFiles of - Nothing -> die $ "can't find source for " ++ baseFile - ++ " in " ++ intercalate ", " searchLoc - _ -> return () - -- found a pre-processable file in one of the source dirs - Just (psrcLoc, psrcRelFile) -> do - let (srcStem, ext) = splitExtension psrcRelFile - psrcFile = psrcLoc psrcRelFile - pp = fromMaybe (error "Internal error in preProcess module: Just expected") - (lookup (tailNotNull ext) handlers) - -- Preprocessing files for 'sdist' is different from preprocessing - -- for 'build'. When preprocessing for sdist we preprocess to - -- avoid that the user has to have the preprocessors available. - -- ATM, we don't have a way to specify which files are to be - -- preprocessed and which not, so for sdist we only process - -- platform independent files and put them into the 'buildLoc' - -- (which we assume is set to the temp. directory that will become - -- the tarball). - --TODO: eliminate sdist variant, just supply different handlers - when (not forSDist || forSDist && platformIndependent pp) $ do - -- look for existing pre-processed source file in the dest dir to - -- see if we really have to re-run the preprocessor. - ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile - recomp <- case ppsrcFiles of - Nothing -> return True - Just ppsrcFile -> do - btime <- getModificationTime ppsrcFile - ptime <- getModificationTime psrcFile - return (btime < ptime) - when recomp $ do - let destDir = buildLoc dirName srcStem - createDirectoryIfMissingVerbose verbosity True destDir - runPreProcessorWithHsBootHack pp - (psrcLoc, psrcRelFile) - (buildLoc, srcStem <.> "hs") - - where - dirName = takeDirectory - tailNotNull [] = [] - tailNotNull x = tail x - - -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files - -- be in the same place as the hs files, so if we put the hs file in dist/ - -- then we need to copy the hs-boot file there too. This should probably be - -- done another way. Possibly we should also be looking for .lhs-boot - -- files, but I think that preprocessors only produce .hs files. - runPreProcessorWithHsBootHack pp - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) = do - runPreProcessor pp - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity - - exists <- doesFileExist inBoot - when exists $ copyFileVerbose verbosity inBoot outBoot - - where - inBoot = replaceExtension inFile "hs-boot" - outBoot = replaceExtension outFile "hs-boot" - - inFile = normalise (inBaseDir inRelativeFile) - outFile = normalise (outBaseDir outRelativeFile) - --- ------------------------------------------------------------ --- * known preprocessors --- ------------------------------------------------------------ - -ppGreenCard :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppGreenCard _ lbi - = PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - rawSystemProgramConf verbosity greencardProgram (withPrograms lbi) - (["-tffi", "-o" ++ outFile, inFile]) - } - --- This one is useful for preprocessors that can't handle literate source. --- We also need a way to chain preprocessors. -ppUnlit :: PreProcessor -ppUnlit = - PreProcessor { - platformIndependent = True, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> - withUTF8FileContents inFile $ \contents -> - either (writeUTF8File outFile) die (unlit inFile contents) - } - -ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppCpp = ppCpp' [] - -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 - - where cppArgs = getCppOptions bi lbi - -ppGhcCpp :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor -ppGhcCpp extraArgs _bi lbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (ghcProg, ghcVersion, _) <- requireProgramVersion verbosity - ghcProgram anyVersion (withPrograms lbi) - rawSystemProgram verbosity ghcProg $ - ["-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 []) - ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] - ++ ["-o", outFile, inFile] - ++ extraArgs - } - -ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor -ppCpphs extraArgs _bi lbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity - cpphsProgram anyVersion (withPrograms lbi) - rawSystemProgram verbosity cpphsProg $ - ("-O" ++ outFile) : inFile - : "--noline" : "--strip" - : (if cpphsVersion >= Version [1,6] [] - then ["--include="++ (autogenModulesDir lbi cppHeaderName)] - else []) - ++ 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 { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) - rawSystemProgramConf verbosity hsc2hsProgram (withPrograms lbi) $ - [ "--cc=" ++ programPath gccProg - , "--ld=" ++ programPath gccProg ] - - -- Additional gcc options - ++ [ "--cflag=" ++ opt | opt <- programDefaultArgs gccProg - ++ programOverrideArgs gccProg ] - ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs gccProg - ++ programOverrideArgs gccProg ] - - -- OSX frameworks: - ++ [ what ++ "=-F" ++ opt - | isOSX - , opt <- nub (concatMap Installed.frameworkDirs pkgs) - , what <- ["--cflag", "--lflag"] ] - ++ [ "--lflag=" ++ arg - | isOSX - , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs - , arg <- ["-framework", opt] ] - - -- Note that on ELF systems, wherever we use -L, we must also use -R - -- because presumably that -L dir is not on the normal path for the - -- system's dynamic linker. This is needed because hsc2hs works by - -- compiling a C program and then running it. - - ++ [ "--cflag=" ++ opt | opt <- hcDefines (compiler lbi) ] - ++ [ "--cflag=" ++ opt | opt <- sysDefines ] - - -- Options from the current package: - ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ] - ++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi - ++ PD.cppOptions bi ] - ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ] - ++ [ "--lflag=-Wl,-R," ++ opt | isELF - , opt <- PD.extraLibDirs bi ] - ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs bi ] - ++ [ "--lflag=" ++ opt | opt <- PD.ldOptions bi ] - - -- Options from dependent packages - ++ [ "--cflag=" ++ opt - | pkg <- pkgs - , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] - ++ [ opt | opt <- Installed.ccOptions pkg ] - ++ [ "-I" ++ autogenModulesDir lbi, - "-include", autogenModulesDir lbi cppHeaderName ] ] - ++ [ "--lflag=" ++ opt - | pkg <- pkgs - , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] - ++ [ "-Wl,-R," ++ opt | isELF - , opt <- Installed.libraryDirs pkg ] - ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ] - ++ [ opt | opt <- Installed.ldOptions pkg ] ] - ++ ["-o", outFile, inFile] - } - where - pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi)) - 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 - -- 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 - -- ldOptions for GHC's rts package: - hackRtsPackage index = - case PackageIndex.lookupPackageName index (PackageName "rts") of - [(_, [rts])] - -> PackageIndex.insert rts { Installed.ldOptions = [] } index - _ -> error "No (or multiple) ghc rts package is registered!!" - - -ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppC2hs bi lbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = \(inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity -> do - (c2hsProg, _, _) <- requireProgramVersion verbosity - c2hsProgram (orLaterVersion (Version [0,15] [])) - (withPrograms lbi) - (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) - rawSystemProgram verbosity c2hsProg $ - - -- Options from the current package: - [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] - ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ] - ++ [ "--include=" ++ outBaseDir ] - - -- Options from dependent packages - ++ [ "--cppopts=" ++ opt - | pkg <- pkgs - , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] - ++ [ opt | opt@('-':c:_) <- Installed.ccOptions pkg - , c `elem` "DIU" ] ] - --TODO: install .chi files for packages, so we can --include - -- those dirs here, for the dependencies - - -- input and output files - ++ [ "--output-dir=" ++ outBaseDir - , "--output=" ++ outRelativeFile - , inBaseDir inRelativeFile ] - } - where - pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) - ---TODO: perhaps use this with hsc2hs too ---TODO: remove cc-options from cpphs for cabal-version: >= 1.10 -getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] -getCppOptions bi lbi - = hcDefines (compiler lbi) - ++ sysDefines - ++ cppOptions bi - ++ ["-I" ++ dir | dir <- PD.includeDirs bi] - ++ [opt | opt@('-':c:_) <- PD.ccOptions bi, c `elem` "DIU"] - -sysDefines :: [String] -sysDefines = ["-D" ++ os ++ "_" ++ loc ++ "_OS" | loc <- locations] - ++ ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations] - where - locations = ["BUILD", "HOST"] - -hcDefines :: Compiler -> [String] -hcDefines comp = - case compilerFlavor comp of - GHC -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version] - JHC -> ["-D__JHC__=" ++ versionInt version] - NHC -> ["-D__NHC__=" ++ versionInt version] - Hugs -> ["-D__HUGS__"] - _ -> [] - where version = compilerVersion 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. -versionInt :: Version -> String -versionInt (Version { versionBranch = [] }) = "1" -versionInt (Version { versionBranch = [n] }) = show n -versionInt (Version { versionBranch = n1:n2:_ }) - = -- 6.8.x -> 608 - -- 6.10.x -> 610 - let s1 = show n1 - s2 = show n2 - middle = case s2 of - _ : _ : _ -> "" - _ -> "0" - in s1 ++ middle ++ s2 - -ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppHappy _ lbi = pp { platformIndependent = True } - where pp = standardPP lbi happyProgram (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-agc"] - hcFlags _ = [] - -ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppAlex _ lbi = pp { platformIndependent = True } - where pp = standardPP lbi alexProgram (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-g"] - hcFlags _ = [] - -standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor -standardPP lbi prog args = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - rawSystemProgramConf verbosity prog (withPrograms lbi) - (args ++ ["-o", outFile, inFile]) - } - --- |Convenience function; get the suffixes of these preprocessors. -ppSuffixes :: [ PPSuffixHandler ] -> [String] -ppSuffixes = map fst - --- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. -knownSuffixHandlers :: [ PPSuffixHandler ] -knownSuffixHandlers = - [ ("gc", ppGreenCard) - , ("chs", ppC2hs) - , ("hsc", ppHsc2hs) - , ("x", ppAlex) - , ("y", ppHappy) - , ("ly", ppHappy) - , ("cpphs", ppCpp) - ] diff --git a/cabal/cabal/Distribution/Simple/PreProcess/Unlit.hs b/cabal/cabal/Distribution/Simple/PreProcess/Unlit.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/PreProcess/Unlit.hs +++ /dev/null @@ -1,165 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.PreProcess.Unlit --- Copyright : ... --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Remove the \"literal\" markups from a Haskell source file, including --- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\" - --- This version is interesting because instead of striping comment lines, it --- turns them into "-- " style comments. This allows using haddock markup --- in literate scripts without having to use "> --" prefix. - -module Distribution.Simple.PreProcess.Unlit (unlit,plain) where - -import Data.Char -import Data.List - -data Classified = BirdTrack String | Blank String | Ordinary String - | Line !Int String | CPP String - | BeginCode | EndCode - -- output only: - | Error String | Comment String - --- | No unliteration. -plain :: String -> String -> String -plain _ hs = hs - -classify :: String -> Classified -classify ('>':s) = BirdTrack s -classify ('#':s) = case tokens s of - (line:file:_) | all isDigit line - && length file >= 2 - && head file == '"' - && last file == '"' - -> Line (read line) (tail (init file)) - _ -> CPP s - where tokens = unfoldr $ \str -> case lex str of - (t@(_:_), str'):_ -> Just (t, str') - _ -> Nothing -classify ('\\':s) - | "begin{code}" `isPrefixOf` s = BeginCode - | "end{code}" `isPrefixOf` s = EndCode -classify s | all isSpace s = Blank s -classify s = Ordinary s - --- So the weird exception for comment indenting is to make things work with --- haddock, see classifyAndCheckForBirdTracks below. -unclassify :: Bool -> Classified -> String -unclassify _ (BirdTrack s) = ' ':s -unclassify _ (Blank s) = s -unclassify _ (Ordinary s) = s -unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file -unclassify _ (CPP s) = '#':s -unclassify True (Comment "") = " --" -unclassify True (Comment s) = " -- " ++ s -unclassify False (Comment "") = "--" -unclassify False (Comment s) = "-- " ++ s -unclassify _ _ = internalError - --- | 'unlit' takes a filename (for error reports), and transforms the --- given string, to eliminate the literate comments from the program text. -unlit :: FilePath -> String -> Either String String -unlit file input = - let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks - . inlines - $ input - in either (Left . unlines . map (unclassify usesBirdTracks)) - Right - . checkErrors - . reclassify - $ classified - - where - -- So haddock requires comments and code to align, since it treats comments - -- as following the layout rule. This is a pain for us since bird track - -- style literate code typically gets indented by two since ">" is replaced - -- by " " and people usually use one additional space of indent ie - -- "> then the code". On the other hand we cannot just go and indent all - -- the comments by two since that does not work for latex style literate - -- code. So the hacky solution we use here is that if we see any bird track - -- style code then we'll indent all comments by two, otherwise by none. - -- Of course this will not work for mixed latex/bird track .lhs files but - -- nobody does that, it's silly and specifically recommended against in the - -- H98 unlit spec. - -- - classifyAndCheckForBirdTracks = - flip mapAccumL False $ \seenBirdTrack line -> - let classification = classify line - in (seenBirdTrack || isBirdTrack classification, classification) - - isBirdTrack (BirdTrack _) = True - isBirdTrack _ = False - - checkErrors ls = case [ e | Error e <- ls ] of - [] -> Left ls - (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message) - where (f, n) = errorPos file 1 ls - errorPos f n [] = (f, n) - errorPos f n (Error _:_) = (f, n) - errorPos _ _ (Line n' f':ls) = errorPos f' n' ls - errorPos f n (_ :ls) = errorPos f (n+1) ls - --- Here we model a state machine, with each state represented by --- a local function. We only have four states (well, five, --- if you count the error state), but the rules --- to transition between then are not so simple. --- Would it be simpler to have more states? --- --- Each state represents the type of line that was last read --- i.e. are we in a comment section, or a latex-code section, --- or a bird-code section, etc? -reclassify :: [Classified] -> [Classified] -reclassify = blank -- begin in blank state - where - latex [] = [] - latex (EndCode :ls) = Blank "" : comment ls - latex (BeginCode :_ ) = [Error "\\begin{code} in code section"] - latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls - latex ( l:ls) = l : latex ls - - blank [] = [] - blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - blank (BeginCode :ls) = Blank "" : latex ls - blank (BirdTrack l:ls) = BirdTrack l : bird ls - blank (Ordinary l:ls) = Comment l : comment ls - blank ( l:ls) = l : blank ls - - bird [] = [] - bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - bird (BeginCode :ls) = Blank "" : latex ls - bird (Blank l :ls) = Blank l : blank ls - bird (Ordinary _:_ ) = [Error "program line before comment line"] - bird ( l:ls) = l : bird ls - - comment [] = [] - comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - comment (BeginCode :ls) = Blank "" : latex ls - comment (CPP l :ls) = CPP l : comment ls - comment (BirdTrack _:_ ) = [Error "comment line before program line"] - -- a blank line and another ordinary line following a comment - -- will be treated as continuing the comment. Otherwise it's - -- then end of the comment, with a blank line. - comment (Blank l:ls@(Ordinary _:_)) = Comment l : comment ls - comment (Blank l:ls) = Blank l : blank ls - comment (Line n f :ls) = Line n f : comment ls - comment (Ordinary l:ls) = Comment l : comment ls - comment (Comment _: _) = internalError - comment (Error _: _) = internalError - --- Re-implementation of 'lines', for better efficiency (but decreased laziness). --- Also, importantly, accepts non-standard DOS and Mac line ending characters. -inlines :: String -> [String] -inlines xs = lines' xs id - where - lines' [] acc = [acc []] - lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS - lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS - lines' ('\n':s) acc = acc [] : lines' s id -- Unix - lines' (c:s) acc = lines' s (acc . (c:)) - -internalError :: a -internalError = error "unlit: internal error" diff --git a/cabal/cabal/Distribution/Simple/Program.hs b/cabal/cabal/Distribution/Simple/Program.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Program.hs +++ /dev/null @@ -1,217 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program --- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This provides an abstraction which deals with configuring and running --- programs. A 'Program' is a static notion of a known program. A --- 'ConfiguredProgram' is a 'Program' that has been found on the current --- machine and is ready to be run (possibly with some user-supplied default --- args). Configuring a program involves finding its location and if necessary --- finding its version. There is also a 'ProgramConfiguration' type which holds --- configured and not-yet configured programs. It is the parameter to lots of --- actions elsewhere in Cabal that need to look up and run programs. If we had --- a Cabal monad, the 'ProgramConfiguration' would probably be a reader or --- state component of it. --- --- The module also defines all the known built-in 'Program's and the --- 'defaultProgramConfiguration' which contains them all. --- --- One nice thing about using it is that any program that is --- registered with Cabal will get some \"configure\" and \".cabal\" --- helpers like --with-foo-args --foo-path= and extra-foo-args. --- --- There's also good default behavior for trying to find \"foo\" in --- PATH, being able to override its location, etc. --- --- There's also a hook for adding programs in a Setup.lhs script. See --- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a --- hook user the ability to get the above flags and such so that they --- don't have to write all the PATH logic inside Setup.lhs. - -module Distribution.Simple.Program ( - -- * Program and functions for constructing them - Program(..) - , simpleProgram - , findProgramLocation - , findProgramVersion - - -- * Configured program and related functions - , ConfiguredProgram(..) - , programPath - , ProgArg - , ProgramLocation(..) - , runProgram - , getProgramOutput - - -- * Program invocations - , ProgramInvocation(..) - , emptyProgramInvocation - , simpleProgramInvocation - , programInvocation - , runProgramInvocation - , getProgramInvocationOutput - - -- * The collection of unconfigured and configured progams - , builtinPrograms - - -- * The collection of configured programs we can run - , ProgramConfiguration - , emptyProgramConfiguration - , defaultProgramConfiguration - , restoreProgramConfiguration - , addKnownProgram - , addKnownPrograms - , lookupKnownProgram - , knownPrograms - , userSpecifyPath - , userSpecifyPaths - , userMaybeSpecifyPath - , userSpecifyArgs - , userSpecifyArgss - , userSpecifiedArgs - , lookupProgram - , updateProgram - , configureProgram - , configureAllKnownPrograms - , reconfigurePrograms - , requireProgram - , requireProgramVersion - , runDbProgram - , getDbProgramOutput - - -- * Programs that Cabal knows about - , ghcProgram - , ghcPkgProgram - , lhcProgram - , lhcPkgProgram - , nhcProgram - , hmakeProgram - , jhcProgram - , hugsProgram - , ffihugsProgram - , uhcProgram - , gccProgram - , ranlibProgram - , arProgram - , stripProgram - , happyProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , hscolourProgram - , haddockProgram - , greencardProgram - , ldProgram - , tarProgram - , cppProgram - , pkgConfigProgram - - -- * deprecated - , rawSystemProgram - , rawSystemProgramStdout - , rawSystemProgramConf - , rawSystemProgramStdoutConf - , findProgramOnPath - - ) where - -import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Run -import Distribution.Simple.Program.Db -import Distribution.Simple.Program.Builtin - -import Distribution.Simple.Utils - ( die, findProgramLocation, findProgramVersion ) -import Distribution.Verbosity - ( Verbosity ) - - --- | Runs the given configured program. --- -runProgram :: Verbosity -- ^Verbosity - -> ConfiguredProgram -- ^The program to run - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO () -runProgram verbosity prog args = - runProgramInvocation verbosity (programInvocation prog args) - - --- | Runs the given configured program and gets the output. --- -getProgramOutput :: Verbosity -- ^Verbosity - -> ConfiguredProgram -- ^The program to run - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO String -getProgramOutput verbosity prog args = - getProgramInvocationOutput verbosity (programInvocation prog args) - - --- | Looks up the given program in the program database and runs it. --- -runDbProgram :: Verbosity -- ^verbosity - -> Program -- ^The program to run - -> ProgramDb -- ^look up the program here - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO () -runDbProgram verbosity prog programDb args = - case lookupProgram prog programDb of - Nothing -> die notFound - Just configuredProg -> runProgram verbosity configuredProg args - where - 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. --- -getDbProgramOutput :: Verbosity -- ^verbosity - -> Program -- ^The program to run - -> ProgramDb -- ^look up the program here - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO String -getDbProgramOutput verbosity prog programDb args = - case lookupProgram prog programDb of - Nothing -> die notFound - Just configuredProg -> getProgramOutput verbosity configuredProg args - where - notFound = "The program " ++ programName prog - ++ " is required but it could not be found" - - ---------------------- --- Deprecated aliases --- - -rawSystemProgram :: Verbosity -> ConfiguredProgram - -> [ProgArg] -> IO () -rawSystemProgram = runProgram - -rawSystemProgramStdout :: Verbosity -> ConfiguredProgram - -> [ProgArg] -> IO String -rawSystemProgramStdout = getProgramOutput - -rawSystemProgramConf :: Verbosity -> Program -> ProgramConfiguration - -> [ProgArg] -> IO () -rawSystemProgramConf = runDbProgram - -rawSystemProgramStdoutConf :: Verbosity -> Program -> ProgramConfiguration - -> [ProgArg] -> IO String -rawSystemProgramStdoutConf = getDbProgramOutput - -type ProgramConfiguration = ProgramDb - -emptyProgramConfiguration, defaultProgramConfiguration :: ProgramConfiguration -emptyProgramConfiguration = emptyProgramDb -defaultProgramConfiguration = defaultProgramDb - -restoreProgramConfiguration :: [Program] -> ProgramConfiguration - -> ProgramConfiguration -restoreProgramConfiguration = restoreProgramDb - -{-# DEPRECATED findProgramOnPath "use findProgramLocation instead" #-} -findProgramOnPath :: String -> Verbosity -> IO (Maybe FilePath) -findProgramOnPath = flip findProgramLocation diff --git a/cabal/cabal/Distribution/Simple/Program/Ar.hs b/cabal/cabal/Distribution/Simple/Program/Ar.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Program/Ar.hs +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Ar --- Copyright : Duncan Coutts 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides an library interface to the @ar@ program. - -module Distribution.Simple.Program.Ar ( - createArLibArchive, - multiStageProgramInvocation, - ) where - -import Distribution.Simple.Program.Types - ( ConfiguredProgram(..) ) -import Distribution.Simple.Program.Run - ( programInvocation, multiStageProgramInvocation - , runProgramInvocation ) -import Distribution.System - ( OS(..), buildOS ) -import Distribution.Verbosity - ( Verbosity, deafening, verbose ) - --- | Call @ar@ to create a library archive from a bunch of object files. --- -createArLibArchive :: Verbosity -> ConfiguredProgram - -> FilePath -> [FilePath] -> IO () -createArLibArchive verbosity ar target files = - - -- The args to use with "ar" are actually rather subtle and system-dependent. - -- In particular we have the following issues: - -- - -- -- On OS X, "ar q" does not make an archive index. Archives with no - -- index cannot be used. - -- - -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us - -- do that. We have duplicates because of modules like "A.M" and "B.M" - -- both make an object file "M.o" and ar does not consider the directory. - -- - -- Our solution is to use "ar r" in the simple case when one call is enough. - -- 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 - OSX -> ["-r", "-s"] - _ -> ["-r"] - - initialArgs = ["-q"] - finalArgs = case buildOS of - OSX -> ["-q", "-s"] - _ -> ["-q"] - - extraArgs = verbosityOpts verbosity ++ [target] - - simple = programInvocation ar (simpleArgs ++ extraArgs) - initial = programInvocation ar (initialArgs ++ extraArgs) - middle = initial - final = programInvocation ar (finalArgs ++ extraArgs) - - in sequence_ - [ runProgramInvocation verbosity inv - | inv <- multiStageProgramInvocation - simple (initial, middle, final) files ] - - where - verbosityOpts v | v >= deafening = ["-v"] - | v >= verbose = [] - | otherwise = ["-c"] diff --git a/cabal/cabal/Distribution/Simple/Program/Builtin.hs b/cabal/cabal/Distribution/Simple/Program/Builtin.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Program/Builtin.hs +++ /dev/null @@ -1,259 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Builtin --- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- The module defines all the known built-in 'Program's. --- --- Where possible we try to find their version numbers. --- -module Distribution.Simple.Program.Builtin ( - - -- * The collection of unconfigured and configured progams - builtinPrograms, - - -- * Programs that Cabal knows about - ghcProgram, - ghcPkgProgram, - lhcProgram, - lhcPkgProgram, - nhcProgram, - hmakeProgram, - jhcProgram, - hugsProgram, - ffihugsProgram, - uhcProgram, - gccProgram, - ranlibProgram, - arProgram, - stripProgram, - happyProgram, - alexProgram, - hsc2hsProgram, - c2hsProgram, - cpphsProgram, - hscolourProgram, - haddockProgram, - greencardProgram, - ldProgram, - tarProgram, - cppProgram, - pkgConfigProgram, - ) where - -import Distribution.Simple.Program.Types - ( Program(..), simpleProgram ) -import Distribution.Simple.Utils - ( findProgramLocation, findProgramVersion ) - --- ------------------------------------------------------------ --- * Known programs --- ------------------------------------------------------------ - --- | The default list of programs. --- These programs are typically used internally to Cabal. -builtinPrograms :: [Program] -builtinPrograms = - [ - -- compilers and related progs - ghcProgram - , ghcPkgProgram - , hugsProgram - , ffihugsProgram - , nhcProgram - , hmakeProgram - , jhcProgram - , lhcProgram - , lhcPkgProgram - , uhcProgram - -- preprocessors - , hscolourProgram - , haddockProgram - , happyProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , greencardProgram - -- platform toolchain - , gccProgram - , ranlibProgram - , arProgram - , stripProgram - , ldProgram - , tarProgram - -- configuration tools - , pkgConfigProgram - ] - -ghcProgram :: Program -ghcProgram = (simpleProgram "ghc") { - programFindVersion = findProgramVersion "--numeric-version" id - } - -ghcPkgProgram :: Program -ghcPkgProgram = (simpleProgram "ghc-pkg") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "ghc-pkg --version" gives a string like - -- "GHC package manager version 6.4.1" - case words str of - (_:_:_:_:ver:_) -> ver - _ -> "" - } - -lhcProgram :: Program -lhcProgram = (simpleProgram "lhc") { - programFindVersion = findProgramVersion "--numeric-version" id - } - -lhcPkgProgram :: Program -lhcPkgProgram = (simpleProgram "lhc-pkg") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "lhc-pkg --version" gives a string like - -- "LHC package manager version 0.7" - case words str of - (_:_:_:_:ver:_) -> ver - _ -> "" - } - -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 -> - -- Invoking "hmake --version" gives a string line - -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" - case words str of - (_:ver:_) -> ver - _ -> "" - } - -jhcProgram :: Program -jhcProgram = (simpleProgram "jhc") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- invoking "jhc --version" gives a string like - -- "jhc 0.3.20080208 (wubgipkamcep-2) - -- compiled by ghc-6.8 on a x86_64 running linux" - case words str of - (_:ver:_) -> ver - _ -> "" - } - -uhcProgram :: Program -uhcProgram = (simpleProgram "uhc") { - programFindVersion = findProgramVersion "--version-dotted" id - } - - --- AArgh! Finding the version of hugs or ffihugs is almost impossible. -hugsProgram :: Program -hugsProgram = simpleProgram "hugs" - -ffihugsProgram :: Program -ffihugsProgram = simpleProgram "ffihugs" - -happyProgram :: Program -happyProgram = (simpleProgram "happy") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "happy --version" gives a string like - -- "Happy Version 1.16 Copyright (c) ...." - case words str of - (_:_:ver:_) -> ver - _ -> "" - } - -alexProgram :: Program -alexProgram = (simpleProgram "alex") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- 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 - _ -> "" - } - -gccProgram :: Program -gccProgram = (simpleProgram "gcc") { - programFindVersion = findProgramVersion "-dumpversion" id - } - -ranlibProgram :: Program -ranlibProgram = simpleProgram "ranlib" - -arProgram :: Program -arProgram = simpleProgram "ar" - -stripProgram :: Program -stripProgram = simpleProgram "strip" - -hsc2hsProgram :: Program -hsc2hsProgram = (simpleProgram "hsc2hs") { - programFindVersion = - findProgramVersion "--version" $ \str -> - -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" - case words str of - (_:_:ver:_) -> ver - _ -> "" - } - -c2hsProgram :: Program -c2hsProgram = (simpleProgram "c2hs") { - programFindVersion = findProgramVersion "--numeric-version" id - } - -cpphsProgram :: Program -cpphsProgram = (simpleProgram "cpphs") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "cpphs --version" gives a string like "cpphs 1.3" - case words str of - (_:ver:_) -> ver - _ -> "" - } - -hscolourProgram :: Program -hscolourProgram = (simpleProgram "hscolour") { - programFindLocation = \v -> findProgramLocation v "HsColour", - programFindVersion = findProgramVersion "-version" $ \str -> - -- Invoking "HsColour -version" gives a string like "HsColour 1.7" - case words str of - (_:ver:_) -> ver - _ -> "" - } - -haddockProgram :: Program -haddockProgram = (simpleProgram "haddock") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "haddock --version" gives a string like - -- "Haddock version 0.8, (c) Simon Marlow 2006" - case words str of - (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver - _ -> "" - } - -greencardProgram :: Program -greencardProgram = simpleProgram "greencard" - -ldProgram :: Program -ldProgram = simpleProgram "ld" - -tarProgram :: Program -tarProgram = simpleProgram "tar" - -cppProgram :: Program -cppProgram = simpleProgram "cpp" - -pkgConfigProgram :: Program -pkgConfigProgram = (simpleProgram "pkg-config") { - programFindVersion = findProgramVersion "--version" id - } diff --git a/cabal/cabal/Distribution/Simple/Program/Db.hs b/cabal/cabal/Distribution/Simple/Program/Db.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Program/Db.hs +++ /dev/null @@ -1,409 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Db --- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This provides a 'ProgramDb' type which holds configured and not-yet --- configured programs. It is the parameter to lots of actions elsewhere in --- Cabal that need to look up and run programs. If we had a Cabal monad, --- the 'ProgramDb' would probably be a reader or state component of it. --- --- One nice thing about using it is that any program that is --- registered with Cabal will get some \"configure\" and \".cabal\" --- helpers like --with-foo-args --foo-path= and extra-foo-args. --- --- There's also a hook for adding programs in a Setup.lhs script. See --- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a --- hook user the ability to get the above flags and such so that they --- don't have to write all the PATH logic inside Setup.lhs. - -module Distribution.Simple.Program.Db ( - -- * The collection of configured programs we can run - ProgramDb, - emptyProgramDb, - defaultProgramDb, - restoreProgramDb, - - -- ** Query and manipulate the program db - addKnownProgram, - addKnownPrograms, - lookupKnownProgram, - knownPrograms, - userSpecifyPath, - userSpecifyPaths, - userMaybeSpecifyPath, - userSpecifyArgs, - userSpecifyArgss, - userSpecifiedArgs, - lookupProgram, - updateProgram, - - -- ** Query and manipulate the program db - configureProgram, - configureAllKnownPrograms, - reconfigurePrograms, - requireProgram, - requireProgramVersion, - - ) where - -import Distribution.Simple.Program.Types - ( Program(..), ProgArg, ConfiguredProgram(..), ProgramLocation(..) ) -import Distribution.Simple.Program.Builtin - ( builtinPrograms ) -import Distribution.Simple.Utils - ( die, findProgramLocation ) -import Distribution.Version - ( Version, VersionRange, isAnyVersion, withinRange ) -import Distribution.Text - ( display ) -import Distribution.Verbosity - ( Verbosity ) - -import Data.List - ( foldl' ) -import Data.Maybe - ( catMaybes ) -import qualified Data.Map as Map -import Control.Monad - ( join, foldM ) -import System.Directory - ( doesFileExist ) - - --- ------------------------------------------------------------ --- * Programs database --- ------------------------------------------------------------ - --- | The configuration is a collection of information about programs. It --- contains information both about configured programs and also about programs --- that we are yet to configure. --- --- The idea is that we start from a collection of unconfigured programs and one --- by one we try to configure them at which point we move them into the --- configured collection. For unconfigured programs we record not just the --- 'Program' but also any user-provided arguments and location for the program. -data ProgramDb = ProgramDb { - unconfiguredProgs :: UnconfiguredProgs, - configuredProgs :: ConfiguredProgs - } - -type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) -type UnconfiguredProgs = Map.Map String UnconfiguredProgram -type ConfiguredProgs = Map.Map String ConfiguredProgram - - -emptyProgramDb :: ProgramDb -emptyProgramDb = ProgramDb Map.empty Map.empty - - -defaultProgramDb :: ProgramDb -defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb - - --- internal helpers: -updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs) - -> ProgramDb -> ProgramDb -updateUnconfiguredProgs update conf = - conf { unconfiguredProgs = update (unconfiguredProgs conf) } - -updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs) - -> ProgramDb -> ProgramDb -updateConfiguredProgs update conf = - conf { configuredProgs = update (configuredProgs conf) } - - --- Read & Show instances are based on listToFM --- Note that we only serialise the configured part of the database, this is --- because we don't need the unconfigured part after the configure stage, and --- additionally because we cannot read/show 'Program' as it contains functions. -instance Show ProgramDb where - show = show . Map.toAscList . configuredProgs - -instance Read ProgramDb where - readsPrec p s = - [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r) - | (s', r) <- readsPrec p s ] - - --- | 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 --- back all the known 'Program's. --- --- * It does not add the default programs, but you probably want them, use --- 'builtinPrograms' in addition to any extra you might need. --- -restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb -restoreProgramDb = addKnownPrograms - - --- ------------------------------- --- Managing unconfigured programs - --- | Add a known program that we may configure later --- -addKnownProgram :: Program -> ProgramDb -> ProgramDb -addKnownProgram prog = updateUnconfiguredProgs $ - Map.insertWith combine (programName prog) (prog, Nothing, []) - where combine _ (_, path, args) = (prog, path, args) - - -addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb -addKnownPrograms progs conf = foldl' (flip addKnownProgram) conf progs - - -lookupKnownProgram :: String -> ProgramDb -> Maybe Program -lookupKnownProgram name = - fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs - - -knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)] -knownPrograms conf = - [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf) - , let p' = Map.lookup (programName p) (configuredProgs conf) ] - - --- |User-specify this path. Basically override any path information --- for this program in the configuration. If it's not a known --- program ignore it. --- -userSpecifyPath :: String -- ^Program name - -> FilePath -- ^user-specified path to the program - -> ProgramDb -> ProgramDb -userSpecifyPath name path = updateUnconfiguredProgs $ - flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args) - - -userMaybeSpecifyPath :: String -> Maybe FilePath - -> ProgramDb -> ProgramDb -userMaybeSpecifyPath _ Nothing conf = conf -userMaybeSpecifyPath name (Just path) conf = userSpecifyPath name path conf - - --- |User-specify the arguments for this program. Basically override --- any args information for this program in the configuration. If it's --- not a known program, ignore it.. -userSpecifyArgs :: String -- ^Program name - -> [ProgArg] -- ^user-specified args - -> ProgramDb - -> ProgramDb -userSpecifyArgs name args' = - updateUnconfiguredProgs - (flip Map.update name $ - \(prog, path, args) -> Just (prog, path, args ++ args')) - . updateConfiguredProgs - (flip Map.update name $ - \prog -> Just prog { programOverrideArgs = programOverrideArgs prog - ++ args' }) - - --- | Like 'userSpecifyPath' but for a list of progs and their paths. --- -userSpecifyPaths :: [(String, FilePath)] - -> ProgramDb - -> ProgramDb -userSpecifyPaths paths conf = - foldl' (\conf' (prog, path) -> userSpecifyPath prog path conf') conf paths - - --- | Like 'userSpecifyPath' but for a list of progs and their args. --- -userSpecifyArgss :: [(String, [ProgArg])] - -> ProgramDb - -> ProgramDb -userSpecifyArgss argss conf = - foldl' (\conf' (prog, args) -> userSpecifyArgs prog args conf') conf argss - - --- | Get the path that has been previously specified for a program, if any. --- -userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath -userSpecifiedPath prog = - join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs - - --- | Get any extra args that have been previously specified for a program. --- -userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg] -userSpecifiedArgs prog = - maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs - - --- ----------------------------- --- Managing configured programs - --- | Try to find a configured program -lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram -lookupProgram prog = Map.lookup (programName prog) . configuredProgs - - --- | Update a configured program in the database. -updateProgram :: ConfiguredProgram -> ProgramDb - -> ProgramDb -updateProgram prog = updateConfiguredProgs $ - Map.insert (programId prog) prog - - --- --------------------------- --- 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 --- added to the configured collection. --- --- Note that it is not a failure if the program cannot be configured. It's only --- a failure if the user supplied a location and the program could not be found --- at that location. --- --- 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 --- 'requireProgram'. --- -configureProgram :: Verbosity - -> Program - -> ProgramDb - -> IO ProgramDb -configureProgram verbosity prog conf = do - let name = programName prog - maybeLocation <- case userSpecifiedPath prog conf of - Nothing -> programFindLocation prog verbosity - >>= return . fmap FoundOnSystem - Just path -> do - absolute <- doesFileExist path - if absolute - then return (Just (UserSpecified path)) - else findProgramLocation verbosity path - >>= maybe (die notFound) (return . Just . UserSpecified) - where notFound = "Cannot find the program '" ++ name ++ "' at '" - ++ path ++ "' or on the path" - case maybeLocation of - Nothing -> return conf - Just location -> do - version <- programFindVersion prog verbosity (locationPath location) - let configuredProg = ConfiguredProgram { - programId = name, - programVersion = version, - programDefaultArgs = [], - programOverrideArgs = userSpecifiedArgs prog conf, - programLocation = location - } - extraArgs <- programPostConf prog verbosity configuredProg - let configuredProg' = configuredProg { - programDefaultArgs = extraArgs - } - return (updateConfiguredProgs (Map.insert name configuredProg') conf) - - --- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. --- -configurePrograms :: Verbosity - -> [Program] - -> ProgramDb - -> IO ProgramDb -configurePrograms verbosity progs conf = - foldM (flip (configureProgram verbosity)) conf progs - - --- | Try to configure all the known programs that have not yet been configured. --- -configureAllKnownPrograms :: Verbosity - -> ProgramDb - -> IO ProgramDb -configureAllKnownPrograms verbosity conf = - configurePrograms verbosity - [ prog | (prog,_,_) <- Map.elems notYetConfigured ] conf - where - notYetConfigured = unconfiguredProgs conf - `Map.difference` configuredProgs conf - - --- | reconfigure a bunch of programs given new user-specified args. It takes --- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs --- with a new path it calls 'configureProgram'. --- -reconfigurePrograms :: Verbosity - -> [(String, FilePath)] - -> [(String, [ProgArg])] - -> ProgramDb - -> IO ProgramDb -reconfigurePrograms verbosity paths argss conf = do - configurePrograms verbosity progs - . userSpecifyPaths paths - . userSpecifyArgss argss - $ conf - - where - progs = catMaybes [ lookupKnownProgram name conf | (name,_) <- paths ] - - --- | Check that a program is configured and available to be run. --- --- It raises an exception if the program could not be configured, otherwise --- it returns the configured program. --- -requireProgram :: Verbosity -> Program -> ProgramDb - -> IO (ConfiguredProgram, ProgramDb) -requireProgram verbosity prog conf = 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 - - case lookupProgram prog conf' of - Nothing -> die notFound - Just configuredProg -> return (configuredProg, conf') - - 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] [])@ --- --- 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. --- -requireProgramVersion :: Verbosity -> Program -> VersionRange - -> ProgramDb - -> IO (ConfiguredProgram, Version, ProgramDb) -requireProgramVersion verbosity prog range conf = 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 - - case lookupProgram prog conf' of - Nothing -> die 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) - - where notFound = "The program " - ++ programName prog ++ versionRequirement - ++ " is required but it could not be found." - 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 - ++ " is required but the version of " - ++ locationPath l ++ " could not be determined." - versionRequirement - | isAnyVersion range = "" - | otherwise = " version " ++ display range diff --git a/cabal/cabal/Distribution/Simple/Program/HcPkg.hs b/cabal/cabal/Distribution/Simple/Program/HcPkg.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Program/HcPkg.hs +++ /dev/null @@ -1,338 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.HcPkg --- Copyright : Duncan Coutts 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides an library interface to the @hc-pkg@ program. --- Currently only GHC and LHC have hc-pkg programs. - -module Distribution.Simple.Program.HcPkg ( - register, - reregister, - unregister, - expose, - hide, - dump, - - -- * Program invocations - registerInvocation, - reregisterInvocation, - unregisterInvocation, - exposeInvocation, - hideInvocation, - dumpInvocation, - ) where - -import Distribution.Package - ( PackageId, InstalledPackageId(..) ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, InstalledPackageInfo_(..) - , showInstalledPackageInfo - , emptyInstalledPackageInfo, fieldsInstalledPackageInfo ) -import Distribution.ParseUtils -import Distribution.Simple.Compiler - ( PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program.Types - ( ConfiguredProgram(programId, programVersion) ) -import Distribution.Simple.Program.Run - ( ProgramInvocation(..), IOEncoding(..), programInvocation - , runProgramInvocation, getProgramInvocationOutput ) -import Distribution.Version - ( Version(..) ) -import Distribution.Text - ( display ) -import Distribution.Simple.Utils - ( die ) -import Distribution.Verbosity - ( Verbosity, deafening, silent ) -import Distribution.Compat.Exception - ( catchExit ) - -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 - - --- | Call @hc-pkg@ to register a package. --- --- > hc-pkg register {filename | -} [--user | --global | --package-conf] --- -register :: Verbosity -> ConfiguredProgram -> PackageDBStack - -> Either FilePath - InstalledPackageInfo - -> IO () -register verbosity hcPkg packagedb pkgFile = - runProgramInvocation verbosity - (registerInvocation hcPkg verbosity packagedb pkgFile) - - --- | Call @hc-pkg@ to re-register a package. --- --- > hc-pkg register {filename | -} [--user | --global | --package-conf] --- -reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack - -> Either FilePath - InstalledPackageInfo - -> IO () -reregister verbosity hcPkg packagedb pkgFile = - runProgramInvocation verbosity - (reregisterInvocation hcPkg verbosity packagedb pkgFile) - - --- | Call @hc-pkg@ to unregister a package --- --- > hc-pkg unregister [pkgid] [--user | --global | --package-conf] --- -unregister :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () -unregister verbosity hcPkg packagedb pkgid = - runProgramInvocation verbosity - (unregisterInvocation hcPkg verbosity packagedb pkgid) - - --- | Call @hc-pkg@ to expose a package. --- --- > hc-pkg expose [pkgid] [--user | --global | --package-conf] --- -expose :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () -expose verbosity hcPkg packagedb pkgid = - runProgramInvocation verbosity - (exposeInvocation hcPkg verbosity packagedb pkgid) - - --- | Call @hc-pkg@ to expose a package. --- --- > hc-pkg expose [pkgid] [--user | --global | --package-conf] --- -hide :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () -hide verbosity hcPkg packagedb pkgid = - runProgramInvocation verbosity - (hideInvocation hcPkg verbosity packagedb pkgid) - - --- | Call @hc-pkg@ to get all the installed packages. --- -dump :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [InstalledPackageInfo] -dump verbosity hcPkg packagedb = do - - output <- getProgramInvocationOutput verbosity - (dumpInvocation hcPkg verbosity packagedb) - `catchExit` \_ -> die $ programId hcPkg ++ " dump failed" - - case parsePackages output of - Left ok -> return ok - _ -> die $ "failed to parse output of '" - ++ programId hcPkg ++ " dump'" - - where - parsePackages str = - let parsed = map parseInstalledPackageInfo' (splitPkgs str) - in case [ msg | ParseFailed msg <- parsed ] of - [] -> Left [ setInstalledPackageId - . maybe id mungePackagePaths pkgroot - $ pkg - | ParseOk _ (pkgroot, 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)) - - --TODO: this could be a lot faster. We're doing normaliseLineEndings twice - -- and converting back and forth with lines/unlines. - splitPkgs :: String -> [String] - splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines - where - -- Handle the case of there being no packages at all. - checkEmpty [s] | all isSpace s = [] - checkEmpty ss = ss - - splitWith :: (a -> Bool) -> [a] -> [[a]] - splitWith p xs = ys : case zs of - [] -> [] - _:ws -> splitWith p ws - where (ys,zs) = break p xs - -mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo --- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec --- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) --- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. --- The "pkgroot" is the directory containing the package database. -mungePackagePaths pkgroot pkginfo = - pkginfo { - importDirs = mungePaths (importDirs pkginfo), - includeDirs = mungePaths (includeDirs pkginfo), - libraryDirs = mungePaths (libraryDirs pkginfo), - frameworkDirs = mungePaths (frameworkDirs pkginfo), - haddockInterfaces = mungePaths (haddockInterfaces pkginfo), - haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) - } - where - mungePaths = map mungePath - mungeUrls = map mungeUrl - - mungePath p = case stripVarPrefix "${pkgroot}" p of - Just p' -> pkgroot p' - Nothing -> p - - mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of - Just p' -> toUrlPath pkgroot p' - Nothing -> p - - toUrlPath r p = "file:///" - -- URLs always use posix style '/' separators: - ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) - - stripVarPrefix var p = - case splitPath p of - (root:path') -> case stripPrefix var root of - Just [sep] | isPathSeparator sep -> Just (joinPath path') - _ -> Nothing - _ -> 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 - - --------------------------- --- The program invocations --- - -registerInvocation, reregisterInvocation - :: ConfiguredProgram -> Verbosity -> PackageDBStack - -> Either FilePath InstalledPackageInfo - -> ProgramInvocation -registerInvocation = registerInvocation' "register" -reregisterInvocation = registerInvocation' "update" - - -registerInvocation' :: String - -> ConfiguredProgram -> Verbosity -> PackageDBStack - -> Either FilePath InstalledPackageInfo - -> ProgramInvocation -registerInvocation' cmdname hcPkg verbosity packagedbs (Left pkgFile) = - programInvocation hcPkg args - where - args = [cmdname, pkgFile] - ++ (if legacyVersion hcPkg - then [packageDbOpts (last packagedbs)] - else packageDbStackOpts packagedbs) - ++ verbosityOpts hcPkg verbosity - -registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) = - (programInvocation hcPkg args) { - progInvokeInput = Just (showInstalledPackageInfo pkgInfo), - progInvokeInputEncoding = IOEncodingUTF8 - } - where - args = [cmdname, "-"] - ++ (if legacyVersion hcPkg - then [packageDbOpts (last packagedbs)] - else packageDbStackOpts packagedbs) - ++ verbosityOpts hcPkg verbosity - - -unregisterInvocation :: ConfiguredProgram - -> Verbosity -> PackageDB -> PackageId - -> ProgramInvocation -unregisterInvocation hcPkg verbosity packagedb pkgid = - programInvocation hcPkg $ - ["unregister", packageDbOpts packagedb, display pkgid] - ++ verbosityOpts hcPkg verbosity - - -exposeInvocation :: ConfiguredProgram - -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation -exposeInvocation hcPkg verbosity packagedb pkgid = - programInvocation hcPkg $ - ["expose", packageDbOpts packagedb, display pkgid] - ++ verbosityOpts hcPkg verbosity - - -hideInvocation :: ConfiguredProgram - -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation -hideInvocation hcPkg verbosity packagedb pkgid = - programInvocation hcPkg $ - ["hide", packageDbOpts packagedb, display pkgid] - ++ verbosityOpts hcPkg verbosity - - -dumpInvocation :: ConfiguredProgram - -> Verbosity -> PackageDB -> ProgramInvocation -dumpInvocation hcPkg _verbosity packagedb = - (programInvocation hcPkg args) { - progInvokeOutputEncoding = IOEncodingUTF8 - } - where - args = ["dump", packageDbOpts packagedb] - ++ verbosityOpts hcPkg silent - -- We use verbosity level 'silent' because it is important that we - -- do not contaminate the output with info/debug messages. - - -packageDbStackOpts :: PackageDBStack -> [String] -packageDbStackOpts dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> "--global" - : "--user" - : map specific dbs - (GlobalPackageDB:dbs) -> "--global" - : "--no-user-package-conf" - : map specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = "--package-conf=" ++ db - specific _ = ierror - ierror :: a - ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) - -packageDbOpts :: PackageDB -> String -packageDbOpts GlobalPackageDB = "--global" -packageDbOpts UserPackageDB = "--user" -packageDbOpts (SpecificPackageDB db) = "--package-conf=" ++ db - -verbosityOpts :: ConfiguredProgram -> Verbosity -> [String] -verbosityOpts hcPkg v - - -- ghc-pkg < 6.11 does not support -v - | programId hcPkg == "ghc-pkg" - && programVersion hcPkg < Just (Version [6,11] []) - = [] - - | 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] []) diff --git a/cabal/cabal/Distribution/Simple/Program/Ld.hs b/cabal/cabal/Distribution/Simple/Program/Ld.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Program/Ld.hs +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Ld --- Copyright : Duncan Coutts 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides an library interface to the @ld@ linker program. - -module Distribution.Simple.Program.Ld ( - combineObjectFiles, - ) where - -import Distribution.Simple.Program.Types - ( ConfiguredProgram(..) ) -import Distribution.Simple.Program.Run - ( programInvocation, multiStageProgramInvocation - , runProgramInvocation ) -import Distribution.Verbosity - ( Verbosity ) - -import System.Directory - ( renameFile ) -import System.FilePath - ( (<.>) ) - --- | Call @ld -r@ to link a bunch of object files together. --- -combineObjectFiles :: Verbosity -> ConfiguredProgram - -> FilePath -> [FilePath] -> IO () -combineObjectFiles verbosity ld target files = - - -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is, - -- if we have more object files than fit on a single command line then we - -- have a slight problem. What we have to do is link files in batches into - -- a temp object file and then include that one in the next batch. - - let simpleArgs = ["-r", "-o", target] - - initialArgs = ["-r", "-o", target] - middleArgs = ["-r", "-o", target, tmpfile] - finalArgs = middleArgs - - simple = programInvocation ld simpleArgs - initial = programInvocation ld initialArgs - middle = programInvocation ld middleArgs - final = programInvocation ld finalArgs - - invocations = multiStageProgramInvocation - simple (initial, middle, final) files - - in run invocations - - where - tmpfile = target <.> "tmp" -- perhaps should use a proper temp file - - run [] = return () - run [inv] = runProgramInvocation verbosity inv - run (inv:invs) = do runProgramInvocation verbosity inv - renameFile target tmpfile - run invs diff --git a/cabal/cabal/Distribution/Simple/Program/Run.hs b/cabal/cabal/Distribution/Simple/Program/Run.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Program/Run.hs +++ /dev/null @@ -1,218 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Run --- Copyright : Duncan Coutts 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides a data type for program invocations and functions to --- run them. - -module Distribution.Simple.Program.Run ( - ProgramInvocation(..), - IOEncoding(..), - emptyProgramInvocation, - simpleProgramInvocation, - programInvocation, - multiStageProgramInvocation, - - runProgramInvocation, - getProgramInvocationOutput, - - ) where - -import Distribution.Simple.Program.Types - ( ConfiguredProgram(..), programPath ) -import Distribution.Simple.Utils - ( die, rawSystemExit, rawSystemStdInOut - , toUTF8, fromUTF8, normaliseLineEndings ) -import Distribution.Verbosity - ( Verbosity ) - -import Data.List - ( foldl', unfoldr ) -import Control.Monad - ( when ) -import System.Exit - ( ExitCode(..) ) - --- | Represents a specific invocation of a specific program. --- --- This is used as an intermediate type between deciding how to call a program --- and actually doing it. This provides the opportunity to the caller to --- adjust how the program will be called. These invocations can either be run --- directly or turned into shell or batch scripts. --- -data ProgramInvocation = ProgramInvocation { - progInvokePath :: FilePath, - progInvokeArgs :: [String], - progInvokeEnv :: [(String, String)], - progInvokeCwd :: Maybe FilePath, - progInvokeInput :: Maybe String, - progInvokeInputEncoding :: IOEncoding, - progInvokeOutputEncoding :: IOEncoding - } - -data IOEncoding = IOEncodingText -- locale mode text - | IOEncodingUTF8 -- always utf8 - -emptyProgramInvocation :: ProgramInvocation -emptyProgramInvocation = - ProgramInvocation { - progInvokePath = "", - progInvokeArgs = [], - progInvokeEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Nothing, - progInvokeInputEncoding = IOEncodingText, - progInvokeOutputEncoding = IOEncodingText - } - -simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation -simpleProgramInvocation path args = - emptyProgramInvocation { - progInvokePath = path, - progInvokeArgs = args - } - -programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation -programInvocation prog args = - emptyProgramInvocation { - progInvokePath = programPath prog, - progInvokeArgs = programDefaultArgs prog - ++ args - ++ programOverrideArgs prog - } - - -runProgramInvocation :: Verbosity -> ProgramInvocation -> IO () -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Nothing - } = - rawSystemExit verbosity path args - -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Just inputStr, - progInvokeInputEncoding = encoding - } = do - (_, errors, exitCode) <- rawSystemStdInOut verbosity - path args - (Just input) False - when (exitCode /= ExitSuccess) $ - die errors - where - input = case encoding of - IOEncodingText -> (inputStr, False) - IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8 - -runProgramInvocation _ _ = - die "runProgramInvocation: not yet implemented for this form of invocation" - - -getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String -getProgramInvocationOutput verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Nothing, - progInvokeOutputEncoding = encoding - } = do - let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False - decode | utf8 = fromUTF8 . normaliseLineEndings - | otherwise = id - (output, errors, exitCode) <- rawSystemStdInOut verbosity - path args - Nothing utf8 - when (exitCode /= ExitSuccess) $ - die errors - return (decode output) - - -getProgramInvocationOutput _ _ = - die "getProgramInvocationOutput: not yet implemented for this form of invocation" - - --- | 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. --- --- It takes four template invocations corresponding to the simple, initial, --- middle and last invocations. If the number of args given is small enough --- that we can get away with just a single invocation then the simple one is --- used: --- --- > $ simple args --- --- If the number of args given means that we need to use multiple invocations --- then the templates for the initial, middle and last invocations are used: --- --- > $ initial args_0 --- > $ middle args_1 --- > $ middle args_2 --- > ... --- > $ final args_n --- -multiStageProgramInvocation - :: ProgramInvocation - -> (ProgramInvocation, ProgramInvocation, ProgramInvocation) - -> [String] - -> [ProgramInvocation] -multiStageProgramInvocation simple (initial, middle, final) args = - - let argSize inv = length (progInvokePath inv) - + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) - fixedArgSize = maximum (map argSize [simple, initial, middle, final]) - chunkSize = maxCommandLineSize - fixedArgSize - - in case splitChunks chunkSize args of - [] -> [ simple ] - - [c] -> [ simple `appendArgs` c ] - - [c,c'] -> [ initial `appendArgs` c ] - ++ [ final `appendArgs` c'] - - (c:cs) -> [ initial `appendArgs` c ] - ++ [ middle `appendArgs` c'| c' <- init cs ] - ++ [ final `appendArgs` c'| let c' = last cs ] - - where - inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as } - - splitChunks len = unfoldr $ \s -> - if null s then Nothing - else Just (chunk len s) - - chunk len (s:_) | length s >= len = error toolong - chunk len ss = chunk' [] len ss - - chunk' acc _ [] = (reverse acc,[]) - chunk' acc len (s:ss) - | len' < len = chunk' (s:acc) (len-len'-1) ss - | otherwise = (reverse acc, s:ss) - where len' = length s - - toolong = "multiStageProgramInvocation: a single program arg is larger " - ++ "than the maximum command line length!" - - ---FIXME: 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 :: Int -maxCommandLineSize = 30 * 1024 diff --git a/cabal/cabal/Distribution/Simple/Program/Script.hs b/cabal/cabal/Distribution/Simple/Program/Script.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Program/Script.hs +++ /dev/null @@ -1,105 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Script --- Copyright : Duncan Coutts 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides an library interface to the @hc-pkg@ program. --- Currently only GHC and LHC have hc-pkg programs. - -module Distribution.Simple.Program.Script ( - - invocationAsSystemScript, - invocationAsShellScript, - invocationAsBatchFile, - ) where - -import Distribution.Simple.Program.Run - ( ProgramInvocation(..) ) -import Distribution.System - ( OS(..) ) - -import Data.Maybe - ( maybeToList ) - --- | Generate a system script, either POSIX shell script or Windows batch file --- as appropriate for the given system. --- -invocationAsSystemScript :: OS -> ProgramInvocation -> String -invocationAsSystemScript Windows = invocationAsBatchFile -invocationAsSystemScript _ = invocationAsShellScript - - --- | Generate a POSIX shell script that invokes a program. --- -invocationAsShellScript :: ProgramInvocation -> String -invocationAsShellScript - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envExtra, - progInvokeCwd = mcwd, - progInvokeInput = minput - } = unlines $ - [ "#!/bin/sh" ] - ++ [ "export " ++ var ++ "=" ++ quote val - | (var,val) <- envExtra ] - ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ] - ++ [ (case minput of - Nothing -> "" - Just input -> "echo " ++ quote input ++ " | ") - ++ unwords (map quote $ path : args) ++ " \"$@\""] - - where - quote :: String -> String - quote s = "'" ++ escape s ++ "'" - - escape [] = [] - escape ('\'':cs) = "'\\''" ++ escape cs - escape (c :cs) = c : escape cs - - --- | Generate a Windows batch file that invokes a program. --- -invocationAsBatchFile :: ProgramInvocation -> String -invocationAsBatchFile - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envExtra, - progInvokeCwd = mcwd, - progInvokeInput = minput - } = unlines $ - [ "@echo off" ] - ++ [ "set " ++ var ++ "=" ++ escape val | (var,val) <- envExtra ] - ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ] - ++ case minput of - Nothing -> - [ path ++ concatMap (' ':) args ] - - Just input -> - [ "(" ] - ++ [ "echo " ++ escape line | line <- lines input ] - ++ [ ") | " - ++ "\"" ++ path ++ "\"" - ++ concatMap (\arg -> ' ':quote arg) args ] - - where - quote :: String -> String - quote s = "\"" ++ escapeQ s ++ "\"" - - escapeQ [] = [] - escapeQ ('"':cs) = "\"\"\"" ++ escapeQ cs - escapeQ (c :cs) = c : escapeQ cs - - escape [] = [] - escape ('|':cs) = "^|" ++ escape cs - escape ('<':cs) = "^<" ++ escape cs - escape ('>':cs) = "^>" ++ escape cs - escape ('&':cs) = "^&" ++ escape cs - escape ('(':cs) = "^(" ++ escape cs - escape (')':cs) = "^)" ++ escape cs - escape ('^':cs) = "^^" ++ escape cs - escape (c :cs) = c : escape cs diff --git a/cabal/cabal/Distribution/Simple/Program/Types.hs b/cabal/cabal/Distribution/Simple/Program/Types.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Program/Types.hs +++ /dev/null @@ -1,122 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Types --- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This provides an abstraction which deals with configuring and running --- programs. A 'Program' is a static notion of a known program. A --- 'ConfiguredProgram' is a 'Program' that has been found on the current --- machine and is ready to be run (possibly with some user-supplied default --- args). Configuring a program involves finding its location and if necessary --- finding its version. There's reasonable default behavior for trying to find --- \"foo\" in PATH, being able to override its location, etc. --- -module Distribution.Simple.Program.Types ( - -- * Program and functions for constructing them - Program(..), - internalProgram, - simpleProgram, - - -- * Configured program and related functions - ConfiguredProgram(..), - programPath, - ProgArg, - ProgramLocation(..), - ) where - -import Data.List (nub) -import System.FilePath (()) - -import Distribution.Simple.Utils - ( findProgramLocation, findFirstFile ) -import Distribution.Version - ( Version ) -import Distribution.Verbosity - ( Verbosity ) - --- | Represents a program which can be configured. -data Program = Program { - -- | The simple name of the program, eg. ghc - programName :: String, - - -- | A function to search for the program if it's location was not - -- specified by the user. Usually this will just be a - programFindLocation :: Verbosity -> 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. - programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version), - - -- | A function to do any additional configuration after we have - -- located the program (and perhaps identified its version). It is - -- allowed to return additional flags that will be passed to the - -- program on every invocation. - programPostConf :: Verbosity -> ConfiguredProgram -> IO [ProgArg] - } - -type ProgArg = String - -data ConfiguredProgram = ConfiguredProgram { - -- | Just the name again - programId :: String, - - -- | The version of this program, if it is known. - programVersion :: Maybe Version, - - -- | Default command-line args for this program. - -- These flags will appear first on the command line, so they can be - -- overridden by subsequent flags. - programDefaultArgs :: [String], - - -- | Override command-line args for this program. - -- These flags will appear last on the command line, so they override - -- all earlier flags. - programOverrideArgs :: [String], - - -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ - programLocation :: ProgramLocation - } deriving (Read, Show, Eq) - --- | Where a program was found. Also tells us whether it's specifed by user or --- not. This includes not just the path, but the program as well. -data ProgramLocation - = UserSpecified { locationPath :: FilePath } - -- ^The user gave the path to this program, - -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 - | FoundOnSystem { locationPath :: FilePath } - -- ^The location of the program, as located by searching PATH. - deriving (Read, Show, Eq) - --- | The full path of a configured program. -programPath :: ConfiguredProgram -> FilePath -programPath = locationPath . programLocation - --- | Make a simple named program. --- --- By default we'll just search for it in the path and not try to find the --- version name. You can override these behaviours if necessary, eg: --- --- > simpleProgram "foo" { programFindLocation = ... , programFindVersion ... } --- -simpleProgram :: String -> Program -simpleProgram name = Program { - programName = name, - programFindLocation = \v -> findProgramLocation v name, - programFindVersion = \_ _ -> return Nothing, - programPostConf = \_ _ -> return [] - } - --- | Make a simple 'internal' program; that is, one that was built as an --- executable already and is expected to be found in the build directory -internalProgram :: [FilePath] -> String -> Program -internalProgram paths name = Program { - programName = name, - programFindLocation = \_v -> - findFirstFile id [ path name | path <- nub paths ], - programFindVersion = \_ _ -> return Nothing, - programPostConf = \_ _ -> return [] - } - diff --git a/cabal/cabal/Distribution/Simple/Register.hs b/cabal/cabal/Distribution/Simple/Register.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Register.hs +++ /dev/null @@ -1,390 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Register --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module deals with registering and unregistering packages. There are a --- couple ways it can do this, one is to do it directly. Another is to generate --- a script that can be run later to do it. The idea here being that the user --- is shielded from the details of what command to use for package registration --- for a particular compiler. In practice this aspect was not especially --- 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 --- latter is occasionally handy, and will become more important when we try to --- build multi-package systems. --- --- This module does not delegate anything to the per-compiler modules but just --- 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, - - registerPackage, - generateRegistrationInfo, - inplaceInstalledPackageInfo, - absoluteInstalledPackageInfo, - generalInstalledPackageInfo, - ) where - -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) - , 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 Distribution.Simple.Compiler - ( compilerVersion, CompilerFlavor(..), compilerFlavor - , PackageDBStack, registrationPackageDB ) -import Distribution.Simple.Program - ( ConfiguredProgram, runProgramInvocation - , requireProgram, lookupProgram, ghcPkgProgram, lhcPkgProgram ) -import Distribution.Simple.Program.Script - ( invocationAsSystemScript ) -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import Distribution.Simple.Setup - ( RegisterFlags(..), CopyDest(..) - , fromFlag, fromFlagOrDefault, flagToMaybe ) -import Distribution.PackageDescription - ( PackageDescription(..), Library(..), BuildInfo(..), hcOptions ) -import Distribution.Package - ( Package(..), packageName, InstalledPackageId(..) ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, InstalledPackageInfo_(InstalledPackageInfo) - , showInstalledPackageInfo ) -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Simple.Utils - ( writeUTF8File, writeFileAtomic, setFileExecutable - , die, notice, setupMessage ) -import Distribution.System - ( OS(..), buildOS ) -import Distribution.Text - ( display ) -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 ) - -import Data.Maybe - ( isJust, fromMaybe, maybeToList ) -import Data.List - ( partition, nub ) - - --- ----------------------------------------------------------------------------- --- Registration - -register :: PackageDescription -> LocalBuildInfo - -> RegisterFlags -- ^Install in the user's database?; verbose - -> IO () -register pkg@PackageDescription { library = Just lib } - lbi@LocalBuildInfo { libraryConfig = Just clbi } regFlags - = do - - installedPkgInfo <- generateRegistrationInfo - verbosity pkg lib lbi clbi inplace distPref - - -- Three different modes: - case () of - _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo - | modeGenerateRegScript -> writeRegisterScript installedPkgInfo - | otherwise -> registerPackage verbosity - installedPkgInfo pkg lbi inplace packageDbs - - where - modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) - regFile = fromMaybe (display (packageId pkg) <.> "conf") - (fromFlag (regGenPkgConf regFlags)) - - modeGenerateRegScript = fromFlag (regGenScript regFlags) - - inplace = fromFlag (regInPlace regFlags) - -- FIXME: there's really no guarantee this will work. - -- registering into a totally different db stack can - -- fail if dependencies cannot be satisfied. - packageDbs = nub $ withPackageDB lbi - ++ maybeToList (flagToMaybe (regPackageDB regFlags)) - distPref = fromFlag (regDistPref regFlags) - verbosity = fromFlag (regVerbosity regFlags) - - writeRegistrationFile installedPkgInfo = do - notice verbosity ("Creating package registration file: " ++ regFile) - writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo) - - 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" - -register _ _ regFlags = notice verbosity "No package to register" - where - verbosity = fromFlag (regVerbosity regFlags) - - -generateRegistrationInfo :: Verbosity - -> PackageDescription - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Bool - -> FilePath - -> IO InstalledPackageInfo -generateRegistrationInfo verbosity pkg lib lbi clbi inplace distPref = do - --TODO: eliminate pwd! - pwd <- getCurrentDirectory - - --TODO: the method of setting the InstalledPackageId is compiler specific - -- this aspect should be delegated to a per-compiler helper. - let comp = compiler lbi - ipid <- - case compilerFlavor comp of - GHC | compilerVersion comp >= Version [6,11] [] -> do - s <- GHC.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 - - return installedPkgInfo{ IPI.installedPackageId = ipid } - - -registerPackage :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo - -> Bool - -> PackageDBStack - -> IO () -registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do - setupMessage verbosity "Registering" (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)" - _ -> die "Registering is not implemented for this compiler" - - -writeHcPkgRegisterScript :: Verbosity - -> InstalledPackageInfo - -> ConfiguredProgram - -> PackageDBStack - -> IO () -writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDbs = do - let invocation = HcPkg.reregisterInvocation hcPkg Verbosity.normal - packageDbs (Right installedPkgInfo) - regScript = invocationAsSystemScript buildOS invocation - - notice verbosity ("Creating package registration script: " ++ regScriptFileName) - writeUTF8File regScriptFileName regScript - setFileExecutable regScriptFileName - -regScriptFileName :: FilePath -regScriptFileName = case buildOS of - Windows -> "register.bat" - _ -> "register.sh" - - --- ----------------------------------------------------------------------------- --- Making the InstalledPackageInfo - --- | Construct 'InstalledPackageInfo' for a library in a package, given a set --- of installation directories. --- -generalInstalledPackageInfo - :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to - -- absolute paths. - -> PackageDescription - -> Library - -> ComponentLocalBuildInfo - -> InstallDirs FilePath - -> InstalledPackageInfo -generalInstalledPackageInfo adjustRelIncDirs pkg lib clbi installDirs = - InstalledPackageInfo { - --TODO: do not open-code this conversion from PackageId to InstalledPackageId - IPI.installedPackageId = InstalledPackageId (display (packageId pkg)), - IPI.sourcePackageId = packageId pkg, - IPI.license = license pkg, - IPI.copyright = copyright pkg, - IPI.maintainer = maintainer pkg, - IPI.author = author pkg, - IPI.stability = stability pkg, - IPI.homepage = homepage pkg, - IPI.pkgUrl = pkgUrl pkg, - IPI.synopsis = synopsis pkg, - IPI.description = description pkg, - IPI.category = category pkg, - IPI.exposed = libExposed lib, - IPI.exposedModules = exposedModules lib, - IPI.hiddenModules = otherModules bi, - IPI.trusted = False, - IPI.importDirs = [ libdir installDirs | hasModules ], - IPI.libraryDirs = if hasLibrary - then libdir installDirs : extraLibDirs bi - else extraLibDirs bi, - IPI.hsLibraries = [ "HS" ++ display (packageId pkg) | hasLibrary ], - IPI.extraLibraries = extraLibs bi, - IPI.extraGHCiLibraries = [], - 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. - IPI.ldOptions = ldOptions bi, - IPI.frameworkDirs = [], - IPI.frameworks = frameworks bi, - IPI.haddockInterfaces = [haddockdir installDirs haddockName pkg], - IPI.haddockHTMLs = [htmldir installDirs] - } - where - bi = libBuildInfo lib - (absinc, relinc) = partition isAbsolute (includeDirs bi) - hasModules = not $ null (exposedModules lib) - && null (otherModules bi) - hasLibrary = hasModules || not (null (cSources bi)) - - --- | Construct 'InstalledPackageInfo' for a library that is inplace in the --- build tree. --- --- This function knows about the layout of inplace packages. --- -inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree - -> FilePath -- ^ location of the dist tree - -> PackageDescription - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> InstalledPackageInfo -inplaceInstalledPackageInfo inplaceDir distPref pkg lib lbi clbi = - generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib clbi installDirs - where - adjustReativeIncludeDirs = map (inplaceDir ) - installDirs = - (absoluteInstallDirs pkg lbi NoCopyDest) { - libdir = inplaceDir buildDir lbi, - datadir = inplaceDir, - datasubdir = distPref, - docdir = inplaceDocdir, - htmldir = inplaceHtmldir, - haddockdir = inplaceHtmldir - } - inplaceDocdir = inplaceDir distPref "doc" - inplaceHtmldir = inplaceDocdir "html" display (packageName pkg) - - --- | Construct 'InstalledPackageInfo' for the final install location of a --- library package. --- --- This function knows about the layout of installed packages. --- -absoluteInstalledPackageInfo :: PackageDescription - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> InstalledPackageInfo -absoluteInstalledPackageInfo pkg lib lbi clbi = - generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib 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 = absoluteInstallDirs pkg lbi NoCopyDest - --- ----------------------------------------------------------------------------- --- Unregistration - -unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () -unregister pkg lbi regFlags = do - let pkgid = packageId pkg - genScript = fromFlag (regGenScript regFlags) - verbosity = fromFlag (regVerbosity regFlags) - packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) - (regPackageDB regFlags) - installDirs = absoluteInstallDirs pkg lbi NoCopyDest - 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 - (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") - -unregScriptFileName :: FilePath -unregScriptFileName = case buildOS of - Windows -> "unregister.bat" - _ -> "unregister.sh" diff --git a/cabal/cabal/Distribution/Simple/Setup.hs b/cabal/cabal/Distribution/Simple/Setup.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Setup.hs +++ /dev/null @@ -1,1584 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Setup --- Copyright : Isaac Jones 2003-2004 --- Duncan Coutts 2007 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is a big module, but not very complicated. The code is very regular --- and repetitive. It defines the command line interface for all the Cabal --- commands. For each command (like @configure@, @build@ etc) it defines a type --- that holds all the flags, the default set of flags and a 'CommandUI' that --- maps command line flags to and from the corresponding flags type. --- --- All the flags types are instances of 'Monoid', see --- --- for an explanation. --- --- The types defined here get used in the front end and especially in --- @cabal-install@ which has to do quite a bit of manipulating sets of command --- line flags. --- --- This is actually relatively nice, it works quite well. The main change it --- needs is to unify it with the code for managing sets of fields that can be --- 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. -} - -module Distribution.Simple.Setup ( - - GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, - ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, - CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, - InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, - HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, - HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, - BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, - buildVerbose, - CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, - RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, - unregisterCommand, - SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, - TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, - TestShowDetails(..), - CopyDest(..), - configureArgs, configureOptions, configureCCompiler, configureLinker, - installDirsOptions, - - defaultDistPref, - - Flag(..), - toFlag, - fromFlag, - fromFlagOrDefault, - flagToMaybe, - flagToList, - boolOpt, boolOpt', trueArg, falseArg, optionVerbosity ) where - -import Distribution.Compiler () -import Distribution.ReadE -import Distribution.Text - ( Text(..), display ) -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp -import Distribution.Package ( Dependency(..) ) -import Distribution.PackageDescription - ( FlagName(..), FlagAssignment ) -import Distribution.Simple.Command hiding (boolOpt, boolOpt') -import qualified Distribution.Simple.Command as Command -import Distribution.Simple.Compiler - ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..) - , OptimisationLevel(..), flagToOptimisationLevel ) -import Distribution.Simple.Utils - ( wrapLine, lowercase, intercalate ) -import Distribution.Simple.Program (Program(..), ProgramConfiguration, - requireProgram, - programInvocation, progInvokePath, progInvokeArgs, - knownPrograms, - addKnownProgram, emptyProgramConfiguration, - haddockProgram, ghcProgram, gccProgram, ldProgram) -import Distribution.Simple.InstallDirs - ( InstallDirs(..), CopyDest(..), - PathTemplate, toPathTemplate, fromPathTemplate ) -import Distribution.Verbosity - -import Data.List ( sort ) -import Data.Char ( isSpace, isAlpha ) -import Data.Monoid ( Monoid(..) ) - --- FIXME Not sure where this should live -defaultDistPref :: FilePath -defaultDistPref = "dist" - --- ------------------------------------------------------------ --- * Flag type --- ------------------------------------------------------------ - --- | All flags are monoids, they come in two flavours: --- --- 1. list flags eg --- --- > --ghc-option=foo --ghc-option=bar --- --- gives us all the values ["foo", "bar"] --- --- 2. singular value flags, eg: --- --- > --enable-foo --disable-foo --- --- gives us Just False --- So this Flag type is for the latter singular kind of flag. --- 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) - -instance Functor Flag where - fmap f (Flag x) = Flag (f x) - fmap _ NoFlag = NoFlag - -instance Monoid (Flag a) where - mempty = NoFlag - _ `mappend` f@(Flag _) = f - f `mappend` NoFlag = f - -instance Bounded a => Bounded (Flag a) where - minBound = toFlag minBound - maxBound = toFlag maxBound - -instance Enum a => Enum (Flag a) where - fromEnum = fromEnum . fromFlag - toEnum = toFlag . toEnum - enumFrom (Flag a) = map toFlag . enumFrom $ a - enumFrom _ = [] - enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b - enumFromThen _ _ = [] - enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b - enumFromTo _ _ = [] - enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c - enumFromThenTo _ _ _ = [] - -toFlag :: a -> Flag a -toFlag = Flag - -fromFlag :: Flag a -> a -fromFlag (Flag x) = x -fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" - -fromFlagOrDefault :: a -> Flag a -> a -fromFlagOrDefault _ (Flag x) = x -fromFlagOrDefault def NoFlag = def - -flagToMaybe :: Flag a -> Maybe a -flagToMaybe (Flag x) = Just x -flagToMaybe NoFlag = Nothing - -flagToList :: Flag a -> [a] -flagToList (Flag x) = [x] -flagToList NoFlag = [] - --- ------------------------------------------------------------ --- * Global flags --- ------------------------------------------------------------ - --- In fact since individual flags types are monoids and these are just sets of --- flags then they are also monoids pointwise. This turns out to be really --- useful. The mempty is the set of empty flags and mappend allows us to --- override specific flags. For example we can start with default flags and --- override with the ones we get from a file or the command line, or both. - --- | Flags that apply at the top level, not to any sub-command. -data GlobalFlags = GlobalFlags { - globalVersion :: Flag Bool, - globalNumericVersion :: Flag Bool - } - -defaultGlobalFlags :: GlobalFlags -defaultGlobalFlags = GlobalFlags { - globalVersion = Flag False, - globalNumericVersion = Flag False - } - -globalCommand :: CommandUI GlobalFlags -globalCommand = CommandUI { - commandName = "", - commandSynopsis = "", - commandUsage = \_ -> - "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" - ++ " " ++ pname ++ " COMMAND --help\n\n" - ++ "Typical steps for installing Cabal packages:\n" - ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" - | x <- ["configure", "build", "install"]], - commandDefaultFlags = defaultGlobalFlags, - commandOptions = \_ -> - [option ['V'] ["version"] - "Print version information" - globalVersion (\v flags -> flags { globalVersion = v }) - trueArg - ,option [] ["numeric-version"] - "Print just the version number" - globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) - trueArg - ] - } - -emptyGlobalFlags :: GlobalFlags -emptyGlobalFlags = mempty - -instance Monoid GlobalFlags where - mempty = GlobalFlags { - globalVersion = mempty, - globalNumericVersion = mempty - } - mappend a b = GlobalFlags { - globalVersion = combine globalVersion, - globalNumericVersion = combine globalNumericVersion - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Config flags --- ------------------------------------------------------------ - --- | Flags to @configure@ command -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. - -- when we change UserHooks next we should pass the initial - -- ProgramConfiguration directly and not via ConfigFlags - configPrograms :: ProgramConfiguration, -- ^All programs that cabal may run - - configProgramPaths :: [(String, FilePath)], -- ^user specifed programs paths - configProgramArgs :: [(String, [String])], -- ^user specifed programs args - configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the compiler, sugh as GHC or Hugs. - configHcPath :: Flag FilePath, -- ^given compiler location - configHcPkg :: Flag FilePath, -- ^given hc-pkg location - configVanillaLib :: Flag Bool, -- ^Enable vanilla library - configProfLib :: Flag Bool, -- ^Enable profiling in the library - configSharedLib :: Flag Bool, -- ^Build shared library - configDynExe :: Flag Bool, -- ^Enable dynamic linking of the executables. - configProfExe :: Flag Bool, -- ^Enable profiling in the executables. - configConfigureArgs :: [String], -- ^Extra arguments to @configure@ - configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. - configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix. - configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix. - configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation paths - configScratchDir :: Flag FilePath, - configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries - configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files - - configDistPref :: Flag FilePath, -- ^"dist" prefix - configVerbosity :: Flag Verbosity, -- ^verbosity level - configUserInstall :: Flag Bool, -- ^The --user\/--global flag - configPackageDB :: Flag PackageDB, -- ^Which package DB to use - configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi - configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC - configStripExes :: Flag Bool, -- ^Enable executable stripping - configConstraints :: [Dependency], -- ^Additional constraints for - -- dependencies - configConfigurationsFlags :: FlagAssignment, - configTests :: Flag Bool, -- ^Enable test suite compilation - configLibCoverage :: Flag Bool -- ^ Enable test suite program coverage - } - deriving (Read,Show) - -defaultConfigFlags :: ProgramConfiguration -> ConfigFlags -defaultConfigFlags progConf = emptyConfigFlags { - configPrograms = progConf, - configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, - configVanillaLib = Flag True, - configProfLib = Flag False, - configSharedLib = Flag False, - configDynExe = Flag False, - configProfExe = Flag False, - configOptimization = Flag NormalOptimisation, - configProgPrefix = Flag (toPathTemplate ""), - configProgSuffix = Flag (toPathTemplate ""), - configDistPref = Flag defaultDistPref, - configVerbosity = Flag normal, - configUserInstall = Flag False, --TODO: reverse this - configGHCiLib = Flag True, - configSplitObjs = Flag False, -- takes longer, so turn off by default - configStripExes = Flag True, - configTests = Flag False, - configLibCoverage = Flag False - } - -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 = - configureOptions showOrParseArgs - ++ programConfigurationPaths progConf showOrParseArgs - configProgramPaths (\v fs -> fs { configProgramPaths = v }) - ++ programConfigurationOptions progConf showOrParseArgs - configProgramArgs (\v fs -> fs { configProgramArgs = v }) - - -configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] -configureOptions showOrParseArgs = - [optionVerbosity configVerbosity (\v flags -> flags { configVerbosity = v }) - ,optionDistPref - configDistPref (\d flags -> flags { configDistPref = d }) - showOrParseArgs - - ,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")]) - - ,option "w" ["with-compiler"] - "give the path to a particular compiler" - configHcPath (\v flags -> flags { configHcPath = v }) - (reqArgFlag "PATH") - - ,option "" ["with-hc-pkg"] - "give the path to the package tool" - configHcPkg (\v flags -> flags { configHcPkg = v }) - (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"] - "prefix to be applied to installed executables" - configProgPrefix - (\v flags -> flags { configProgPrefix = v }) - (reqPathTemplateArgFlag "PREFIX") - - ,option "" ["program-suffix"] - "suffix to be applied to installed executables" - configProgSuffix (\v flags -> flags { configProgSuffix = v } ) - (reqPathTemplateArgFlag "SUFFIX") - - ,option "" ["library-vanilla"] - "Vanilla libraries" - configVanillaLib (\v flags -> flags { configVanillaLib = v }) - (boolOpt [] []) - - ,option "p" ["library-profiling"] - "Library profiling" - configProfLib (\v flags -> flags { configProfLib = v }) - (boolOpt "p" []) - - ,option "" ["shared"] - "Shared library" - configSharedLib (\v flags -> flags { configSharedLib = v }) - (boolOpt [] []) - - ,option "" ["executable-dynamic"] - "Executable dynamic linking" - configDynExe (\v flags -> flags { configDynExe = v }) - (boolOpt [] []) - - ,option "" ["executable-profiling"] - "Executable profiling" - configProfExe (\v flags -> flags { configProfExe = v }) - (boolOpt [] []) - - ,multiOption "optimization" - configOptimization (\v flags -> flags { configOptimization = v }) - [optArg' "n" (Flag . flagToOptimisationLevel) - (\f -> case f of - Flag NoOptimisation -> [] - Flag NormalOptimisation -> [Nothing] - Flag MaximumOptimisation -> [Just "2"] - _ -> []) - "O" ["enable-optimization","enable-optimisation"] - "Build with optimization (n is 0--2, default is 1)", - noArg (Flag NoOptimisation) [] - ["disable-optimization","disable-optimisation"] - "Build without optimization" - ] - - ,option "" ["library-for-ghci"] - "compile library for use with GHCi" - configGHCiLib (\v flags -> flags { configGHCiLib = v }) - (boolOpt [] []) - - ,option "" ["split-objs"] - "split library into smaller objects to reduce binary sizes (GHC 6.6+)" - configSplitObjs (\v flags -> flags { configSplitObjs = v }) - (boolOpt [] []) - - ,option "" ["executable-stripping"] - "strip executables upon installation to reduce binary sizes" - configStripExes (\v flags -> flags { configStripExes = v }) - (boolOpt [] []) - - ,option "" ["configure-option"] - "Extra option for configure" - configConfigureArgs (\v flags -> flags { configConfigureArgs = v }) - (reqArg' "OPT" (\x -> [x]) id) - - ,option "" ["user-install"] - "doing a per-user installation" - configUserInstall (\v flags -> flags { configUserInstall = v }) - (boolOpt' ([],["user"]) ([], ["global"])) - - ,option "" ["package-db"] - "Use a specific package database (to satisfy dependencies and register in)" - configPackageDB (\v flags -> flags { configPackageDB = v }) - (reqArg' "PATH" (Flag . SpecificPackageDB) - (\f -> case f of - Flag (SpecificPackageDB db) -> [db] - _ -> [])) - - ,option "f" ["flags"] - "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." - configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v }) - (reqArg' "FLAGS" readFlagList showFlagList) - - ,option "" ["extra-include-dirs"] - "A list of directories to search for header files" - configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-lib-dirs"] - "A list of directories to search for external libraries" - configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - ,option "" ["constraint"] - "A list of additional constraints on the dependencies." - configConstraints (\v flags -> flags { configConstraints = v}) - (reqArg "DEPENDENCY" - (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) - (map (\x -> display x))) - ,option "" ["tests"] - "dependency checking and compilation for test suites listed in the package description file." - configTests (\v flags -> flags { configTests = v }) - (boolOpt [] []) - ,option "" ["library-coverage"] - "build library and test suites with Haskell Program Coverage enabled. (GHC only)" - configLibCoverage (\v flags -> flags { configLibCoverage = v }) - (boolOpt [] []) - ] - where - readFlagList :: String -> FlagAssignment - readFlagList = map tagWithValue . words - where tagWithValue ('-':fname) = (FlagName (lowercase fname), False) - tagWithValue fname = (FlagName (lowercase fname), True) - - showFlagList :: FlagAssignment -> [String] - showFlagList fs = [ if not set then '-':fname else fname - | (FlagName fname, set) <- fs] - - liftInstallDirs = - liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v }) - - reqPathTemplateArgFlag title _sf _lf d get set = - reqArgFlag title _sf _lf d - (fmap fromPathTemplate . get) (set . fmap toPathTemplate) - -installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] -installDirsOptions = - [ option "" ["prefix"] - "bake this prefix in preparation of installation" - prefix (\v flags -> flags { prefix = v }) - installDirArg - - , option "" ["bindir"] - "installation directory for executables" - bindir (\v flags -> flags { bindir = v }) - installDirArg - - , option "" ["libdir"] - "installation directory for libraries" - libdir (\v flags -> flags { libdir = v }) - installDirArg - - , option "" ["libsubdir"] - "subdirectory of libdir in which libs are installed" - libsubdir (\v flags -> flags { libsubdir = v }) - installDirArg - - , option "" ["libexecdir"] - "installation directory for program executables" - libexecdir (\v flags -> flags { libexecdir = v }) - installDirArg - - , option "" ["datadir"] - "installation directory for read-only data" - datadir (\v flags -> flags { datadir = v }) - installDirArg - - , option "" ["datasubdir"] - "subdirectory of datadir in which data files are installed" - datasubdir (\v flags -> flags { datasubdir = v }) - installDirArg - - , option "" ["docdir"] - "installation directory for documentation" - docdir (\v flags -> flags { docdir = v }) - installDirArg - - , option "" ["htmldir"] - "installation directory for HTML documentation" - htmldir (\v flags -> flags { htmldir = v }) - installDirArg - - , option "" ["haddockdir"] - "installation directory for haddock interfaces" - haddockdir (\v flags -> flags { haddockdir = v }) - installDirArg - ] - where - installDirArg _sf _lf d get set = - reqArgFlag "DIR" _sf _lf d - (fmap fromPathTemplate . get) (set . fmap toPathTemplate) - -emptyConfigFlags :: ConfigFlags -emptyConfigFlags = mempty - -instance Monoid ConfigFlags where - mempty = ConfigFlags { - configPrograms = error "FIXME: remove configPrograms", - configProgramPaths = mempty, - configProgramArgs = mempty, - configHcFlavor = mempty, - configHcPath = mempty, - configHcPkg = mempty, - configVanillaLib = mempty, - configProfLib = mempty, - configSharedLib = mempty, - configDynExe = mempty, - configProfExe = mempty, - configConfigureArgs = mempty, - configOptimization = mempty, - configProgPrefix = mempty, - configProgSuffix = mempty, - configInstallDirs = mempty, - configScratchDir = mempty, - configDistPref = mempty, - configVerbosity = mempty, - configUserInstall = mempty, - configPackageDB = mempty, - configGHCiLib = mempty, - configSplitObjs = mempty, - configStripExes = mempty, - configExtraLibDirs = mempty, - configConstraints = mempty, - configExtraIncludeDirs = mempty, - configConfigurationsFlags = mempty, - configTests = mempty, - configLibCoverage = mempty - } - mappend a b = ConfigFlags { - configPrograms = configPrograms b, - configProgramPaths = combine configProgramPaths, - configProgramArgs = combine configProgramArgs, - configHcFlavor = combine configHcFlavor, - configHcPath = combine configHcPath, - configHcPkg = combine configHcPkg, - configVanillaLib = combine configVanillaLib, - configProfLib = combine configProfLib, - configSharedLib = combine configSharedLib, - configDynExe = combine configDynExe, - configProfExe = combine configProfExe, - configConfigureArgs = combine configConfigureArgs, - configOptimization = combine configOptimization, - configProgPrefix = combine configProgPrefix, - configProgSuffix = combine configProgSuffix, - configInstallDirs = combine configInstallDirs, - configScratchDir = combine configScratchDir, - configDistPref = combine configDistPref, - configVerbosity = combine configVerbosity, - configUserInstall = combine configUserInstall, - configPackageDB = combine configPackageDB, - configGHCiLib = combine configGHCiLib, - configSplitObjs = combine configSplitObjs, - configStripExes = combine configStripExes, - configExtraLibDirs = combine configExtraLibDirs, - configConstraints = combine configConstraints, - configExtraIncludeDirs = combine configExtraIncludeDirs, - configConfigurationsFlags = combine configConfigurationsFlags, - configTests = combine configTests, - configLibCoverage = combine configLibCoverage - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Copy flags --- ------------------------------------------------------------ - --- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity) -data CopyFlags = CopyFlags { - copyDest :: Flag CopyDest, - copyDistPref :: Flag FilePath, - copyVerbosity :: Flag Verbosity - } - deriving Show - -defaultCopyFlags :: CopyFlags -defaultCopyFlags = CopyFlags { - copyDest = Flag NoCopyDest, - copyDistPref = Flag defaultDistPref, - 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" - ++ "Without the --destdir flag, configure determines location.\n" - options showOrParseArgs = - [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v }) - - ,optionDistPref - copyDistPref (\d flags -> flags { copyDistPref = d }) - showOrParseArgs - - ,option "" ["destdir"] - "directory to copy files to, prepended to installation directories" - copyDest (\v flags -> flags { copyDest = v }) - (reqArg "DIR" (succeedReadE (Flag . CopyTo)) - (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) - ] - -emptyCopyFlags :: CopyFlags -emptyCopyFlags = mempty - -instance Monoid CopyFlags where - mempty = CopyFlags { - copyDest = mempty, - copyDistPref = mempty, - copyVerbosity = mempty - } - mappend a b = CopyFlags { - copyDest = combine copyDest, - copyDistPref = combine copyDistPref, - copyVerbosity = combine copyVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Install flags --- ------------------------------------------------------------ - --- | Flags to @install@: (package db, verbosity) -data InstallFlags = InstallFlags { - installPackageDB :: Flag PackageDB, - installDistPref :: Flag FilePath, - installUseWrapper :: Flag Bool, - installInPlace :: Flag Bool, - installVerbosity :: Flag Verbosity - } - deriving Show - -defaultInstallFlags :: InstallFlags -defaultInstallFlags = InstallFlags { - installPackageDB = NoFlag, - installDistPref = Flag defaultDistPref, - 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" - ++ "specified in the configure step, use the copy command.\n" - options showOrParseArgs = - [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v }) - ,optionDistPref - installDistPref (\d flags -> flags { installDistPref = d }) - showOrParseArgs - - ,option "" ["inplace"] - "install the package in the install subdirectory of the dist prefix, so it can be used without being installed" - installInPlace (\v flags -> flags { installInPlace = v }) - trueArg - - ,option "" ["shell-wrappers"] - "using shell script wrappers around executables" - installUseWrapper (\v flags -> flags { installUseWrapper = v }) - (boolOpt [] []) - - ,option "" ["package-db"] "" - installPackageDB (\v flags -> flags { installPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "upon configuration register this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default) upon configuration register this package in the system-wide package database")]) - ] - -emptyInstallFlags :: InstallFlags -emptyInstallFlags = mempty - -instance Monoid InstallFlags where - mempty = InstallFlags{ - installPackageDB = mempty, - installDistPref = mempty, - installUseWrapper = mempty, - installInPlace = mempty, - installVerbosity = mempty - } - mappend a b = InstallFlags{ - installPackageDB = combine installPackageDB, - installDistPref = combine installDistPref, - installUseWrapper = combine installUseWrapper, - installInPlace = combine installInPlace, - installVerbosity = combine installVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * SDist flags --- ------------------------------------------------------------ - --- | Flags to @sdist@: (snapshot, verbosity) -data SDistFlags = SDistFlags { - sDistSnapshot :: Flag Bool, - sDistDirectory :: Flag FilePath, - sDistDistPref :: Flag FilePath, - sDistVerbosity :: Flag Verbosity - } - deriving Show - -defaultSDistFlags :: SDistFlags -defaultSDistFlags = SDistFlags { - sDistSnapshot = Flag False, - sDistDirectory = mempty, - sDistDistPref = Flag defaultDistPref, - 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 = - [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v }) - ,optionDistPref - sDistDistPref (\d flags -> flags { sDistDistPref = d }) - showOrParseArgs - - ,option "" ["snapshot"] - "Produce a snapshot source distribution" - sDistSnapshot (\v flags -> flags { sDistSnapshot = v }) - trueArg - - ,option "" ["output-directory"] - "Generate a source distribution in the given directory" - sDistDirectory (\v flags -> flags { sDistDirectory = v }) - (reqArgFlag "DIR") - ] - -emptySDistFlags :: SDistFlags -emptySDistFlags = mempty - -instance Monoid SDistFlags where - mempty = SDistFlags { - sDistSnapshot = mempty, - sDistDirectory = mempty, - sDistDistPref = mempty, - sDistVerbosity = mempty - } - mappend a b = SDistFlags { - sDistSnapshot = combine sDistSnapshot, - sDistDirectory = combine sDistDirectory, - sDistDistPref = combine sDistDistPref, - sDistVerbosity = combine sDistVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Register flags --- ------------------------------------------------------------ - --- | Flags to @register@ and @unregister@: (user package, gen-script, --- in-place, verbosity) -data RegisterFlags = RegisterFlags { - regPackageDB :: Flag PackageDB, - regGenScript :: Flag Bool, - regGenPkgConf :: Flag (Maybe FilePath), - regInPlace :: Flag Bool, - regDistPref :: Flag FilePath, - regVerbosity :: Flag Verbosity - } - deriving Show - -defaultRegisterFlags :: RegisterFlags -defaultRegisterFlags = RegisterFlags { - regPackageDB = NoFlag, - regGenScript = Flag False, - regGenPkgConf = NoFlag, - regInPlace = Flag False, - regDistPref = Flag defaultDistPref, - 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 = - [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref - regDistPref (\d flags -> flags { regDistPref = d }) - showOrParseArgs - - ,option "" ["packageDB"] "" - regPackageDB (\v flags -> flags { regPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "upon registration, register this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default)upon registration, register this package in the system-wide package database")]) - - ,option "" ["inplace"] - "register the package in the build location, so it can be used without being installed" - regInPlace (\v flags -> flags { regInPlace = v }) - trueArg - - ,option "" ["gen-script"] - "instead of registering, generate a script to register later" - regGenScript (\v flags -> flags { regGenScript = v }) - trueArg - - ,option "" ["gen-pkg-config"] - "instead of registering, generate a package registration file" - regGenPkgConf (\v flags -> flags { regGenPkgConf = v }) - (optArg' "PKG" Flag flagToList) - ] - -unregisterCommand :: CommandUI RegisterFlags -unregisterCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options - where - name = "unregister" - shortDesc = "Unregister this package with the compiler." - longDesc = Nothing - options showOrParseArgs = - [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref - regDistPref (\d flags -> flags { regDistPref = d }) - showOrParseArgs - - ,option "" ["user"] "" - regPackageDB (\v flags -> flags { regPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "unregister this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default) unregister this package in the system-wide package database")]) - - ,option "" ["gen-script"] - "Instead of performing the unregister command, generate a script to unregister later" - regGenScript (\v flags -> flags { regGenScript = v }) - trueArg - ] - -emptyRegisterFlags :: RegisterFlags -emptyRegisterFlags = mempty - -instance Monoid RegisterFlags where - mempty = RegisterFlags { - regPackageDB = mempty, - regGenScript = mempty, - regGenPkgConf = mempty, - regInPlace = mempty, - regDistPref = mempty, - regVerbosity = mempty - } - mappend a b = RegisterFlags { - regPackageDB = combine regPackageDB, - regGenScript = combine regGenScript, - regGenPkgConf = combine regGenPkgConf, - regInPlace = combine regInPlace, - regDistPref = combine regDistPref, - regVerbosity = combine regVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * HsColour flags --- ------------------------------------------------------------ - -data HscolourFlags = HscolourFlags { - hscolourCSS :: Flag FilePath, - hscolourExecutables :: Flag Bool, - hscolourDistPref :: Flag FilePath, - hscolourVerbosity :: Flag Verbosity - } - deriving Show - -emptyHscolourFlags :: HscolourFlags -emptyHscolourFlags = mempty - -defaultHscolourFlags :: HscolourFlags -defaultHscolourFlags = HscolourFlags { - hscolourCSS = NoFlag, - hscolourExecutables = Flag False, - hscolourDistPref = Flag defaultDistPref, - hscolourVerbosity = Flag normal - } - -instance Monoid HscolourFlags where - mempty = HscolourFlags { - hscolourCSS = mempty, - hscolourExecutables = mempty, - hscolourDistPref = mempty, - hscolourVerbosity = mempty - } - mappend a b = HscolourFlags { - hscolourCSS = combine hscolourCSS, - hscolourExecutables = combine hscolourExecutables, - hscolourDistPref = combine hscolourDistPref, - hscolourVerbosity = combine hscolourVerbosity - } - 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 = - [optionVerbosity hscolourVerbosity (\v flags -> flags { hscolourVerbosity = v }) - ,optionDistPref - hscolourDistPref (\d flags -> flags { hscolourDistPref = d }) - showOrParseArgs - - ,option "" ["executables"] - "Run hscolour for Executables targets" - hscolourExecutables (\v flags -> flags { hscolourExecutables = v }) - trueArg - - ,option "" ["css"] - "Use a cascading style sheet" - hscolourCSS (\v flags -> flags { hscolourCSS = v }) - (reqArgFlag "PATH") - ] - --- ------------------------------------------------------------ --- * Haddock flags --- ------------------------------------------------------------ - -data HaddockFlags = HaddockFlags { - haddockProgramPaths :: [(String, FilePath)], - haddockProgramArgs :: [(String, [String])], - haddockHoogle :: Flag Bool, - haddockHtml :: Flag Bool, - haddockHtmlLocation :: Flag String, - haddockExecutables :: Flag Bool, - haddockInternal :: Flag Bool, - haddockCss :: Flag FilePath, - haddockHscolour :: Flag Bool, - haddockHscolourCss :: Flag FilePath, - haddockDistPref :: Flag FilePath, - haddockVerbosity :: Flag Verbosity - } - deriving Show - -defaultHaddockFlags :: HaddockFlags -defaultHaddockFlags = HaddockFlags { - haddockProgramPaths = mempty, - haddockProgramArgs = [], - haddockHoogle = Flag False, - haddockHtml = Flag False, - haddockHtmlLocation = NoFlag, - haddockExecutables = Flag False, - haddockInternal = Flag False, - haddockCss = NoFlag, - haddockHscolour = Flag False, - haddockHscolourCss = NoFlag, - haddockDistPref = Flag defaultDistPref, - haddockVerbosity = Flag normal - } - -haddockCommand :: CommandUI HaddockFlags -haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options - 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 - - ,option "" ["hoogle"] - "Generate a hoogle database" - haddockHoogle (\v flags -> flags { haddockHoogle = v }) - trueArg - - ,option "" ["html"] - "Generate HTML documentation (the default)" - haddockHtml (\v flags -> flags { haddockHtml = v }) - trueArg - - ,option "" ["html-location"] - "Location of HTML documentation for pre-requisite packages" - haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v }) - (reqArgFlag "URL") - - ,option "" ["executables"] - "Run haddock for Executables targets" - haddockExecutables (\v flags -> flags { haddockExecutables = 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 "" ["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") - ] - ++ programConfigurationPaths progConf ParseArgs - haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v}) - ++ programConfigurationOptions progConf ParseArgs - haddockProgramArgs (\v flags -> flags { haddockProgramArgs = v}) - progConf = addKnownProgram haddockProgram - $ addKnownProgram ghcProgram - $ emptyProgramConfiguration - -emptyHaddockFlags :: HaddockFlags -emptyHaddockFlags = mempty - -instance Monoid HaddockFlags where - mempty = HaddockFlags { - haddockProgramPaths = mempty, - haddockProgramArgs = mempty, - haddockHoogle = mempty, - haddockHtml = mempty, - haddockHtmlLocation = mempty, - haddockExecutables = mempty, - haddockInternal = mempty, - haddockCss = mempty, - haddockHscolour = mempty, - haddockHscolourCss = mempty, - haddockDistPref = mempty, - haddockVerbosity = mempty - } - mappend a b = HaddockFlags { - haddockProgramPaths = combine haddockProgramPaths, - haddockProgramArgs = combine haddockProgramArgs, - haddockHoogle = combine haddockHoogle, - haddockHtml = combine haddockHoogle, - haddockHtmlLocation = combine haddockHtmlLocation, - haddockExecutables = combine haddockExecutables, - haddockInternal = combine haddockInternal, - haddockCss = combine haddockCss, - haddockHscolour = combine haddockHscolour, - haddockHscolourCss = combine haddockHscolourCss, - haddockDistPref = combine haddockDistPref, - haddockVerbosity = combine haddockVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Clean flags --- ------------------------------------------------------------ - -data CleanFlags = CleanFlags { - cleanSaveConf :: Flag Bool, - cleanDistPref :: Flag FilePath, - cleanVerbosity :: Flag Verbosity - } - deriving Show - -defaultCleanFlags :: CleanFlags -defaultCleanFlags = CleanFlags { - cleanSaveConf = Flag False, - cleanDistPref = Flag defaultDistPref, - 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 = - [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) - ,optionDistPref - cleanDistPref (\d flags -> flags { cleanDistPref = d }) - showOrParseArgs - - ,option "s" ["save-configure"] - "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." - cleanSaveConf (\v flags -> flags { cleanSaveConf = v }) - trueArg - ] - -emptyCleanFlags :: CleanFlags -emptyCleanFlags = mempty - -instance Monoid CleanFlags where - mempty = CleanFlags { - cleanSaveConf = mempty, - cleanDistPref = mempty, - cleanVerbosity = mempty - } - mappend a b = CleanFlags { - cleanSaveConf = combine cleanSaveConf, - cleanDistPref = combine cleanDistPref, - cleanVerbosity = combine cleanVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Build flags --- ------------------------------------------------------------ - -data BuildFlags = BuildFlags { - buildProgramPaths :: [(String, FilePath)], - buildProgramArgs :: [(String, [String])], - buildDistPref :: Flag FilePath, - buildVerbosity :: Flag Verbosity - } - deriving Show - -{-# DEPRECATED buildVerbose "Use buildVerbosity instead" #-} -buildVerbose :: BuildFlags -> Verbosity -buildVerbose = fromFlagOrDefault normal . buildVerbosity - -defaultBuildFlags :: BuildFlags -defaultBuildFlags = BuildFlags { - buildProgramPaths = mempty, - buildProgramArgs = [], - buildDistPref = Flag defaultDistPref, - buildVerbosity = Flag normal - } - -buildCommand :: ProgramConfiguration -> CommandUI BuildFlags -buildCommand progConf = makeCommand name shortDesc longDesc defaultBuildFlags options - where - name = "build" - shortDesc = "Make this package ready for installation." - longDesc = Nothing - options showOrParseArgs = - optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v }) - : optionDistPref - buildDistPref (\d flags -> flags { buildDistPref = d }) - showOrParseArgs - - : programConfigurationPaths progConf showOrParseArgs - buildProgramPaths (\v flags -> flags { buildProgramPaths = v}) - - ++ programConfigurationOptions progConf showOrParseArgs - buildProgramArgs (\v flags -> flags { buildProgramArgs = v}) - -emptyBuildFlags :: BuildFlags -emptyBuildFlags = mempty - -instance Monoid BuildFlags where - mempty = BuildFlags { - buildProgramPaths = mempty, - buildProgramArgs = mempty, - buildVerbosity = mempty, - buildDistPref = mempty - } - mappend a b = BuildFlags { - buildProgramPaths = combine buildProgramPaths, - buildProgramArgs = combine buildProgramArgs, - buildVerbosity = combine buildVerbosity, - buildDistPref = combine buildDistPref - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Test flags --- ------------------------------------------------------------ - -data TestShowDetails = Never | Failures | Always - deriving (Eq, Ord, Enum, Bounded, Show) - -knownTestShowDetails :: [TestShowDetails] -knownTestShowDetails = [minBound..maxBound] - -instance Text TestShowDetails where - disp = Disp.text . lowercase . show - - parse = maybe Parse.pfail return . classify =<< ident - where - ident = Parse.munch1 (\c -> isAlpha c || c == '_' || c == '-') - classify str = lookup (lowercase str) enumMap - enumMap :: [(String, TestShowDetails)] - enumMap = [ (display x, x) - | x <- knownTestShowDetails ] - ---TODO: do we need this instance? -instance Monoid TestShowDetails where - mempty = Never - mappend a b = if a < b then b else a - -data TestFlags = TestFlags { - testDistPref :: Flag FilePath, - testVerbosity :: Flag Verbosity, - testHumanLog :: Flag PathTemplate, - 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 :: Flag [PathTemplate] - } - -defaultTestFlags :: TestFlags -defaultTestFlags = TestFlags { - testDistPref = Flag defaultDistPref, - testVerbosity = Flag normal, - testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log", - testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log", - testShowDetails = toFlag Failures, - testKeepTix = toFlag False, - testList = Flag [], - testOptions = Flag [] - } - -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 = - [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) - , optionDistPref - testDistPref (\d flags -> flags { testDistPref = d }) - showOrParseArgs - , option [] ["log"] - ("Log all test suite results to file (name template can use " - ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)") - testHumanLog (\v flags -> flags { testHumanLog = v }) - (reqArg' "TEMPLATE" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - , option [] ["machine-log"] - ("Produce a machine-readable log file (name template can use " - ++ "$pkgid, $compiler, $os, $arch, $result)") - testMachineLog (\v flags -> flags { testMachineLog = v }) - (reqArg' "TEMPLATE" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - , 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.") - testShowDetails (\v flags -> flags { testShowDetails = v }) - (reqArg "FILTER" - (readP_to_E (\_ -> "--show-details flag expects one of " - ++ intercalate ", " - (map display knownTestShowDetails)) - (fmap toFlag parse)) - (flagToList . fmap display)) - , option [] ["keep-tix-files"] - "keep .tix files for HPC between test runs" - testKeepTix (\v flags -> flags { testKeepTix = v}) - trueArg - , option [] ["test-options"] - ("give extra options to test executables " - ++ "(name templates can use $pkgid, $compiler, " - ++ "$os, $arch, $test-suite)") - testOptions (\v flags -> flags { testOptions = v }) - (reqArg' "TEMPLATES" (toFlag . map toPathTemplate . splitArgs) - (map fromPathTemplate . fromFlagOrDefault [])) - , option [] ["test-option"] - ("give extra option to test executables " - ++ "(no need to quote options containing spaces, " - ++ "name template can use $pkgid, $compiler, " - ++ "$os, $arch, $test-suite)") - testOptions (\v flags -> flags { testOptions = v }) - (reqArg' "TEMPLATE" (\x -> toFlag [toPathTemplate x]) - (map fromPathTemplate . fromFlagOrDefault [])) - ] - -emptyTestFlags :: TestFlags -emptyTestFlags = mempty - -instance Monoid TestFlags where - mempty = TestFlags { - testDistPref = mempty, - testVerbosity = mempty, - testHumanLog = mempty, - testMachineLog = mempty, - testShowDetails = mempty, - testKeepTix = mempty, - testList = mempty, - testOptions = mempty - } - mappend a b = TestFlags { - testDistPref = combine testDistPref, - testVerbosity = combine testVerbosity, - testHumanLog = combine testHumanLog, - testMachineLog = combine testMachineLog, - testShowDetails = combine testShowDetails, - testKeepTix = combine testKeepTix, - testList = combine testList, - testOptions = combine testOptions - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Shared options utils --- ------------------------------------------------------------ - -programFlagsDescription :: ProgramConfiguration -> String -programFlagsDescription progConf = - "The flags --with-PROG and --PROG-option(s) can be used with" - ++ " the following programs:" - ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort) - [ programName prog | (prog, _) <- knownPrograms progConf ] - ++ "\n" - -programConfigurationPaths - :: ProgramConfiguration - -> ShowOrParseArgs - -> (flags -> [(String, FilePath)]) - -> ([(String, FilePath)] -> (flags -> flags)) - -> [OptionField flags] -programConfigurationPaths progConf showOrParseArgs get set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [withProgramPath "PROG"] - ParseArgs -> map (withProgramPath . programName . fst) (knownPrograms progConf) - where - withProgramPath prog = - option "" ["with-" ++ prog] - ("give the path to " ++ prog) - get set - (reqArg' "PATH" (\path -> [(prog, path)]) - (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) - -programConfigurationOptions - :: ProgramConfiguration - -> ShowOrParseArgs - -> (flags -> [(String, [String])]) - -> ([(String, [String])] -> (flags -> flags)) - -> [OptionField flags] -programConfigurationOptions progConf showOrParseArgs get set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [programOptions "PROG", programOption "PROG"] - ParseArgs -> map (programOptions . programName . fst) (knownPrograms progConf) - ++ map (programOption . programName . fst) (knownPrograms progConf) - where - programOptions prog = - option "" [prog ++ "-options"] - ("give extra options to " ++ prog) - get set - (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) - - programOption prog = - option "" [prog ++ "-option"] - ("give an extra option to " ++ prog ++ - " (no need to quote options containing spaces)") - get set - (reqArg' "OPT" (\arg -> [(prog, [arg])]) - (\progArgs -> concat [ args | (prog', args) <- progArgs, prog==prog' ])) - - --- ------------------------------------------------------------ --- * GetOpt Utils --- ------------------------------------------------------------ - -boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -boolOpt = Command.boolOpt flagToMaybe Flag - -boolOpt' :: OptFlags -> OptFlags -> 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) - -reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> - (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b -reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList - -optionDistPref :: (flags -> Flag FilePath) - -> (Flag FilePath -> flags -> flags) - -> ShowOrParseArgs - -> OptionField flags -optionDistPref get set = \showOrParseArgs -> - option "" (distPrefFlagName showOrParseArgs) - ( "The directory where Cabal puts generated build files " - ++ "(default " ++ defaultDistPref ++ ")") - get set - (reqArgFlag "DIR") - where - distPrefFlagName ShowArgs = ["builddir"] - distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"] - -optionVerbosity :: (flags -> Flag Verbosity) - -> (Flag Verbosity -> flags -> flags) - -> OptionField flags -optionVerbosity get set = - option "v" ["verbose"] - "Control verbosity (n is 0--3, default verbosity level is 1)" - get set - (optArg "n" (fmap Flag flagToVerbosity) - (Flag verbose) -- default Value if no n is given - (fmap (Just . showForCabal) . flagToList)) - --- ------------------------------------------------------------ --- * Other Utils --- ------------------------------------------------------------ - --- | Arguments to pass to a @configure@ script, e.g. generated by --- @autoconf@. -configureArgs :: Bool -> ConfigFlags -> [String] -configureArgs bcHack flags - = hc_flag - ++ optFlag "with-hc-pkg" configHcPkg - ++ optFlag' "prefix" prefix - ++ optFlag' "bindir" bindir - ++ optFlag' "libdir" libdir - ++ optFlag' "libexecdir" libexecdir - ++ optFlag' "datadir" datadir - ++ configConfigureArgs flags - where - hc_flag = case (configHcFlavor flags, configHcPath flags) of - (_, Flag hc_path) -> [hc_flag_name ++ hc_path] - (Flag hc, NoFlag) -> [hc_flag_name ++ display hc] - (NoFlag,NoFlag) -> [] - hc_flag_name - --TODO kill off thic bc hack when defaultUserHooks is removed. - | bcHack = "--with-hc=" - | otherwise = "--with-compiler=" - optFlag name config_field = case config_field flags of - Flag p -> ["--" ++ name ++ "=" ++ p] - NoFlag -> [] - optFlag' name config_field = optFlag name (fmap fromPathTemplate - . config_field - . configInstallDirs) - -configureCCompiler :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String]) -configureCCompiler verbosity lbi = configureProg verbosity lbi gccProgram - -configureLinker :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String]) -configureLinker verbosity lbi = configureProg verbosity lbi ldProgram - -configureProg :: Verbosity -> ProgramConfiguration -> Program -> IO (FilePath, [String]) -configureProg verbosity programConfig prog = do - (p, _) <- requireProgram verbosity prog programConfig - let pInv = programInvocation p [] - return (progInvokePath pInv, progInvokeArgs pInv) - --- | Helper function to split a string into a list of arguments. --- It's supposed to handle quoted things sensibly, eg: --- --- > splitArgs "--foo=\"C:\Program Files\Bar\" --baz" --- > = ["--foo=C:\Program Files\Bar", "--baz"] --- -splitArgs :: String -> [String] -splitArgs = space [] - where - space :: String -> String -> [String] - space w [] = word w [] - space w ( c :s) - | isSpace c = word w (space [] s) - space w ('"':s) = string w s - space w s = nonstring w s - - string :: String -> String -> [String] - string w [] = word w [] - string w ('"':s) = space w s - string w ( c :s) = string (c:w) s - - nonstring :: String -> String -> [String] - nonstring w [] = word w [] - nonstring w ('"':s) = string w s - nonstring w ( c :s) = space (c:w) s - - word [] s = s - word w s = reverse w : s - --- The test cases kinda have to be rewritten from the ground up... :/ ---hunitTests :: [Test] ---hunitTests = --- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)] --- (flags, commands', unkFlags, ers) --- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"] --- in [TestLabel "very basic option parsing" $ TestList [ --- "getOpt flags" ~: "failed" ~: --- [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag, --- WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag] --- ~=? flags, --- "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands', --- "getOpt unknown opts" ~: "failed" ~: --- ["--unknown1", "--unknown2"] ~=? unkFlags, --- "getOpt errors" ~: "failed" ~: [] ~=? ers], --- --- TestLabel "test location of various compilers" $ TestList --- ["configure parsing for prefix and compiler flag" ~: "failed" ~: --- (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), [])) --- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"]) --- | (name, comp) <- m], --- --- TestLabel "find the package tool" $ TestList --- ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~: --- (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), [])) --- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, --- "--with-compiler=/foo/comp", "configure"]) --- | (name, comp) <- m], --- --- TestLabel "simpler commands" $ TestList --- [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag]) --- | (flag, flagCmd) <- [("build", BuildCmd), --- ("install", InstallCmd Nothing False), --- ("sdist", SDistCmd), --- ("register", RegisterCmd False)] --- ] --- ] - -{- Testing ideas: - * IO to look for hugs and hugs-pkg (which hugs, etc) - * quickCheck to test permutations of arguments - * what other options can we over-ride with a command-line flag? --} diff --git a/cabal/cabal/Distribution/Simple/SrcDist.hs b/cabal/cabal/Distribution/Simple/SrcDist.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/SrcDist.hs +++ /dev/null @@ -1,418 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.SrcDist --- Copyright : Simon Marlow 2004 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This handles the @sdist@ command. The module exports an 'sdist' action but --- also some of the phases that make it up so that other tools can use just the --- bits they need. In particular the preparation of the tree of files to go --- into the source tarball is separated from actually building the source --- tarball. --- --- The 'createArchive' action uses the external @tar@ program and assumes that --- 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. - -module Distribution.Simple.SrcDist ( - -- * The top level action - sdist, - - -- ** Parts of 'sdist' - printPackageProblems, - prepareTree, - createArchive, - - -- ** Snaphots - prepareSnapshotTree, - snapshotPackage, - snapshotVersion, - dateToSnapshotNumber, - ) where - -import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) - , TestSuite(..), TestSuiteInterface(..) ) -import Distribution.PackageDescription.Check - ( PackageCheck(..), checkConfiguredPackage, checkPackageFiles ) -import Distribution.Package - ( PackageIdentifier(pkgVersion), Package(..), packageVersion ) -import Distribution.ModuleName (ModuleName) -import qualified Distribution.ModuleName as ModuleName -import Distribution.Version - ( Version(versionBranch) ) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File - , installOrdinaryFile, installOrdinaryFiles, setFileExecutable - , findFile, findFileWithExtension, matchFileGlob - , withTempDirectory, defaultPackageDesc - , die, warn, notice, setupMessage ) -import Distribution.Simple.Setup (SDistFlags(..), fromFlag, flagToMaybe) -import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessComponent) -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), withComponentsLBI ) -import Distribution.Simple.BuildPaths ( autogenModuleName ) -import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram, - rawSystemProgram, tarProgram ) -import Distribution.Text - ( display ) - -import Control.Monad(when, unless) -import Data.Char (toLower) -import Data.List (partition, isPrefixOf) -import Data.Maybe (isNothing, catMaybes) -import System.Time (getClockTime, toCalendarTime, CalendarTime(..)) -import System.Directory - ( doesFileExist, Permissions(executable), getPermissions ) -import Distribution.Verbosity (Verbosity) -import System.FilePath - ( (), (<.>), takeDirectory, dropExtension, isAbsolute ) - --- |Create a source distribution. -sdist :: PackageDescription -- ^information from the tarball - -> Maybe LocalBuildInfo -- ^Information from configure - -> SDistFlags -- ^verbosity & snapshot - -> (FilePath -> FilePath) -- ^build prefix (temp dir) - -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) - -> IO () -sdist pkg mb_lbi flags mkTmpDir pps = do - - -- do some QA - printPackageProblems verbosity pkg - - when (isNothing mb_lbi) $ - warn verbosity "Cannot run preprocessors. Run 'configure' command first." - - date <- toCalendarTime =<< getClockTime - let pkg' | snapshot = snapshotPackage date pkg - | otherwise = pkg - - case flagToMaybe (sDistDirectory flags) of - Just targetDir -> do - generateSourceDir targetDir pkg' - notice verbosity $ "Source directory created: " ++ targetDir - - Nothing -> do - createDirectoryIfMissingVerbose verbosity True tmpTargetDir - withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do - let targetDir = tmpDir tarBallName pkg' - generateSourceDir targetDir pkg' - targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref - notice verbosity $ "Source tarball created: " ++ targzFile - - where - generateSourceDir targetDir pkg' = do - - setupMessage verbosity "Building source dist for" (packageId pkg') - prepareTree verbosity pkg' mb_lbi distPref targetDir pps - when snapshot $ - overwriteSnapshotPackageDesc verbosity pkg' targetDir - - verbosity = fromFlag (sDistVerbosity flags) - snapshot = fromFlag (sDistSnapshot flags) - - distPref = fromFlag $ sDistDistPref flags - targetPref = distPref - tmpTargetDir = mkTmpDir distPref - - --- |Prepare a directory tree of source files. -prepareTree :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> Maybe LocalBuildInfo - -> FilePath -- ^dist dir - -> FilePath -- ^source tree to populate - -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) - -> IO () -prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do - createDirectoryIfMissingVerbose verbosity True targetDir - - -- maybe move the library files into place - withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } -> - prepareDir verbosity pkg_descr distPref targetDir pps modules libBi - - -- move the executables into place - withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do - prepareDir verbosity pkg_descr distPref targetDir pps [] exeBi - srcMainFile <- do - ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) (dropExtension mainPath) - case ppFile of - Nothing -> findFile (hsSourceDirs exeBi) mainPath - Just pp -> return pp - copyFileTo verbosity targetDir srcMainFile - - -- move the test suites into place - withTest $ \t -> do - let bi = testBuildInfo t - prep = prepareDir verbosity pkg_descr distPref targetDir pps - case testInterface t of - TestSuiteExeV10 _ mainPath -> do - prep [] bi - srcMainFile <- do - ppFile <- findFileWithExtension (ppSuffixes pps) - (hsSourceDirs bi) - (dropExtension mainPath) - case ppFile of - Nothing -> findFile (hsSourceDirs bi) mainPath - Just pp -> return pp - copyFileTo verbosity targetDir srcMainFile - TestSuiteLibV09 _ m -> do - prep [m] bi - TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " ++ show tp - - flip mapM_ (dataFiles pkg_descr) $ \ filename -> do - files <- matchFileGlob (dataDir pkg_descr filename) - let dir = takeDirectory (dataDir pkg_descr filename) - createDirectoryIfMissingVerbose verbosity True (targetDir dir) - sequence_ [ installOrdinaryFile verbosity file (targetDir file) - | file <- files ] - - when (not (null (licenseFile pkg_descr))) $ - copyFileTo verbosity targetDir (licenseFile pkg_descr) - flip mapM_ (extraSrcFiles pkg_descr) $ \ fpath -> do - files <- matchFileGlob fpath - sequence_ - [ do copyFileTo verbosity targetDir file - -- preserve executable bit on extra-src-files like ./configure - perms <- getPermissions file - when (executable perms) --only checks user x bit - (setFileExecutable (targetDir file)) - | file <- files ] - - -- copy the install-include files - withLib $ \ l -> do - let lbi = libBuildInfo l - relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) - incs <- mapM (findInc relincdirs) (installIncludes lbi) - flip mapM_ incs $ \(_,fpath) -> - copyFileTo verbosity targetDir fpath - - -- 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 - let lbi' = lbi{ buildDir = targetDir buildDir lbi } - withComponentsLBI pkg_descr lbi' $ \c _ -> - preprocessComponent pkg_descr c lbi' True verbosity pps - _ -> return () - - -- setup isn't listed in the description file. - hsExists <- doesFileExist "Setup.hs" - lhsExists <- doesFileExist "Setup.lhs" - if hsExists then copyFileTo verbosity targetDir "Setup.hs" - else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs" - else writeUTF8File (targetDir "Setup.hs") $ unlines [ - "import Distribution.Simple", - "main = defaultMain"] - -- the description file itself - descFile <- defaultPackageDesc verbosity - installOrdinaryFile verbosity descFile (targetDir descFile) - - where - pkg_descr = mapAllBuildInfo filterAutogenModule pkg_descr0 - filterAutogenModule bi = bi { - otherModules = filter (/=autogenModule) (otherModules bi) - } - autogenModule = autogenModuleName pkg_descr0 - - findInc [] f = die ("can't find include file " ++ f) - findInc (d:ds) f = do - let path = (d f) - b <- doesFileExist path - if b then return (f,path) else findInc ds f - - -- We have to deal with all libs and executables, so we have local - -- versions of these functions that ignore the 'buildable' attribute: - withLib action = maybe (return ()) action (library pkg_descr) - withExe action = mapM_ action (executables pkg_descr) - withTest action = mapM_ action (testSuites pkg_descr) - --- | Prepare a directory tree of source files for a snapshot version. --- It is expected that the appropriate snapshot version has already been set --- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. --- -prepareSnapshotTree :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> Maybe LocalBuildInfo - -> FilePath -- ^dist dir - -> FilePath -- ^source tree to populate - -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) - -> IO () -prepareSnapshotTree verbosity pkg mb_lbi distPref targetDir pps = do - prepareTree verbosity pkg mb_lbi distPref targetDir pps - overwriteSnapshotPackageDesc verbosity pkg targetDir - -overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^source tree - -> IO () -overwriteSnapshotPackageDesc verbosity pkg targetDir = do - -- We could just writePackageDescription targetDescFile pkg_descr, - -- but that would lose comments and formatting. - descFile <- defaultPackageDesc verbosity - withUTF8FileContents descFile $ - writeUTF8File (targetDir descFile) - . unlines . map (replaceVersion (packageVersion pkg)) . lines - - where - replaceVersion :: Version -> String -> String - replaceVersion version line - | "version:" `isPrefixOf` map toLower line - = "version: " ++ display version - | otherwise = line - --- | Modifies a 'PackageDescription' by appending a snapshot number --- corresponding to the given date. --- -snapshotPackage :: CalendarTime -> PackageDescription -> PackageDescription -snapshotPackage date pkg = - pkg { - package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) } - } - where pkgid = packageId pkg - --- | Modifies a 'Version' by appending a snapshot number corresponding --- to the given date. --- -snapshotVersion :: CalendarTime -> Version -> Version -snapshotVersion date version = version { - versionBranch = versionBranch version - ++ [dateToSnapshotNumber date] - } - --- | Given a date produce a corresponding integer representation. --- For example given a date @18/03/2008@ produce the number @20080318@. --- -dateToSnapshotNumber :: CalendarTime -> Int -dateToSnapshotNumber date = year * 10000 - + month * 100 - + day - where - year = ctYear date - month = fromEnum (ctMonth date) + 1 - day = ctDay date - --- |Create an archive from a tree of source files, and clean up the tree. -createArchive :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from cabal file - -> Maybe LocalBuildInfo -- ^info from configure - -> FilePath -- ^source tree to archive - -> FilePath -- ^name of archive to create - -> IO FilePath - -createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do - let tarBallFilePath = targetPref tarBallName pkg_descr <.> "tar.gz" - - (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] - return tarBallFilePath - --- |Move the sources into place based on buildInfo -prepareDir :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^dist dir - -> FilePath -- ^TargetPrefix - -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) - -> [ModuleName] -- ^Exposed modules - -> BuildInfo - -> IO () -prepareDir verbosity _pkg _distPref inPref pps modules bi - = do let searchDirs = hsSourceDirs bi - sources <- sequence - [ let file = ModuleName.toFilePath module_ - in findFileWithExtension suffixes searchDirs file - >>= maybe (notFound module_) return - | module_ <- modules ++ otherModules bi ] - bootFiles <- sequence - [ let file = ModuleName.toFilePath module_ - fileExts = ["hs-boot", "lhs-boot"] - in findFileWithExtension fileExts (hsSourceDirs bi) file - | module_ <- modules ++ otherModules bi ] - - let allSources = sources ++ catMaybes bootFiles ++ cSources bi - installOrdinaryFiles verbosity inPref (zip (repeat []) allSources) - - where suffixes = ppSuffixes pps ++ ["hs", "lhs"] - notFound m = die $ "Error: Could not find module: " ++ display m - ++ " with any suffix: " ++ show suffixes - -copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () -copyFileTo verbosity dir file = do - let targetFile = dir file - createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) - installOrdinaryFile verbosity file targetFile - -printPackageProblems :: Verbosity -> PackageDescription -> IO () -printPackageProblems verbosity pkg_descr = do - ioChecks <- checkPackageFiles pkg_descr "." - let pureChecks = checkConfiguredPackage pkg_descr - isDistError (PackageDistSuspicious _) = False - isDistError _ = True - (errors, warnings) = partition isDistError (pureChecks ++ ioChecks) - unless (null errors) $ - notice verbosity $ "Distribution quality errors:\n" - ++ unlines (map explanation errors) - unless (null warnings) $ - notice verbosity $ "Distribution quality warnings:\n" - ++ unlines (map explanation warnings) - unless (null errors) $ - notice verbosity - "Note: the public hackage server would reject this package." - ------------------------------------------------------------- - --- | The name of the tarball without extension --- -tarBallName :: PackageDescription -> String -tarBallName = display . packageId - -mapAllBuildInfo :: (BuildInfo -> BuildInfo) - -> (PackageDescription -> PackageDescription) -mapAllBuildInfo f pkg = pkg { - library = fmap mapLibBi (library pkg), - executables = fmap mapExeBi (executables pkg) - } - where - mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) } - mapExeBi exe = exe { buildInfo = f (buildInfo exe) } diff --git a/cabal/cabal/Distribution/Simple/Test.hs b/cabal/cabal/Distribution/Simple/Test.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Test.hs +++ /dev/null @@ -1,486 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Test --- Copyright : Thomas Tuegel 2010 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is the entry point into testing a built package. It performs the --- \"@.\/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 - , runTests - , writeSimpleTestStub - , stubFilePath - , stubName - , PackageLog(..) - , TestSuiteLog(..) - , Case(..) - , 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 ( doHpcMarkup, findTixFiles, tixDir ) -import Distribution.Simple.InstallDirs - ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) - , substPathTemplate , toPathTemplate, PathTemplate ) -import qualified Distribution.Simple.LocalBuildInfo as LBI - ( LocalBuildInfo(..) ) -import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag ) -import Distribution.Simple.Utils ( die, notice ) -import qualified Distribution.TestSuite as TestSuite - ( Test, Result(..), ImpureTestable(..), TestOptions(..), Options(..) ) -import Distribution.Text -import Distribution.Verbosity ( normal, Verbosity ) -import Distribution.System ( buildPlatform, Platform ) - -import Control.Exception ( bracket ) -import Control.Monad ( when, liftM, unless, filterM ) -import Data.Char ( toUpper ) -import Data.Monoid ( mempty ) -import System.Directory - ( createDirectoryIfMissing, doesFileExist, getCurrentDirectory - , removeFile, getDirectoryContents ) -import System.Environment ( getEnvironment ) -import System.Exit ( ExitCode(..), exitFailure, exitWith ) -import System.FilePath ( (), (<.>) ) -import System.IO ( hClose, IOMode(..), openFile ) -import System.Process ( runProcess, waitForProcess ) - --- | 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 = buildPlatform - , testSuites = [] - } - --- | Logs test suite results, itemized by test case. -data TestSuiteLog = TestSuiteLog - { name :: String - , cases :: [Case] - , logFile :: FilePath -- path to human-readable log file - } - deriving (Read, Show, Eq) - -data Case = Case - { caseName :: String - , caseOptions :: TestSuite.Options - , caseResult :: TestSuite.Result - } - deriving (Read, Show, Eq) - -getTestOptions :: TestSuite.Test -> TestSuiteLog -> IO TestSuite.Options -getTestOptions t l = - case filter ((== TestSuite.name t) . caseName) (cases l) of - (x:_) -> return $ caseOptions x - _ -> TestSuite.defaultOptions t - --- | From a 'TestSuiteLog', determine if the test suite passed. -suitePassed :: TestSuiteLog -> Bool -suitePassed = all (== TestSuite.Pass) . map caseResult . cases - --- | From a 'TestSuiteLog', determine if the test suite failed. -suiteFailed :: TestSuiteLog -> Bool -suiteFailed = any isFail . map caseResult . cases - where isFail (TestSuite.Fail _) = True - isFail _ = False - --- | From a 'TestSuiteLog', determine if the test suite encountered errors. -suiteError :: TestSuiteLog -> Bool -suiteError = any isError . map caseResult . cases - where isError (TestSuite.Error _) = True - isError _ = False - --- | 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" - optionTemplates = fromFlag $ testOptions flags - options = map (testOption pkg_descr lbi suite) optionTemplates - - pwd <- getCurrentDirectory - existingEnv <- getEnvironment - let dataDirPath = pwd PD.dataDir pkg_descr - shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath) - : ("HPCTIXDIR", pwd tixDir distPref suite) - : existingEnv - - bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog -> - bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do - - -- Create directory for HPC files. - createDirectoryIfMissing True $ tixDir distPref suite - - -- Remove old .tix files if appropriate. - tixFiles <- findTixFiles distPref suite - unless (fromFlag $ testKeepTix flags) - $ mapM_ deleteIfExists tixFiles - - -- Write summary notices indicating start of test suite - notice verbosity $ summarizeSuiteStart $ PD.testName suite - appendFile tempLog $ 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 runProcess - proc <- runProcess cmd options Nothing shellEnv - (Just hIn) (Just hLog) (Just hLog) - waitForProcess proc - - -- Generate TestSuiteLog from executable exit code and a machine- - -- readable test log - suiteLog <- readFile tempInput >>= return . postTest exit - - -- Generate final log file name - let finalLogName = testLogDir logNamer suiteLog - suiteLog' = suiteLog { logFile = finalLogName } - - -- Write summary notice to log file indicating end of test suite - appendFile tempLog $ summarizeSuiteFinish suiteLog' - - -- Append contents of temporary log file to the final human- - -- readable log file - readFile tempLog >>= appendFile (logFile 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 (logFile suiteLog') >>= - putStr . unlines . map (">>> " ++) . lines - - -- Write summary notice to terminal indicating end of test suite - notice verbosity $ summarizeSuiteFinish suiteLog' - - doHpcMarkup verbosity 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 - - --- |Perform the \"@.\/setup test@\" action. -test :: 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 - let verbosity = fromFlag $ testVerbosity flags - humanTemplate = fromFlag $ testHumanLog flags - machineTemplate = fromFlag $ testMachineLog flags - distPref = fromFlag $ testDistPref flags - testLogDir = distPref "test" - testNames = fromFlag $ testList flags - 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, mLog) = do - let testLogPath = testSuiteLogPath humanTemplate pkg_descr lbi - go pre cmd post = testController flags pkg_descr lbi suite - pre cmd post testLogPath - 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 -> TestSuite.Pass - ExitFailure c -> TestSuite.Fail - $ "exit code: " ++ show c - in TestSuiteLog - { name = PD.testName suite - , cases = [Case (PD.testName suite) mempty r] - , logFile = "" - } - go preTest cmd postTest - - PD.TestSuiteLibV09 _ _ -> do - let cmd = LBI.buildDir lbi stubName suite - stubName suite <.> exeExtension - oldLog = case mLog of - Nothing -> TestSuiteLog - { name = PD.testName suite - , cases = [] - , logFile = [] - } - Just l -> l - preTest f = show $ oldLog { logFile = f } - postTest _ = read - go preTest cmd postTest - - _ -> return TestSuiteLog - { name = PD.testName suite - , cases = [Case (PD.testName suite) mempty - $ TestSuite.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." - exitWith ExitSuccess - - when (PD.hasTests pkg_descr && null enabledTests) $ - die $ "No test suites enabled. Did you remember to configure with " - ++ "\'--enable-tests\'?" - - testsToRun <- case testNames of - [] -> return $ zip enabledTests $ repeat Nothing - names -> flip mapM names $ \tName -> - let testMap = zip enabledNames enabledTests - enabledNames = map PD.testName enabledTests - allNames = map PD.testName pkgTests - in case lookup tName testMap of - Just t -> return (t, Nothing) - _ | tName `elem` allNames -> - die $ "Package configured with test suite " - ++ tName ++ " disabled." - | otherwise -> die $ "no such test: " ++ tName - - createDirectoryIfMissing True testLogDir - - -- Delete ordinary files from test log directory. - getDirectoryContents testLogDir - >>= filterM doesFileExist . map (testLogDir ) - >>= mapM_ removeFile - - let totalSuites = length testsToRun - notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." - suites <- mapM doTest testsToRun - let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites } - packageLogFile = () testLogDir - $ packageLogPath machineTemplate pkg_descr lbi - allOk <- summarizePackage verbosity packageLog - writeFile packageLogFile $ show packageLog - 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 cases' = map caseResult $ concatMap cases $ testSuites packageLog - passedCases = length $ filter (== TestSuite.Pass) cases' - totalCases = length cases' - passedSuites = length $ filter suitePassed $ testSuites packageLog - totalSuites = length $ testSuites packageLog - notice verbosity $ show passedSuites ++ " of " ++ show totalSuites - ++ " test suites (" ++ show passedCases ++ " of " - ++ show totalCases ++ " test cases) passed." - return $! passedSuites == totalSuites - --- | Print a summary of a single test case's result to the console, supressing --- output for certain verbosity or test filter levels. -summarizeCase :: Verbosity -> TestShowDetails -> Case -> IO () -summarizeCase verbosity details t = - when shouldPrint $ notice verbosity $ "Test case " ++ caseName t - ++ ": " ++ show (caseResult t) - where shouldPrint = (details > Never) && (notPassed || details == Always) - notPassed = caseResult t /= TestSuite.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 " ++ name 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) - ++ [ (TestSuiteNameVar, toPathTemplate $ name 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) ++ - [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)] - -packageLogPath :: PathTemplate - -> PD.PackageDescription - -> LBI.LocalBuildInfo - -> FilePath -packageLogPath template pkg_descr lbi = - fromPathTemplate $ substPathTemplate env template - where - env = initialPathTemplateEnv - (PD.package pkg_descr) (compilerId $ LBI.compiler 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 Control.Monad ( liftM )" - , "import Distribution.Simple.Test ( runTests )" - , "import " ++ show (disp m) ++ " ( tests )" - , "main :: IO ()" - , "main = runTests tests" - ] - --- | 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. -runTests :: [TestSuite.Test] -> IO () -runTests tests = do - testLogIn <- liftM read getContents - let go :: TestSuite.Test -> IO Case - go t = do - o <- getTestOptions t testLogIn - r <- TestSuite.runM t o - let ret = Case - { caseName = TestSuite.name t - , caseOptions = o - , caseResult = r - } - summarizeCase normal Always ret - return ret - cases' <- mapM go tests - let testLog = testLogIn { cases = cases'} - writeFile (logFile testLog) $ show testLog - when (suiteError testLog) $ exitWith $ ExitFailure 2 - when (suiteFailed testLog) $ exitWith $ ExitFailure 1 - exitWith ExitSuccess diff --git a/cabal/cabal/Distribution/Simple/UHC.hs b/cabal/cabal/Distribution/Simple/UHC.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/UHC.hs +++ /dev/null @@ -1,300 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.UHC --- Copyright : Andres Loeh 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module contains most of the UHC-specific code for configuring, building --- and installing packages. --- --- Thanks to the authors of the other implementation-specific files, in --- 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 - ) where - -import Control.Monad -import Data.List -import Distribution.Compat.ReadP -import Distribution.InstalledPackageInfo -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Simple.BuildPaths -import Distribution.Simple.Compiler as C -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.PackageIndex -import Distribution.Simple.Program -import Distribution.Simple.Utils -import Distribution.Text -import Distribution.Verbosity -import Distribution.Version -import Language.Haskell.Extension -import System.Directory -import System.FilePath - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) -configure verbosity hcPath _hcPkgPath conf = do - - (_uhcProg, uhcVersion, conf') <- - requireProgramVersion verbosity uhcProgram - (orLaterVersion (Version [1,0,2] [])) - (userMaybeSpecifyPath "uhc" hcPath conf) - - let comp = Compiler { - compilerId = CompilerId UHC uhcVersion, - compilerLanguages = uhcLanguages, - compilerExtensions = uhcLanguageExtensions - } - return (comp, conf') - -uhcLanguages :: [(Language, C.Flag)] -uhcLanguages = [(Haskell98, "")] - --- | The flags for the supported extensions. -uhcLanguageExtensions :: [(Extension, C.Flag)] -uhcLanguageExtensions = - let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), - (DisableExtension f, disable)] - alwaysOn = ("", ""{- wrong -}) - in concatMap doFlag - [(CPP, ("--cpp", ""{- wrong -})), - (PolymorphicComponents, alwaysOn), - (ExistentialQuantification, alwaysOn), - (ForeignFunctionInterface, alwaysOn), - (UndecidableInstances, alwaysOn), - (MultiParamTypeClasses, alwaysOn), - (Rank2Types, alwaysOn), - (PatternSignatures, alwaysOn), - (EmptyDataDecls, alwaysOn), - (ImplicitPrelude, ("", "--no-prelude"{- wrong -})), - (TypeOperators, alwaysOn), - (OverlappingInstances, alwaysOn), - (FlexibleInstances, alwaysOn)] - -getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration - -> IO PackageIndex -getInstalledPackages verbosity comp packagedbs conf = do - let compilerid = compilerId comp - systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram conf ["--meta-pkgdir-system"] - userPkgDir <- getUserPackageDir - let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) - -- putStrLn $ "pkgdirs: " ++ show pkgDirs - -- call to "lines" necessary, because pkgdir contains an extra newline at the end - pkgs <- liftM (map addBuiltinVersions . concat) . - mapM (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d)) . - concatMap lines $ pkgDirs - -- putStrLn $ "pkgs: " ++ show pkgs - let iPkgs = - map mkInstalledPackageInfo $ - concatMap parsePackage $ - pkgs - -- putStrLn $ "installed pkgs: " ++ show iPkgs - return (fromList iPkgs) - -getUserPackageDir :: IO FilePath -getUserPackageDir = - do - homeDir <- getHomeDirectory - return $ homeDir ".cabal" "lib" -- TODO: determine in some other way - -packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] -packageDbPaths user system db = - case db of - GlobalPackageDB -> [ system ] - UserPackageDB -> [ user ] - SpecificPackageDB path -> [ path ] - --- | Hack to add version numbers to UHC-builtin packages. This should sooner or --- later be fixed on the UHC side. -addBuiltinVersions :: String -> String -{- -addBuiltinVersions "uhcbase" = "uhcbase-1.0" -addBuiltinVersions "base" = "base-3.0" -addBuiltinVersions "array" = "array-0.2" --} -addBuiltinVersions xs = xs - --- | Name of the installed package config file. -installedPkgConfig :: String -installedPkgConfig = "installed-pkg-config" - --- | Check if a certain dir contains a valid package. Currently, we are --- looking only for the presence of an installed package configuration. --- TODO: Actually make use of the information provided in the file. -isPkgDir :: String -> String -> String -> IO Bool -isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . -isPkgDir c dir xs = do - let candidate = dir uhcPackageDir xs c - -- putStrLn $ "trying: " ++ candidate - doesFileExist (candidate installedPkgConfig) - -parsePackage :: String -> [PackageId] -parsePackage x = map fst (filter (\ (_,y) -> null y) (readP_to_S parse x)) - --- | Create a trivial package info from a directory name. -mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo -mkInstalledPackageInfo p = emptyInstalledPackageInfo - { installedPackageId = InstalledPackageId (display p), - sourcePackageId = p } - - --- ----------------------------------------------------------------------------- --- Building - -buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity pkg_descr lbi lib clbi = do - - systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] - userPkgDir <- getUserPackageDir - let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) - let uhcArgs = -- set package name - ["--pkg-build=" ++ display (packageId pkg_descr)] - -- common flags lib/exe - ++ constructUHCCmdLine userPkgDir systemPkgDir - lbi (libBuildInfo lib) clbi - (buildDir lbi) verbosity - -- source files - -- suboptimal: UHC does not understand module names, so - -- we replace periods by path separators - ++ map (map (\ c -> if c == '.' then pathSeparator else c)) - (map display (libModules lib)) - - runUhcProg uhcArgs - - return () - -buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe verbosity _pkg_descr lbi exe clbi = do - systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] - userPkgDir <- getUserPackageDir - let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) - let uhcArgs = -- common flags lib/exe - constructUHCCmdLine userPkgDir systemPkgDir - lbi (buildInfo exe) clbi - (buildDir lbi) verbosity - -- output file - ++ ["--output", buildDir lbi exeName exe] - -- main source module - ++ [modulePath exe] - runUhcProg uhcArgs - -constructUHCCmdLine :: FilePath -> FilePath - -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> Verbosity -> [String] -constructUHCCmdLine user system lbi bi clbi odir verbosity = - -- verbosity - (if verbosity >= deafening then ["-v4"] - else if verbosity >= normal then [] - else ["-v0"]) - ++ hcOptions UHC bi - -- flags for language extensions - ++ languageToFlags (compiler lbi) (defaultLanguage bi) - ++ extensionsToFlags (compiler lbi) (usedExtensions bi) - -- packages - ++ ["--hide-all-packages"] - ++ uhcPackageDbOptions user system (withPackageDB lbi) - ++ ["--package=uhcbase"] - ++ ["--package=" ++ display (pkgName pkgid) | (_, pkgid) <- componentPackageDeps clbi ] - -- search paths - ++ ["-i" ++ odir] - ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] - ++ ["-i" ++ autogenModulesDir lbi] - -- output path - ++ ["--odir=" ++ odir] - -- optimization - ++ (case withOptimization lbi of - NoOptimisation -> ["-O0"] - NormalOptimisation -> ["-O1"] - MaximumOptimisation -> ["-O2"]) - -uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] -uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x) - (concatMap (packageDbPaths user system) db) - --- ----------------------------------------------------------------------------- --- Installation - -installLib :: Verbosity -> LocalBuildInfo - -> FilePath -> FilePath -> FilePath - -> PackageDescription -> Library -> IO () -installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library = do - -- putStrLn $ "dest: " ++ targetDir - -- putStrLn $ "built: " ++ builtDir - installDirectoryContents verbosity (builtDir display (packageId pkg)) targetDir - --- currently hardcoded UHC code generator and variant to use -uhcTarget, uhcTargetVariant :: String -uhcTarget = "bc" -uhcTargetVariant = "plain" - --- root directory for a package in UHC -uhcPackageDir :: String -> String -> FilePath -uhcPackageSubDir :: String -> FilePath -uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid -uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant - --- ----------------------------------------------------------------------------- --- Registering - -registerPackage - :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo - -> Bool - -> PackageDBStack - -> IO () -registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do - let installDirs = absoluteInstallDirs pkg lbi NoCopyDest - pkgdir | inplace = buildDir lbi uhcPackageDir (display pkgid) (display compilerid) - | otherwise = libdir installDirs uhcPackageSubDir (display compilerid) - createDirectoryIfMissingVerbose verbosity True pkgdir - writeUTF8File (pkgdir installedPkgConfig) - (showInstalledPackageInfo installedPkgInfo) - where - pkgid = packageId pkg - compilerid = compilerId (compiler lbi) diff --git a/cabal/cabal/Distribution/Simple/UserHooks.hs b/cabal/cabal/Distribution/Simple/UserHooks.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/UserHooks.hs +++ /dev/null @@ -1,220 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.UserHooks --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defines the API that @Setup.hs@ scripts can use to customise the way --- the build works. This module just defines the 'UserHooks' type. The --- predefined sets of hooks that implement the @Simple@, @Make@ and @Configure@ --- build systems are defined in "Distribution.Simple". The 'UserHooks' is a big --- record of functions. There are 3 for each action, a pre, post and the action --- itself. There are few other miscellaneous hooks, ones to extend the set of --- programs and preprocessors and one to override the function used to read the --- @.cabal@ file. --- --- This hooks type is widely agreed to not be the right solution. Partly this --- is because changes to it usually break custom @Setup.hs@ files and yet many --- internal code changes do require changes to the hooks. For example we cannot --- pass any extra parameters to most of the functions that implement the --- 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, - ) where - -import Distribution.PackageDescription - (PackageDescription, GenericPackageDescription, - HookedBuildInfo, emptyHookedBuildInfo) -import Distribution.Simple.Program (Program) -import Distribution.Simple.Command (noExtraFlags) -import Distribution.Simple.PreProcess (PPSuffixHandler) -import Distribution.Simple.Setup - (ConfigFlags, BuildFlags, CleanFlags, CopyFlags, - InstallFlags, SDistFlags, RegisterFlags, HscolourFlags, - HaddockFlags, TestFlags) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) - -type Args = [String] - --- | Hooks allow authors to add specific functionality before and after a --- command is run, and also to specify additional preprocessors. --- --- * WARNING: The hooks interface is under rather constant flux as we try to --- understand users needs. Setup files that depend on this interface may --- break in future releases. -data UserHooks = UserHooks { - - -- | Used for @.\/setup test@ - runTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO (), - -- | Read the description file - readDesc :: IO (Maybe GenericPackageDescription), - -- | Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. - hookedPreProcessors :: [ PPSuffixHandler ], - -- | These programs are detected at configure time. Arguments for them are - -- added to the configure command. - hookedPrograms :: [Program], - - -- |Hook to run before configure command - preConf :: Args -> ConfigFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during configure. - confHook :: (GenericPackageDescription, HookedBuildInfo) - -> ConfigFlags -> IO LocalBuildInfo, - -- |Hook to run after configure command - postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |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. - buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (), - -- |Hook to run after build command. Second arg indicates verbosity level. - postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before clean command. Second arg indicates verbosity level. - preClean :: Args -> CleanFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during clean. - cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO (), - -- |Hook to run after clean command. Second arg indicates verbosity level. - postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO (), - - -- |Hook to run before copy command - preCopy :: Args -> CopyFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during copy. - copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (), - -- |Hook to run after copy command - postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before install command - preInst :: Args -> InstallFlags -> IO HookedBuildInfo, - - -- |Over-ride this hook to get different behavior during install. - instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (), - -- |Hook to run after install command. postInst should be run - -- on the target, not on the build machine. - postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before sdist command. Second arg indicates verbosity level. - preSDist :: Args -> SDistFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during sdist. - sDistHook :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO (), - -- |Hook to run after sdist command. Second arg indicates verbosity level. - postSDist :: Args -> SDistFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO (), - - -- |Hook to run before register command - preReg :: Args -> RegisterFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during registration. - regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), - -- |Hook to run after register command - postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before unregister command - preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during registration. - unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), - -- |Hook to run after unregister command - postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before hscolour command. Second arg indicates verbosity level. - preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during hscolour. - hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (), - -- |Hook to run after hscolour command. Second arg indicates verbosity level. - postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before haddock command. Second arg indicates verbosity level. - preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during haddock. - haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (), - -- |Hook to run after haddock command. Second arg indicates verbosity level. - postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |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 (), - -- |Hook to run after test command. - postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO () - } - -{-# DEPRECATED runTests "Please use the new testing interface instead!" #-} - --- |Empty 'UserHooks' which do nothing. -emptyUserHooks :: UserHooks -emptyUserHooks - = UserHooks { - runTests = ru, - readDesc = return Nothing, - hookedPreProcessors = [], - hookedPrograms = [], - preConf = rn, - confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")), - postConf = ru, - preBuild = rn, - buildHook = ru, - postBuild = ru, - preClean = rn, - cleanHook = ru, - postClean = ru, - preCopy = rn, - copyHook = ru, - postCopy = ru, - preInst = rn, - instHook = ru, - postInst = ru, - preSDist = rn, - sDistHook = ru, - postSDist = ru, - preReg = rn, - regHook = ru, - postReg = ru, - preUnreg = rn, - unregHook = ru, - postUnreg = ru, - preHscolour = rn, - hscolourHook = ru, - postHscolour = ru, - preHaddock = rn, - haddockHook = ru, - postHaddock = ru, - preTest = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without - -- noExtraFlags - testHook = ru, - postTest = ru - } - where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo - ru _ _ _ _ = return () diff --git a/cabal/cabal/Distribution/Simple/Utils.hs b/cabal/cabal/Distribution/Simple/Utils.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Simple/Utils.hs +++ /dev/null @@ -1,1131 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp -fffi #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Utils --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- portions Copyright (c) 2007, Galois Inc. --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- A large and somewhat miscellaneous collection of utility functions used --- throughout the rest of the Cabal lib and in other tools that use the Cabal --- lib like @cabal-install@. It has a very simple set of logging actions. It --- 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, - - -- * logging and errors - die, - dieWithLocation, - topHandler, - warn, notice, setupMessage, info, debug, - chattyTry, - - -- * running programs - rawSystemExit, - rawSystemExitWithEnv, - rawSystemStdout, - rawSystemStdInOut, - maybeExit, - xargs, - findProgramLocation, - findProgramVersion, - - -- * copying files - smartCopySources, - createDirectoryIfMissingVerbose, - copyFileVerbose, - copyDirectoryRecursiveVerbose, - copyFiles, - - -- * installing files - installOrdinaryFile, - installExecutableFile, - installOrdinaryFiles, - installDirectoryContents, - - -- * File permissions - setFileOrdinary, - setFileExecutable, - - -- * file names - currentDir, - - -- * finding files - findFile, - findFirstFile, - findFileWithExtension, - findFileWithExtension', - findModuleFile, - findModuleFiles, - getDirectoryContentsRecursive, - - -- * simple file globbing - matchFileGlob, - matchDirFileGlob, - parseFileGlob, - FileGlob(..), - - -- * temp files and dirs - withTempFile, - withTempDirectory, - - -- * .cabal and .buildinfo files - defaultPackageDesc, - findPackageDesc, - defaultHookedPackageDesc, - findHookedPackageDesc, - - -- * reading and writing files safely - withFileContents, - writeFileAtomic, - rewriteFile, - - -- * Unicode - fromUTF8, - toUTF8, - readUTF8File, - withUTF8FileContents, - writeUTF8File, - normaliseLineEndings, - - -- * generic utils - equating, - comparing, - isInfixOf, - intercalate, - lowercase, - wrapText, - wrapLine, - ) where - -import Control.Monad - ( when, unless, filterM ) -#ifdef __GLASGOW_HASKELL__ -import Control.Concurrent.MVar - ( newEmptyMVar, putMVar, takeMVar ) -#endif -import Data.List - ( nub, unfoldr, isPrefixOf, tails, intersperse ) -import Data.Char as Char - ( toLower, chr, ord ) -import Data.Bits - ( Bits((.|.), (.&.), shiftL, shiftR) ) - -import System.Directory - ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile - , findExecutable ) -import System.Environment - ( getProgName ) -import System.Cmd - ( rawSystem ) -import System.Exit - ( exitWith, ExitCode(..) ) -import System.FilePath - ( normalise, (), (<.>), takeDirectory, splitFileName - , splitExtension, splitExtensions, splitDirectories ) -import System.Directory - ( createDirectory, renameFile, removeDirectoryRecursive ) -import System.IO - ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode - , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) -import System.IO.Error as IO.Error - ( isDoesNotExistError, isAlreadyExistsError - , ioeSetFileName, ioeGetFileName, ioeGetErrorString ) -#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)) -import System.IO.Error - ( ioeSetLocation, ioeGetLocation ) -#endif -import System.IO.Unsafe - ( unsafeInterleaveIO ) -import qualified Control.Exception as Exception - -import Distribution.Text - ( display, simpleParse ) -import Distribution.Package - ( PackageIdentifier ) -import Distribution.ModuleName (ModuleName) -import qualified Distribution.ModuleName as ModuleName -import Distribution.Version - (Version(..)) - -import Control.Exception (evaluate) -import System.Process (runProcess) - -#ifdef __GLASGOW_HASKELL__ -import Control.Concurrent (forkIO) -import System.Process (runInteractiveProcess, waitForProcess) -#else -import System.Cmd (system) -import System.Directory (getTemporaryDirectory) -#endif - -import Distribution.Compat.CopyFile - ( copyFile, copyOrdinaryFile, copyExecutableFile - , setFileOrdinary, setFileExecutable, setDirOrdinary ) -import Distribution.Compat.TempFile - ( openTempFile, openNewBinaryFile, createTempDirectory ) -import Distribution.Compat.Exception - ( IOException, throwIOIO, tryIO, catchIO, catchExit, onException ) -import Distribution.Verbosity - -#ifdef VERSION_base -import qualified Paths_Cabal (version) -#endif - --- We only get our own version number when we're building with ourselves -cabalVersion :: Version -#if defined(VERSION_base) -cabalVersion = Paths_Cabal.version -#elif defined(CABAL_VERSION) -cabalVersion = Version [CABAL_VERSION] [] -#else -cabalVersion = Version [1,9999] [] --used when bootstrapping -#endif - --- ---------------------------------------------------------------------------- --- Exception and logging utils - -dieWithLocation :: FilePath -> Maybe Int -> String -> IO a -dieWithLocation filename lineno msg = - ioError . setLocation lineno - . flip ioeSetFileName (normalise filename) - $ userError msg - where -#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608) - setLocation _ err = err -#else - setLocation Nothing err = err - setLocation (Just n) err = ioeSetLocation err (show n) -#endif - -die :: String -> IO a -die msg = ioError (userError msg) - -topHandler :: IO a -> IO a -topHandler prog = catchIO prog handle - where - handle ioe = do - hFlush stdout - pname <- getProgName - hPutStr stderr (mesage pname) - exitWith (ExitFailure 1) - where - mesage pname = wrapText (pname ++ ": " ++ file ++ detail) - file = case ioeGetFileName ioe of - Nothing -> "" - Just path -> path ++ location ++ ": " -#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608) - location = "" -#else - location = case ioeGetLocation ioe of - l@(n:_) | n >= '0' && n <= '9' -> ':' : l - _ -> "" -#endif - detail = ioeGetErrorString ioe - --- | Non fatal conditions that may be indicative of an error or problem. --- --- We display these at the 'normal' verbosity level. --- -warn :: Verbosity -> String -> IO () -warn verbosity msg = - when (verbosity >= normal) $ do - hFlush stdout - hPutStr stderr (wrapText ("Warning: " ++ msg)) - --- | Useful status messages. --- --- We display these at the 'normal' verbosity level. --- --- This is for the ordinary helpful status messages that users see. Just --- enough information to know that things are working but not floods of detail. --- -notice :: Verbosity -> String -> IO () -notice verbosity msg = - when (verbosity >= normal) $ - putStr (wrapText msg) - -setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () -setupMessage verbosity msg pkgid = - notice verbosity (msg ++ ' ': display pkgid ++ "...") - --- | More detail on the operation of some action. --- --- We display these messages when the verbosity level is 'verbose' --- -info :: Verbosity -> String -> IO () -info verbosity msg = - when (verbosity >= verbose) $ - putStr (wrapText msg) - --- | Detailed internal debugging information --- --- We display these messages when the verbosity level is 'deafening' --- -debug :: Verbosity -> String -> IO () -debug verbosity msg = - when (verbosity >= deafening) $ do - putStr (wrapText msg) - hFlush stdout - --- | Perform an IO action, catching any IO exceptions and printing an error --- if one occurs. -chattyTry :: String -- ^ a description of the action we were attempting - -> IO () -- ^ the action itself - -> IO () -chattyTry desc action = - catchIO action $ \exception -> - putStrLn $ "Error while " ++ desc ++ ": " ++ show exception - --- ----------------------------------------------------------------------------- --- Helper functions - --- | Wraps text to the default line width. Existing newlines are preserved. -wrapText :: String -> String -wrapText = unlines - . concatMap (map unwords - . wrapLine 79 - . words) - . lines - --- | Wraps a list of words to a list of lines of words of a particular width. -wrapLine :: Int -> [String] -> [[String]] -wrapLine width = wrap 0 [] - where wrap :: Int -> [String] -> [String] -> [[String]] - wrap 0 [] (w:ws) - | length w + 1 > width - = wrap (length w) [w] ws - wrap col line (w:ws) - | col + length w + 1 > width - = reverse line : wrap 0 [] (w:ws) - wrap col line (w:ws) - = let col' = col + length w + 1 - in wrap col' (w:line) ws - wrap _ [] [] = [] - wrap _ line [] = [reverse line] - --- ----------------------------------------------------------------------------- --- rawSystem variants -maybeExit :: IO ExitCode -> IO () -maybeExit cmd = do - res <- cmd - unless (res == ExitSuccess) $ exitWith res - -printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () -printRawCommandAndArgs verbosity path args - | verbosity >= deafening = print (path, args) - | verbosity >= verbose = putStrLn $ unwords (path : args) - | otherwise = return () - -printRawCommandAndArgsAndEnv :: Verbosity - -> FilePath - -> [String] - -> [(String, String)] - -> IO () -printRawCommandAndArgsAndEnv verbosity path args env - | verbosity >= deafening = do putStrLn ("Environment: " ++ show env) - print (path, args) - | verbosity >= verbose = putStrLn $ unwords (path : args) - | otherwise = return () - --- Exit with the same exitcode if the subcommand fails -rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () -rawSystemExit verbosity path args = do - printRawCommandAndArgs verbosity path args - hFlush stdout - exitcode <- rawSystem path args - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - exitWith exitcode - -rawSystemExitWithEnv :: Verbosity - -> FilePath - -> [String] - -> [(String, String)] - -> IO () -rawSystemExitWithEnv verbosity path args env = do - printRawCommandAndArgsAndEnv verbosity path args env - hFlush stdout - ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing - exitcode <- waitForProcess ph - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - exitWith exitcode - --- | Run a command and return its output. --- --- The output is assumed to be text in the locale encoding. --- -rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String -rawSystemStdout verbosity path args = do - (output, errors, exitCode) <- rawSystemStdInOut verbosity path args - Nothing False - when (exitCode /= ExitSuccess) $ - die errors - return output - --- | Run a command and return its output, errors and exit status. Optionally --- also supply some input. Also provides control over whether the binary/text --- mode of the input and output. --- -rawSystemStdInOut :: Verbosity - -> FilePath -> [String] - -> Maybe (String, Bool) -- ^ input text and binary mode - -> Bool -- ^ output in binary mode - -> IO (String, String, ExitCode) -- ^ output, errors, exit -rawSystemStdInOut verbosity path args input outputBinary = do - printRawCommandAndArgs verbosity path args - -#ifdef __GLASGOW_HASKELL__ - Exception.bracket - (runInteractiveProcess path args Nothing Nothing) - (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) - $ \(inh,outh,errh,pid) -> do - - -- output mode depends on what the caller wants - hSetBinaryMode outh outputBinary - -- but the errors are always assumed to be text (in the current locale) - hSetBinaryMode errh False - - -- fork off a couple threads to pull on the stderr and stdout - -- so if the process writes to stderr we do not block. - - err <- hGetContents errh - out <- hGetContents outh - - mv <- newEmptyMVar - let force str = (evaluate (length str) >> return ()) - `Exception.finally` putMVar mv () - --TODO: handle exceptions like text decoding. - _ <- forkIO $ force out - _ <- forkIO $ force err - - -- push all the input, if any - case input of - Nothing -> return () - Just (inputStr, inputBinary) -> do - -- input mode depends on what the caller wants - hSetBinaryMode inh inputBinary - hPutStr inh inputStr - hClose inh - --TODO: this probably fails if the process refuses to consume - -- or if it closes stdin (eg if it exits) - - -- wait for both to finish, in either order - takeMVar mv - takeMVar mv - - -- wait for the program to terminate - exitcode <- waitForProcess pid - unless (exitcode == ExitSuccess) $ - debug verbosity $ path ++ " returned " ++ show exitcode - ++ if null err then "" else - " with error message:\n" ++ err - - return (out, err, exitcode) -#else - tmpDir <- getTemporaryDirectory - withTempFile tmpDir ".cmd.stdout" $ \outName outHandle -> - withTempFile tmpDir ".cmd.stdin" $ \inName inHandle -> do - hClose outHandle - - case input of - Nothing -> return () - Just (inputStr, inputBinary) -> do - hSetBinaryMode inHandle inputBinary - hPutStr inHandle inputStr - hClose inHandle - - let quote name = "'" ++ name ++ "'" - cmd = unwords (map quote (path:args)) - ++ " <" ++ quote inName - ++ " >" ++ quote outName - exitcode <- system cmd - - unless (exitcode == ExitSuccess) $ - debug verbosity $ path ++ " returned " ++ show exitcode - - Exception.bracket (openFile outName ReadMode) hClose $ \hnd -> do - hSetBinaryMode hnd outputBinary - output <- hGetContents hnd - length output `seq` return (output, "", exitcode) -#endif - - --- | Look for a program on the path. -findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath) -findProgramLocation verbosity prog = do - debug verbosity $ "searching for " ++ prog ++ " in path." - res <- findExecutable prog - case res of - Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") - Just path -> debug verbosity ("found " ++ prog ++ " at "++ path) - return res - - --- | Look for a program and try to find it's version number. It can accept --- either an absolute path or the name of a program binary, in which case we --- will look for the program on the path. --- -findProgramVersion :: String -- ^ version args - -> (String -> String) -- ^ function to select version - -- number from program output - -> Verbosity - -> FilePath -- ^ location - -> IO (Maybe Version) -findProgramVersion versionArg selectVersion verbosity path = do - str <- rawSystemStdout verbosity path [versionArg] - `catchIO` (\_ -> return "") - `catchExit` (\_ -> return "") - let version :: Maybe Version - version = simpleParse (selectVersion str) - case version of - Nothing -> warn verbosity $ "cannot determine version of " ++ path - ++ " :\n" ++ show str - Just v -> debug verbosity $ path ++ " is version " ++ display v - return version - - --- | 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. --- --- Use it with either of the rawSystem variants above. For example: --- --- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs --- -xargs :: Int -> ([String] -> IO ()) - -> [String] -> [String] -> IO () -xargs maxSize rawSystemFun fixedArgs bigArgs = - let fixedArgSize = sum (map length fixedArgs) + length fixedArgs - chunkSize = maxSize - fixedArgSize - in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) - - where chunks len = unfoldr $ \s -> - if null s then Nothing - else Just (chunk [] len s) - - chunk acc _ [] = (reverse acc,[]) - chunk acc len (s:ss) - | len' < len = chunk (s:acc) (len-len'-1) ss - | otherwise = (reverse acc, s:ss) - where len' = length s - --- ------------------------------------------------------------ --- * File Utilities --- ------------------------------------------------------------ - ----------------- --- Finding files - --- | Find a file by looking in a search path. The file path must match exactly. --- -findFile :: [FilePath] -- ^search locations - -> FilePath -- ^File Name - -> IO FilePath -findFile searchPath fileName = - findFirstFile id - [ path fileName - | path <- nub searchPath] - >>= maybe (die $ fileName ++ " doesn't exist") return - --- | Find a file by looking in a search path with one of a list of possible --- file extensions. The file base name should be given and it will be tried --- with each of the extensions in each element of the search path. --- -findFileWithExtension :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe FilePath) -findFileWithExtension extensions searchPath baseName = - findFirstFile 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. --- -findFileWithExtension' :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe (FilePath, FilePath)) -findFileWithExtension' extensions searchPath baseName = - findFirstFile (uncurry ()) - [ (path, baseName <.> ext) - | path <- nub searchPath - , ext <- nub extensions ] - -findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) -findFirstFile file = findFirst - where findFirst [] = return Nothing - findFirst (x:xs) = do exists <- doesFileExist (file x) - if exists - then return (Just x) - else findFirst xs - --- | Finds the files corresponding to a list of Haskell module names. --- --- As 'findModuleFile' but for a list of module names. --- -findModuleFiles :: [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> [ModuleName] -- ^ modules - -> IO [(FilePath, FilePath)] -findModuleFiles searchPath extensions moduleNames = - mapM (findModuleFile searchPath extensions) moduleNames - --- | Find the file corresponding to a Haskell module name. --- --- This is similar to 'findFileWithExtension'' but specialised to a module --- name. The function fails if the file corresponding to the module is missing. --- -findModuleFile :: [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> ModuleName -- ^ module - -> IO (FilePath, FilePath) -findModuleFile searchPath extensions moduleName = - maybe notFound return - =<< findFileWithExtension' extensions searchPath - (ModuleName.toFilePath moduleName) - where - notFound = die $ "Error: Could not find module: " ++ display moduleName - ++ " with any suffix: " ++ show extensions - ++ " in the search path: " ++ show searchPath - --- | List all the files in a directory and all subdirectories. --- --- The order places files in sub-directories after all the files in their --- parent directories. The list is generated lazily so is not well defined if --- the source directory structure changes before the list is used. --- -getDirectoryContentsRecursive :: FilePath -> IO [FilePath] -getDirectoryContentsRecursive topdir = recurseDirectories [""] - where - recurseDirectories :: [FilePath] -> IO [FilePath] - recurseDirectories [] = return [] - recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) - files' <- recurseDirectories (dirs' ++ dirs) - return (files ++ files') - - where - collect files dirs' [] = return (reverse files, reverse dirs') - collect files dirs' (entry:entries) | ignore entry - = collect files dirs' entries - collect files dirs' (entry:entries) = do - let dirEntry = dir entry - isDirectory <- doesDirectoryExist (topdir dirEntry) - if isDirectory - then collect files (dirEntry:dirs') entries - else collect (dirEntry:files) dirs' entries - - ignore ['.'] = True - ignore ['.', '.'] = True - ignore _ = False - ----------------- --- File globbing - -data FileGlob - -- | No glob at all, just an ordinary file - = NoGlob FilePath - - -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to - -- @FileGlob \"foo\/bar\" \".baz\"@ - | FileGlob FilePath String - -parseFileGlob :: FilePath -> Maybe FileGlob -parseFileGlob filepath = case splitExtensions filepath of - (filepath', ext) -> case splitFileName filepath' of - (dir, "*") | '*' `elem` dir - || '*' `elem` ext - || null ext -> Nothing - | null dir -> Just (FileGlob "." ext) - | otherwise -> Just (FileGlob dir ext) - _ | '*' `elem` filepath -> Nothing - | otherwise -> Just (NoGlob filepath) - -matchFileGlob :: FilePath -> IO [FilePath] -matchFileGlob = matchDirFileGlob "." - -matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath] -matchDirFileGlob dir filepath = case parseFileGlob filepath of - Nothing -> die $ "invalid file glob '" ++ filepath - ++ "'. Wildcards '*' are only allowed in place of the file" - ++ " name, not in the directory name or file extension." - ++ " If a wildcard is used it must be with an file extension." - Just (NoGlob filepath') -> return [filepath'] - Just (FileGlob dir' ext) -> do - files <- getDirectoryContents (dir dir') - case [ dir' file - | file <- files - , let (name, ext') = splitExtensions file - , not (null name) && ext' == ext ] of - [] -> die $ "filepath wildcard '" ++ filepath - ++ "' does not match any files." - matches -> return matches - ----------------------------------------- --- Copying and installing files and dirs - --- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. --- -createDirectoryIfMissingVerbose :: Verbosity - -> Bool -- ^ Create its parents too? - -> FilePath - -> IO () -createDirectoryIfMissingVerbose verbosity create_parents path0 - | create_parents = createDirs (parents path0) - | otherwise = createDirs (take 1 (parents path0)) - where - parents = reverse . scanl1 () . splitDirectories . normalise - - createDirs [] = return () - createDirs (dir:[]) = createDir dir throwIOIO - createDirs (dir:dirs) = - createDir dir $ \_ -> do - createDirs dirs - createDir dir throwIOIO - - createDir :: FilePath -> (IOException -> IO ()) -> IO () - createDir dir notExistHandler = do - r <- tryIO $ createDirectoryVerbose verbosity dir - case (r :: Either IOException ()) of - Right () -> return () - Left e - | isDoesNotExistError e -> notExistHandler e - -- 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 - -- 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. - | isAlreadyExistsError e -> (do - isDir <- doesDirectoryExist dir - if isDir then return () - else throwIOIO e - ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) - | otherwise -> throwIOIO e - -createDirectoryVerbose :: Verbosity -> FilePath -> IO () -createDirectoryVerbose verbosity dir = do - info verbosity $ "creating " ++ dir - createDirectory dir - setDirOrdinary dir - --- | Copies a file without copying file permissions. The target file is created --- with default permissions. Any existing target file is replaced. --- --- At higher verbosity levels it logs an info message. --- -copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () -copyFileVerbose verbosity src dest = do - info verbosity ("copy " ++ src ++ " to " ++ dest) - copyFile src dest - --- | Install an ordinary file. This is like a file copy but the permissions --- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" --- while on Windows it uses the default permissions for the target directory. --- -installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () -installOrdinaryFile verbosity src dest = do - info verbosity ("Installing " ++ src ++ " to " ++ dest) - copyOrdinaryFile src dest - --- | Install an executable file. This is like a file copy but the permissions --- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" --- while on Windows it uses the default permissions for the target directory. --- -installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () -installExecutableFile verbosity src dest = do - info verbosity ("Installing executable " ++ src ++ " to " ++ dest) - copyExecutableFile src dest - --- | Copies a bunch of files to a target directory, preserving the directory --- structure in the target location. The target directories are created if they --- do not exist. --- --- The files are identified by a pair of base directory and a path relative to --- that base. It is only the relative part that is preserved in the --- destination. --- --- For example: --- --- > copyFiles normal "dist/src" --- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] --- --- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and --- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". --- --- This operation is not atomic. Any IO failure during the copy (including any --- missing source files) leaves the target in an unknown state so it is best to --- use it with a freshly created directory so that it can be simply deleted if --- anything goes wrong. --- -copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -copyFiles verbosity targetDir srcFiles = do - - -- Create parent directories for everything - let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles - mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs - - -- Copy all the files - sequence_ [ let src = srcBase srcFile - dest = targetDir srcFile - in copyFileVerbose verbosity src dest - | (srcBase, srcFile) <- srcFiles ] - --- | This is like 'copyFiles' but uses 'installOrdinaryFile'. --- -installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -installOrdinaryFiles verbosity targetDir srcFiles = do - - -- Create parent directories for everything - let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles - mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs - - -- Copy all the files - sequence_ [ let src = srcBase srcFile - dest = targetDir srcFile - in installOrdinaryFile verbosity src dest - | (srcBase, srcFile) <- srcFiles ] - --- | This installs all the files in a directory to a target location, --- preserving the directory layout. All the files are assumed to be ordinary --- rather than executable files. --- -installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () -installDirectoryContents verbosity srcDir destDir = do - info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") - srcFiles <- getDirectoryContentsRecursive srcDir - installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] - ---------------------------------- --- Deprecated file copy functions - -{-# DEPRECATED smartCopySources - "Use findModuleFiles and copyFiles or installOrdinaryFiles" #-} -smartCopySources :: Verbosity -> [FilePath] -> FilePath - -> [ModuleName] -> [String] -> IO () -smartCopySources verbosity searchPath targetDir moduleNames extensions = - findModuleFiles searchPath extensions moduleNames - >>= copyFiles verbosity targetDir - -{-# DEPRECATED copyDirectoryRecursiveVerbose - "You probably want installDirectoryContents instead" #-} -copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO () -copyDirectoryRecursiveVerbose verbosity srcDir destDir = do - info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") - srcFiles <- getDirectoryContentsRecursive srcDir - copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] - ---------------------------- --- Temporary files and dirs - --- | Use a temporary filename that doesn't already exist. --- -withTempFile :: FilePath -- ^ Temp dir to create the file in - -> String -- ^ File name template. See 'openTempFile'. - -> (FilePath -> Handle -> IO a) -> IO a -withTempFile tmpDir template action = - Exception.bracket - (openTempFile tmpDir template) - (\(name, handle) -> hClose handle >> removeFile name) - (uncurry action) - --- | Create and use a temporary directory. --- --- Creates a new temporary directory inside the given directory, making use --- of the template. The temp directory is deleted after use. For example: --- --- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... --- --- The @tmpDir@ will be a new subdirectory of the given directory, e.g. --- @src/sdist.342@. --- -withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a -withTempDirectory _verbosity targetDir template = - Exception.bracket - (createTempDirectory targetDir template) - (removeDirectoryRecursive) - ------------------------------------ --- Safely reading and writing files - --- | Gets the contents of a file, but guarantee that it gets closed. --- --- The file is read lazily but if it is not fully consumed by the action then --- the remaining input is truncated and the file is closed. --- -withFileContents :: FilePath -> (String -> IO a) -> IO a -withFileContents name action = - Exception.bracket (openFile name ReadMode) hClose - (\hnd -> hGetContents hnd >>= action) - --- | Writes a file atomically. --- --- The file is either written sucessfully 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. --- This case will give an IO exception but the atomic property is not affected. --- -writeFileAtomic :: FilePath -> String -> IO () -writeFileAtomic targetFile content = do - (tmpFile, tmpHandle) <- openNewBinaryFile targetDir template - do hPutStr tmpHandle content - hClose tmpHandle - renameFile tmpFile targetFile - `onException` do hClose tmpHandle - removeFile tmpFile - where - template = targetName <.> "tmp" - targetDir | null targetDir_ = currentDir - | otherwise = targetDir_ - --TODO: remove this when takeDirectory/splitFileName is fixed - -- to always return a valid dir - (targetDir_,targetName) = splitFileName targetFile - --- | Write a file but only if it would have new content. If we would be writing --- the same as the existing content then leave the file as is so that we do not --- update the file's modification time. --- -rewriteFile :: FilePath -> String -> IO () -rewriteFile path newContent = - flip catchIO mightNotExist $ do - existingContent <- readFile path - _ <- evaluate (length existingContent) - unless (existingContent == newContent) $ - writeFileAtomic path newContent - where - mightNotExist e | isDoesNotExistError e = writeFileAtomic path newContent - | otherwise = ioError e - --- | The path name that represents the current directory. --- In Unix, it's @\".\"@, but this is system-specific. --- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) -currentDir :: FilePath -currentDir = "." - --- ------------------------------------------------------------ --- * Finding the description file --- ------------------------------------------------------------ - --- |Package description file (/pkgname/@.cabal@) -defaultPackageDesc :: Verbosity -> IO FilePath -defaultPackageDesc _verbosity = findPackageDesc currentDir - --- |Find a package description file in the given directory. Looks for --- @.cabal@ files. -findPackageDesc :: FilePath -- ^Where to look - -> IO FilePath -- ^.cabal -findPackageDesc dir - = do files <- getDirectoryContents dir - -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal - -- file we filter to exclude dirs and null base file names: - cabalFiles <- filterM doesFileExist - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == ".cabal" ] - case cabalFiles of - [] -> noDesc - [cabalFile] -> return cabalFile - multiple -> multiDesc multiple - - where - noDesc :: IO a - noDesc = die $ "No cabal file found.\n" - ++ "Please create a package description file .cabal" - - multiDesc :: [String] -> IO a - multiDesc l = die $ "Multiple cabal files found.\n" - ++ "Please use only one of: " - ++ show l - --- |Optional auxiliary package information file (/pkgname/@.buildinfo@) -defaultHookedPackageDesc :: IO (Maybe FilePath) -defaultHookedPackageDesc = findHookedPackageDesc currentDir - --- |Find auxiliary package information in the given directory. --- Looks for @.buildinfo@ files. -findHookedPackageDesc - :: FilePath -- ^Directory to search - -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present -findHookedPackageDesc dir = do - files <- getDirectoryContents dir - buildInfoFiles <- filterM doesFileExist - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == buildInfoExt ] - case buildInfoFiles of - [] -> return Nothing - [f] -> return (Just f) - _ -> die ("Multiple files with extension " ++ buildInfoExt) - -buildInfoExt :: String -buildInfoExt = ".buildinfo" - --- ------------------------------------------------------------ --- * Unicode stuff --- ------------------------------------------------------------ - --- This is a modification of the UTF8 code from gtk2hs and the --- utf8-string package. - -fromUTF8 :: String -> String -fromUTF8 [] = [] -fromUTF8 (c:cs) - | c <= '\x7F' = c : fromUTF8 cs - | c <= '\xBF' = replacementChar : fromUTF8 cs - | c <= '\xDF' = twoBytes c cs - | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF) - | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7) - | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3) - | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1) - | otherwise = replacementChar : fromUTF8 cs - where - twoBytes c0 (c1:cs') - | ord c1 .&. 0xC0 == 0x80 - = let d = ((ord c0 .&. 0x1F) `shiftL` 6) - .|. (ord c1 .&. 0x3F) - in if d >= 0x80 - then chr d : fromUTF8 cs' - else replacementChar : fromUTF8 cs' - twoBytes _ cs' = replacementChar : fromUTF8 cs' - - moreBytes :: Int -> Int -> [Char] -> Int -> [Char] - moreBytes 1 overlong cs' acc - | overlong <= acc && acc <= 0x10FFFF - && (acc < 0xD800 || 0xDFFF < acc) - && (acc < 0xFFFE || 0xFFFF < acc) - = chr acc : fromUTF8 cs' - - | otherwise - = replacementChar : fromUTF8 cs' - - moreBytes byteCount overlong (cn:cs') acc - | ord cn .&. 0xC0 == 0x80 - = moreBytes (byteCount-1) overlong cs' - ((acc `shiftL` 6) .|. ord cn .&. 0x3F) - - moreBytes _ _ cs' _ - = replacementChar : fromUTF8 cs' - - replacementChar = '\xfffd' - -toUTF8 :: String -> String -toUTF8 [] = [] -toUTF8 (c:cs) - | c <= '\x07F' = c - : toUTF8 cs - | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6)) - : chr (0x80 .|. (w .&. 0x3F)) - : toUTF8 cs - | c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12)) - : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) - : chr (0x80 .|. (w .&. 0x3F)) - : toUTF8 cs - | otherwise = chr (0xf0 .|. (w `shiftR` 18)) - : chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F)) - : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) - : chr (0x80 .|. (w .&. 0x3F)) - : toUTF8 cs - where w = ord c - --- | Ignore a Unicode byte order mark (BOM) at the beginning of the input --- -ignoreBOM :: String -> String -ignoreBOM ('\xFEFF':string) = string -ignoreBOM string = string - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Reads lazily using ordinary 'readFile'. --- -readUTF8File :: FilePath -> IO String -readUTF8File f = fmap (ignoreBOM . fromUTF8) - . hGetContents =<< openBinaryFile f ReadMode - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Same behaviour as 'withFileContents'. --- -withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a -withUTF8FileContents name action = - Exception.bracket - (openBinaryFile name ReadMode) - hClose - (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8) - --- | Writes a Unicode String as a UTF8 encoded text file. --- --- Uses 'writeFileAtomic', so provides the same guarantees. --- -writeUTF8File :: FilePath -> String -> IO () -writeUTF8File path = writeFileAtomic path . toUTF8 - --- | Fix different systems silly line ending conventions -normaliseLineEndings :: String -> String -normaliseLineEndings [] = [] -normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows -normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old osx -normaliseLineEndings ( c :s) = c : normaliseLineEndings s - --- ------------------------------------------------------------ --- * Common utils --- ------------------------------------------------------------ - -equating :: Eq a => (b -> a) -> b -> b -> Bool -equating p x y = p x == p y - -comparing :: Ord a => (b -> a) -> b -> b -> Ordering -comparing p x y = p x `compare` p y - -isInfixOf :: String -> String -> Bool -isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) - -intercalate :: [a] -> [[a]] -> [a] -intercalate sep = concat . intersperse sep - -lowercase :: String -> String -lowercase = map Char.toLower diff --git a/cabal/cabal/Distribution/System.hs b/cabal/cabal/Distribution/System.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/System.hs +++ /dev/null @@ -1,179 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.System --- Copyright : Duncan Coutts 2007-2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Cabal often needs to do slightly different things on specific platforms. You --- probably know about the 'System.Info.os' however using that is very --- inconvenient because it is a string and different Haskell implementations --- do not agree on using the same strings for the same platforms! (In --- particular see the controversy over \"windows\" vs \"ming32\"). So to make it --- more consistent and easy to use we have an 'OS' enumeration. --- -module Distribution.System ( - -- * Operating System - OS(..), - buildOS, - - -- * Machine Architecture - Arch(..), - buildArch, - - -- * Platform is a pair of arch and OS - Platform(..), - buildPlatform, - ) where - -import qualified System.Info (os, arch) -import qualified Data.Char as Char (toLower, isAlphaNum) - -import Distribution.Text (Text(..), display) -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<>)) - --- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. --- --- 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 --- 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. --- --- 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 --- which enables us to warn about such deprecated aliases. --- -data ClassificationStrictness = Permissive | Compat | Strict - --- ------------------------------------------------------------ --- * Operating System --- ------------------------------------------------------------ - -data OS = Linux | Windows | OSX -- teir 1 desktop OSs - | FreeBSD | OpenBSD | NetBSD -- other free unix OSs - | Solaris | AIX | HPUX | IRIX -- ageing Unix OSs - | HaLVM -- bare metal / VMs / hypervisors - | OtherOS String - deriving (Eq, Ord, Show, Read) - ---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? - -knownOSs :: [OS] -knownOSs = [Linux, Windows, OSX - ,FreeBSD, OpenBSD, NetBSD - ,Solaris, AIX, HPUX, IRIX - ,HaLVM] - -osAliases :: ClassificationStrictness -> OS -> [String] -osAliases Permissive Windows = ["mingw32", "cygwin32"] -osAliases Compat Windows = ["mingw32", "win32"] -osAliases _ OSX = ["darwin"] -osAliases Permissive FreeBSD = ["kfreebsdgnu"] -osAliases Permissive Solaris = ["solaris2"] -osAliases _ _ = [] - -instance Text OS where - disp (OtherOS name) = Disp.text name - disp other = Disp.text (lowercase (show other)) - - parse = fmap (classifyOS Compat) ident - -classifyOS :: ClassificationStrictness -> String -> OS -classifyOS strictness s = - case lookup (lowercase s) osMap of - Just os -> os - Nothing -> OtherOS s - where - osMap = [ (name, os) - | os <- knownOSs - , name <- display os : osAliases strictness os ] - -buildOS :: OS -buildOS = classifyOS Permissive System.Info.os - --- ------------------------------------------------------------ --- * Machine Architecture --- ------------------------------------------------------------ - -data Arch = I386 | X86_64 | PPC | PPC64 | Sparc - | Arm | Mips | SH - | IA64 | S390 - | Alpha | Hppa | Rs6000 - | M68k | Vax - | OtherArch String - deriving (Eq, Ord, Show, Read) - -knownArches :: [Arch] -knownArches = [I386, X86_64, PPC, PPC64, Sparc - ,Arm, Mips, SH - ,IA64, S390 - ,Alpha, Hppa, Rs6000 - ,M68k, Vax] - -archAliases :: ClassificationStrictness -> Arch -> [String] -archAliases Strict _ = [] -archAliases Compat _ = [] -archAliases _ PPC = ["powerpc"] -archAliases _ PPC64 = ["powerpc64"] -archAliases _ Sparc = ["sparc64", "sun4"] -archAliases _ Mips = ["mipsel", "mipseb"] -archAliases _ Arm = ["armeb", "armel"] -archAliases _ _ = [] - -instance Text Arch where - disp (OtherArch name) = Disp.text name - disp other = Disp.text (lowercase (show other)) - - parse = fmap (classifyArch Strict) ident - -classifyArch :: ClassificationStrictness -> String -> Arch -classifyArch strictness s = - case lookup (lowercase s) archMap of - Just arch -> arch - Nothing -> OtherArch s - where - archMap = [ (name, arch) - | arch <- knownArches - , name <- display arch : archAliases strictness arch ] - -buildArch :: Arch -buildArch = classifyArch Permissive System.Info.arch - --- ------------------------------------------------------------ --- * Platform --- ------------------------------------------------------------ - -data Platform = Platform Arch OS - deriving (Eq, Ord, Show, Read) - -instance Text Platform where - disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os - parse = do - arch <- parse - _ <- Parse.char '-' - os <- parse - return (Platform arch os) - -buildPlatform :: Platform -buildPlatform = Platform buildArch buildOS - --- Utils: - -ident :: Parse.ReadP r String -ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') - --TODO: probably should disallow starting with a number - -lowercase :: String -> String -lowercase = map Char.toLower diff --git a/cabal/cabal/Distribution/TestSuite.hs b/cabal/cabal/Distribution/TestSuite.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/TestSuite.hs +++ /dev/null @@ -1,310 +0,0 @@ -{-# LANGUAGE CPP, ExistentialQuantification #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.TestSuite --- Copyright : Thomas Tuegel 2010 --- --- 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. -} - -#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610)) -#define NEW_EXCEPTION -#endif - -module Distribution.TestSuite - ( -- * Example - -- $example - -- * Options - Options(..) - , lookupOption - , TestOptions(..) - -- * Tests - , Test - , pure, impure - , Result(..) - , ImpureTestable(..) - , PureTestable(..) - ) where - -#ifdef NEW_EXCEPTION -import Control.Exception ( evaluate, catch, throw, SomeException, fromException ) -#else -import Control.Exception ( evaluate, catch, throw, Exception(IOException) ) -#endif - ---TODO: it is totally unreasonable that we have to import things from GHC.* here. --- see ghc ticket #3517 -#ifdef __GLASGOW_HASKELL__ -#if __GLASGOW_HASKELL__ >= 612 -import GHC.IO.Exception ( IOErrorType(Interrupted) ) -#else -import GHC.IOBase ( IOErrorType(Interrupted) ) -#endif -import System.IO.Error ( ioeGetErrorType ) -#endif - -import Data.List ( unionBy ) -import Data.Monoid ( Monoid(..) ) -import Data.Typeable ( TypeRep ) -import Prelude hiding ( catch ) - --- | 'Options' are provided to pass options to test runners, making tests --- reproducable. Each option is a @('String', 'String')@ of the form --- @(Name, Value)@. Use 'mappend' to combine sets of 'Options'; if the same --- option is given different values, the value from the left argument of --- 'mappend' will be used. -newtype Options = Options [(String, String)] - deriving (Read, Show, Eq) - -instance Monoid Options where - mempty = Options [] - mappend (Options a) (Options b) = Options $ unionBy (equating fst) a b - where - equating p x y = p x == p y - - -class TestOptions t where - -- | The name of the test. - name :: t -> String - - -- | A list of the options a test recognizes. The name and 'TypeRep' are - -- provided so that test agents can ensure that user-specified options are - -- correctly typed. - options :: t -> [(String, TypeRep)] - - -- | The default options for a test. Test frameworks should provide a new - -- random seed, if appropriate. - defaultOptions :: t -> IO Options - - -- | Try to parse the provided options. Return the names of unparsable - -- options. This allows test agents to detect bad user-specified options. - check :: t -> Options -> [String] - --- | Read an option from the specified set of 'Options'. It is an error to --- lookup an option that has not been specified. For this reason, test agents --- should 'mappend' any 'Options' against the 'defaultOptions' for a test, so --- the default value specified by the test framework will be used for any --- otherwise-unspecified options. -lookupOption :: Read r => String -> Options -> r -lookupOption n (Options opts) = - case lookup n opts of - Just str -> read str - Nothing -> error $ "test option not specified: " ++ n - -data Result - = Pass -- ^ indicates a successful test - | Fail String -- ^ indicates a test completed unsuccessfully; - -- the 'String' value should be a human-readable message - -- indicating how the test failed. - | Error String -- ^ indicates a test that could not be - -- completed due to some error; the test framework - -- should provide a message indicating the - -- nature of the error. - deriving (Read, Show, Eq) - --- | Class abstracting impure tests. Test frameworks should implement this --- class only as a last resort for test types which actually require 'IO'. --- In particular, tests that simply require pseudo-random number generation can --- be implemented as pure tests. -class TestOptions t => ImpureTestable t where - -- | Runs an impure test and returns the result. Test frameworks - -- implementing this class are responsible for converting any exceptions to - -- the correct 'Result' value. - runM :: t -> Options -> IO Result - --- | Class abstracting pure tests. Test frameworks should prefer to implement --- this class over 'ImpureTestable'. A default instance exists so that any pure --- test can be lifted into an impure test; when lifted, any exceptions are --- automatically caught. Test agents that lift pure tests themselves must --- handle exceptions. -class TestOptions t => PureTestable t where - -- | The result of a pure test. - run :: t -> Options -> Result - --- | 'Test' is a wrapper for pure and impure tests so that lists containing --- arbitrary test types can be constructed. -data Test - = forall p. PureTestable p => PureTest p - | forall i. ImpureTestable i => ImpureTest i - --- | A convenient function for wrapping pure tests into 'Test's. -pure :: PureTestable p => p -> Test -pure = PureTest - --- | A convenient function for wrapping impure tests into 'Test's. -impure :: ImpureTestable i => i -> Test -impure = ImpureTest - -instance TestOptions Test where - name (PureTest p) = name p - name (ImpureTest i) = name i - - options (PureTest p) = options p - options (ImpureTest i) = options i - - defaultOptions (PureTest p) = defaultOptions p - defaultOptions (ImpureTest p) = defaultOptions p - - check (PureTest p) = check p - check (ImpureTest p) = check p - -instance ImpureTestable Test where - runM (PureTest p) o = catch (evaluate $ run p o) handler - - -- Because we have to handle old and new style exceptions, GHC and non-GHC - -- this code is totally horrible and really fragile. Has to be tested with - -- lots of ghc versions to check it is right, and with non-ghc too. :-( -#ifdef NEW_EXCEPTION - where - handler :: SomeException -> IO Result - handler e = case fromException e of - Just ioe | isInterruptedError ioe -> throw e - _ -> return (Error (show e)) -#else - where - handler :: Exception -> IO Result - handler e = case e of - IOException ioe | isInterruptedError ioe -> throw e - _ -> return (Error (show e)) -#endif - - -- We do not want to catch control-C here, but only GHC - -- defines the Interrupted exception type! (ticket #3517) - isInterruptedError ioe = -#ifdef __GLASGOW_HASKELL__ - ioeGetErrorType ioe == Interrupted -#else - False -#endif - - runM (ImpureTest i) o = runM i o - --- $example --- The following terms are used carefully throughout this file: --- --- [test interface] The interface provided by this module. --- --- [test agent] A program used by package users to coordinates the running --- of tests and the reporting of their results. --- --- [test framework] A package used by software authors to specify tests, --- such as QuickCheck or HUnit. --- --- Test frameworks are obligated to supply, at least, instances of the --- 'TestOptions' and 'ImpureTestable' classes. It is preferred that test --- frameworks implement 'PureTestable' whenever possible, so that test agents --- have an assurance that tests can be safely run in parallel. --- --- Test agents that allow the user to specify options should avoid setting --- options not listed by the 'options' method. Test agents should use 'check' --- before running tests with non-default options. Test frameworks must --- implement a 'check' function that attempts to parse the given options safely. --- --- The packages cabal-test-hunit, cabal-test-quickcheck1, and --- cabal-test-quickcheck2 provide simple interfaces to these popular test --- frameworks. An example from cabal-test-quickcheck2 is shown below. A --- better implementation would eliminate the console output from QuickCheck\'s --- built-in runner and provide an instance of 'PureTestable' instead of --- 'ImpureTestable'. --- --- > import Control.Monad (liftM) --- > import Data.Maybe (catMaybes, fromJust, maybe) --- > import Data.Typeable (Typeable(..)) --- > import qualified Distribution.TestSuite as Cabal --- > import System.Random (newStdGen, next, StdGen) --- > import qualified Test.QuickCheck as QC --- > --- > data QCTest = forall prop. QC.Testable prop => QCTest String prop --- > --- > test :: QC.Testable prop => String -> prop -> Cabal.Test --- > test n p = Cabal.impure $ QCTest n p --- > --- > instance Cabal.TestOptions QCTest where --- > name (QCTest n _) = n --- > --- > options _ = --- > [ ("std-gen", typeOf (undefined :: String)) --- > , ("max-success", typeOf (undefined :: Int)) --- > , ("max-discard", typeOf (undefined :: Int)) --- > , ("size", typeOf (undefined :: Int)) --- > ] --- > --- > defaultOptions _ = do --- > rng <- newStdGen --- > return $ Cabal.Options $ --- > [ ("std-gen", show rng) --- > , ("max-success", show $ QC.maxSuccess QC.stdArgs) --- > , ("max-discard", show $ QC.maxDiscard QC.stdArgs) --- > , ("size", show $ QC.maxSize QC.stdArgs) --- > ] --- > --- > check t (Cabal.Options opts) = catMaybes --- > [ maybeNothing "max-success" ([] :: [(Int, String)]) --- > , maybeNothing "max-discard" ([] :: [(Int, String)]) --- > , maybeNothing "size" ([] :: [(Int, String)]) --- > ] --- > -- There is no need to check the parsability of "std-gen" --- > -- because the Read instance for StdGen always succeeds. --- > where --- > maybeNothing n x = --- > maybe Nothing (\str -> --- > if reads str == x then Just n else Nothing) --- > $ lookup n opts --- > --- > instance Cabal.ImpureTestable QCTest where --- > runM (QCTest _ prop) o = --- > catch go (return . Cabal.Error . show) --- > where --- > go = do --- > result <- QC.quickCheckWithResult args prop --- > return $ case result of --- > QC.Success {} -> Cabal.Pass --- > QC.GaveUp {}-> --- > Cabal.Fail $ "gave up after " --- > ++ show (QC.numTests result) --- > ++ " tests" --- > QC.Failure {} -> Cabal.Fail $ QC.reason result --- > QC.NoExpectedFailure {} -> --- > Cabal.Fail "passed (expected failure)" --- > args = QC.Args --- > { QC.replay = Just --- > ( Cabal.lookupOption "std-gen" o --- > , Cabal.lookupOption "size" o --- > ) --- > , QC.maxSuccess = Cabal.lookupOption "max-success" o --- > , QC.maxDiscard = Cabal.lookupOption "max-discard" o --- > , QC.maxSize = Cabal.lookupOption "size" o --- > } diff --git a/cabal/cabal/Distribution/Text.hs b/cabal/cabal/Distribution/Text.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Text.hs +++ /dev/null @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Text --- Copyright : Duncan Coutts 2007 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defines a 'Text' class which is a bit like the 'Read' and 'Show' --- classes. The difference is that is uses a modern pretty printer and parser --- system and the format is not expected to be Haskell concrete syntax but --- rather the external human readable representation used by Cabal. --- -module Distribution.Text ( - Text(..), - display, - simpleParse, - ) where - -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp - -import Data.Version (Version(Version)) -import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace) - -class Text a where - disp :: a -> Disp.Doc - parse :: Parse.ReadP r a - -display :: Text a => a -> String -display = Disp.renderStyle style . disp - where style = Disp.Style { - Disp.mode = Disp.PageMode, - Disp.lineLength = 79, - Disp.ribbonsPerLine = 1.0 - } - -simpleParse :: Text a => String -> Maybe a -simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str - , all Char.isSpace s ] of - [] -> Nothing - (p:_) -> Just p - --- ----------------------------------------------------------------------------- --- Instances for types from the base package - -instance Text Bool where - disp = Disp.text . show - parse = Parse.choice [ (Parse.string "True" Parse.+++ - Parse.string "true") >> return True - , (Parse.string "False" Parse.+++ - Parse.string "false") >> return False ] - -instance Text Version where - disp (Version branch _tags) -- Death to version tags!! - = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch)) - - 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? - where - digits = do - first <- Parse.satisfy Char.isDigit - if first == '0' - then return 0 - else do rest <- Parse.munch Char.isDigit - return (read (first : rest)) diff --git a/cabal/cabal/Distribution/Verbosity.hs b/cabal/cabal/Distribution/Verbosity.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Verbosity.hs +++ /dev/null @@ -1,113 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Verbosity --- Copyright : Ian Lynagh 2007 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- A simple 'Verbosity' type with associated utilities. There are 4 standard --- verbosity levels from 'silent', 'normal', 'verbose' up to 'deafening'. This --- is used for deciding what logging messages to print. - --- 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. -} - -module Distribution.Verbosity ( - -- * Verbosity - Verbosity, - silent, normal, verbose, deafening, - moreVerbose, lessVerbose, - intToVerbosity, flagToVerbosity, - showForCabal, showForGHC - ) where - -import Data.List (elemIndex) -import Distribution.ReadE - -data Verbosity = Silent | Normal | Verbose | Deafening - deriving (Show, Read, Eq, Ord, Enum, Bounded) - --- We shouldn't print /anything/ unless an error occurs in silent mode -silent :: Verbosity -silent = Silent - --- Print stuff we want to see by default -normal :: Verbosity -normal = Normal - --- Be more verbose about what's going on -verbose :: Verbosity -verbose = Verbose - --- Not only are we verbose ourselves (perhaps even noisier than when --- being "verbose"), but we tell everything we run to be verbose too -deafening :: Verbosity -deafening = Deafening - -moreVerbose :: Verbosity -> Verbosity -moreVerbose Silent = Silent --silent should stay silent -moreVerbose Normal = Verbose -moreVerbose Verbose = Deafening -moreVerbose Deafening = Deafening - -lessVerbose :: Verbosity -> Verbosity -lessVerbose Deafening = Deafening -lessVerbose Verbose = Normal -lessVerbose Normal = Silent -lessVerbose Silent = Silent - -intToVerbosity :: Int -> Maybe Verbosity -intToVerbosity 0 = Just Silent -intToVerbosity 1 = Just Normal -intToVerbosity 2 = Just Verbose -intToVerbosity 3 = Just Deafening -intToVerbosity _ = Nothing - -flagToVerbosity :: ReadE Verbosity -flagToVerbosity = ReadE $ \s -> - case reads s of - [(i, "")] -> - case intToVerbosity i of - Just v -> Right v - Nothing -> Left ("Bad verbosity: " ++ show i ++ - ". Valid values are 0..3") - _ -> Left ("Can't parse verbosity " ++ s) - -showForCabal, showForGHC :: Verbosity -> String - -showForCabal v = maybe (error "unknown verbosity") show $ - elemIndex v [silent,normal,verbose,deafening] -showForGHC v = maybe (error "unknown verbosity") show $ - elemIndex v [silent,normal,__,verbose,deafening] - where __ = silent -- this will be always ignored by elemIndex diff --git a/cabal/cabal/Distribution/Version.hs b/cabal/cabal/Distribution/Version.hs deleted file mode 100644 --- a/cabal/cabal/Distribution/Version.hs +++ /dev/null @@ -1,742 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Version --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- Duncan Coutts 2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Exports the 'Version' type along with a parser and pretty printer. A version --- 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(..), - - -- * Version ranges - VersionRange(..), - - -- ** Constructing - anyVersion, noVersion, - thisVersion, notThisVersion, - laterVersion, earlierVersion, - orLaterVersion, orEarlierVersion, - unionVersionRanges, intersectVersionRanges, - withinVersion, - betweenVersionsInclusive, - - -- ** Inspection - withinRange, - isAnyVersion, - isNoVersion, - isSpecificVersion, - simplifyVersionRange, - foldVersionRange, - foldVersionRange', - - -- * Version intervals view - asVersionIntervals, - VersionInterval, - LowerBound(..), - UpperBound(..), - Bound(..), - - -- ** 'VersionIntervals' abstract type - -- | The 'VersionIntervals' type and the accompanying functions are exposed - -- primarily for completeness and testing purposes. In practice - -- 'asVersionIntervals' is the main function to use to - -- view a 'VersionRange' as a bunch of 'VersionInterval's. - -- - VersionIntervals, - toVersionIntervals, - fromVersionIntervals, - withinIntervals, - versionIntervals, - mkVersionIntervals, - unionVersionIntervals, - intersectVersionIntervals, - - ) where - -import Data.Version ( Version(..) ) - -import Distribution.Text ( Text(..) ) -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP ((+++)) -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<>), (<+>)) -import qualified Data.Char as Char (isDigit) -import Control.Exception (assert) - --- ----------------------------------------------------------------------------- --- Version ranges - --- Todo: maybe move this to Distribution.Package.Version? --- (package-specific versioning scheme). - -data VersionRange - = AnyVersion - | ThisVersion Version -- = version - | LaterVersion Version -- > version (NB. not >=) - | EarlierVersion Version -- < version - | WildcardVersion Version -- == ver.* (same as >= ver && < ver+1) - | UnionVersionRanges VersionRange VersionRange - | IntersectVersionRanges VersionRange VersionRange - | VersionRangeParens VersionRange -- just '(exp)' parentheses syntax - deriving (Show,Read,Eq) - -{-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED LaterVersion "use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED EarlierVersion "use 'earlierVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED WildcardVersion "use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED UnionVersionRanges "use 'unionVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED IntersectVersionRanges "use 'intersectVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} - --- | The version range @-any@. That is, a version range containing all --- versions. --- --- > withinRange v anyVersion = True --- -anyVersion :: VersionRange -anyVersion = AnyVersion - --- | The empty version range, that is a version range containing no versions. --- --- This can be constructed using any unsatisfiable version range expression, --- for example @> 1 && < 1@. --- --- > withinRange v anyVersion = False --- -noVersion :: VersionRange -noVersion = IntersectVersionRanges (LaterVersion v) (EarlierVersion v) - where v = Version [1] [] - --- | The version range @== v@ --- --- > withinRange v' (thisVersion v) = v' == v --- -thisVersion :: Version -> VersionRange -thisVersion = ThisVersion - --- | The version range @< v || > v@ --- --- > withinRange v' (notThisVersion v) = v' /= v --- -notThisVersion :: Version -> VersionRange -notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) - --- | The version range @> v@ --- --- > withinRange v' (laterVersion v) = v' > v --- -laterVersion :: Version -> VersionRange -laterVersion = LaterVersion - --- | The version range @>= v@ --- --- > withinRange v' (orLaterVersion v) = v' >= v --- -orLaterVersion :: Version -> VersionRange -orLaterVersion v = UnionVersionRanges (ThisVersion v) (LaterVersion v) - --- | The version range @< v@ --- --- > withinRange v' (earlierVersion v) = v' < v --- -earlierVersion :: Version -> VersionRange -earlierVersion = EarlierVersion - --- | The version range @<= v@ --- --- > withinRange v' (orEarlierVersion v) = v' <= v --- -orEarlierVersion :: Version -> VersionRange -orEarlierVersion v = UnionVersionRanges (ThisVersion v) (EarlierVersion v) - --- | The version range @vr1 || vr2@ --- --- > withinRange v' (unionVersionRanges vr1 vr2) --- > = withinRange v' vr1 || withinRange v' vr2 --- -unionVersionRanges :: VersionRange -> VersionRange -> VersionRange -unionVersionRanges = UnionVersionRanges - --- | The version range @vr1 && vr2@ --- --- > withinRange v' (intersectVersionRanges vr1 vr2) --- > = withinRange v' vr1 && withinRange v' vr2 --- -intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange -intersectVersionRanges = IntersectVersionRanges - --- | The version range @== v.*@. --- --- For example, for version @1.2@, the version range @== 1.2.*@ is the same as --- @>= 1.2 && < 1.3@ --- --- > withinRange v' (laterVersion v) = v' >= v && v' < upper v --- > where --- > upper (Version lower t) = Version (init lower ++ [last lower + 1]) t --- -withinVersion :: Version -> VersionRange -withinVersion = WildcardVersion - --- | The version range @>= v1 && <= v2@. --- --- In practice this is not very useful because we normally use inclusive lower --- bounds and exclusive upper bounds. --- --- > withinRange v' (laterVersion v) = v' > v --- -betweenVersionsInclusive :: Version -> Version -> VersionRange -betweenVersionsInclusive v1 v2 = - IntersectVersionRanges (orLaterVersion v1) (orEarlierVersion v2) - -{-# DEPRECATED betweenVersionsInclusive - "In practice this is not very useful because we normally use inclusive lower bounds and exclusive upper bounds" - #-} - --- | Fold over the basic syntactic structure of a 'VersionRange'. --- --- This provides a syntacic view of the expression defining the version range. --- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented --- in terms of the other basic syntax. --- --- For a semantic view use 'asVersionIntervals'. --- -foldVersionRange :: a -- ^ @\"-any\"@ version - -> (Version -> a) -- ^ @\"== v\"@ - -> (Version -> a) -- ^ @\"> v\"@ - -> (Version -> a) -- ^ @\"< v\"@ - -> (a -> a -> a) -- ^ @\"_ || _\"@ union - -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection - -> VersionRange -> a -foldVersionRange anyv this later earlier union intersect = fold - where - fold AnyVersion = anyv - fold (ThisVersion v) = this v - fold (LaterVersion v) = later v - fold (EarlierVersion v) = earlier v - fold (WildcardVersion v) = fold (wildcard v) - fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) - fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) - fold (VersionRangeParens v) = fold v - - wildcard v = intersectVersionRanges - (orLaterVersion v) - (earlierVersion (wildcardUpperBound v)) - --- | An extended variant of 'foldVersionRange' that also provides a view of --- in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented --- explicitly rather than in terms of the other basic syntax. --- -foldVersionRange' :: a -- ^ @\"-any\"@ version - -> (Version -> a) -- ^ @\"== v\"@ - -> (Version -> a) -- ^ @\"> v\"@ - -> (Version -> a) -- ^ @\"< v\"@ - -> (Version -> a) -- ^ @\">= v\"@ - -> (Version -> a) -- ^ @\"<= v\"@ - -> (Version -> Version -> a) -- ^ @\"== v.*\"@ wildcard. The - -- function is passed the - -- inclusive lower bound and the - -- exclusive upper bounds of the - -- range defined by the wildcard. - -> (a -> a -> a) -- ^ @\"_ || _\"@ union - -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection - -> (a -> a) -- ^ @\"(_)\"@ parentheses - -> VersionRange -> a -foldVersionRange' anyv this later earlier orLater orEarlier - wildcard union intersect parens = fold - where - fold AnyVersion = anyv - fold (ThisVersion v) = this v - fold (LaterVersion v) = later v - fold (EarlierVersion v) = earlier v - - fold (UnionVersionRanges (ThisVersion v) - (LaterVersion v')) | v==v' = orLater v - fold (UnionVersionRanges (LaterVersion v) - (ThisVersion v')) | v==v' = orLater v - fold (UnionVersionRanges (ThisVersion v) - (EarlierVersion v')) | v==v' = orEarlier v - fold (UnionVersionRanges (EarlierVersion v) - (ThisVersion v')) | v==v' = orEarlier v - - fold (WildcardVersion v) = wildcard v (wildcardUpperBound v) - fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) - fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) - fold (VersionRangeParens v) = parens (fold v) - - --- | Does this version fall within the given range? --- --- This is the evaluation function for the 'VersionRange' type. --- -withinRange :: Version -> VersionRange -> Bool -withinRange v = foldVersionRange - True - (\v' -> versionBranch v == versionBranch v') - (\v' -> versionBranch v > versionBranch v') - (\v' -> versionBranch v < versionBranch v') - (||) - (&&) - --- | View a 'VersionRange' as a union of intervals. --- --- This provides a canonical view of the semantics of a 'VersionRange' as --- opposed to the syntax of the expression used to define it. For the syntactic --- view use 'foldVersionRange'. --- --- Each interval is non-empty. The sequence is in increasing order and no --- intervals overlap or touch. Therefore only the first and last can be --- unbounded. The sequence can be empty if the range is empty --- (e.g. a range expression like @< 1 && > 2@). --- --- Other checks are trivial to implement using this view. For example: --- --- > isNoVersion vr | [] <- asVersionIntervals vr = True --- > | otherwise = False --- --- > isSpecificVersion vr --- > | [(LowerBound v InclusiveBound --- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr --- > , v == v' = Just v --- > | otherwise = Nothing --- -asVersionIntervals :: VersionRange -> [VersionInterval] -asVersionIntervals = versionIntervals . toVersionIntervals - --- | Does this 'VersionRange' place any restriction on the 'Version' or is it --- in fact equivalent to 'AnyVersion'. --- --- Note this is a semantic check, not simply a syntactic check. So for example --- the following is @True@ (for all @v@). --- --- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v) --- -isAnyVersion :: VersionRange -> Bool -isAnyVersion vr = case asVersionIntervals vr of - [(LowerBound v InclusiveBound, NoUpperBound)] | isVersion0 v -> True - _ -> False - --- | This is the converse of 'isAnyVersion'. It check if the version range is --- empty, if there is no possible version that satisfies the version range. --- --- For example this is @True@ (for all @v@): --- --- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v) --- -isNoVersion :: VersionRange -> Bool -isNoVersion vr = case asVersionIntervals vr of - [] -> True - _ -> False - --- | Is this version range in fact just a specific version? --- --- For example the version range @\">= 3 && <= 3\"@ contains only the version --- @3@. --- -isSpecificVersion :: VersionRange -> Maybe Version -isSpecificVersion vr = case asVersionIntervals vr of - [(LowerBound v InclusiveBound - ,UpperBound v' InclusiveBound)] - | v == v' -> Just v - _ -> Nothing - --- | Simplify a 'VersionRange' expression. For non-empty version ranges --- this produces a canonical form. Empty or inconsistent version ranges --- are left as-is because that provides more information. --- --- If you need a canonical form use --- @fromVersionIntervals . toVersionIntervals@ --- --- It satisfies the following properties: --- --- > withinRange v (simplifyVersionRange r) = withinRange v r --- --- > withinRange v r = withinRange v r' --- > ==> simplifyVersionRange r = simplifyVersionRange r' --- > || isNoVersion r --- > || isNoVersion r' --- -simplifyVersionRange :: VersionRange -> VersionRange -simplifyVersionRange vr - -- If the version range is inconsistent then we just return the - -- original since that has more information than ">1 && < 1", which - -- is the canonical inconsistent version range. - | null (versionIntervals vi) = vr - | otherwise = fromVersionIntervals vi - where - vi = toVersionIntervals vr - ----------------------------- --- Wildcard range utilities --- - -wildcardUpperBound :: Version -> Version -wildcardUpperBound (Version lowerBound ts) = (Version upperBound ts) - where - upperBound = init lowerBound ++ [last lowerBound + 1] - -isWildcardRange :: Version -> Version -> Bool -isWildcardRange (Version branch1 _) (Version branch2 _) = check branch1 branch2 - where check (n:[]) (m:[]) | n+1 == m = True - check (n:ns) (m:ms) | n == m = check ns ms - check _ _ = False - ------------------- --- Intervals view --- - --- | A complementary representation of a 'VersionRange'. Instead of a boolean --- version predicate it uses an increasing sequence of non-overlapping, --- non-empty intervals. --- --- The key point is that this representation gives a canonical representation --- for the semantics of 'VersionRange's. This makes it easier to check things --- like whether a version range is empty, covers all versions, or requires a --- certain minimum or maximum version. It also makes it easy to check equality --- or containment. It also makes it easier to identify \'simple\' version --- predicates for translation into foreign packaging systems that do not --- support complex version range expressions. --- -newtype VersionIntervals = VersionIntervals [VersionInterval] - deriving (Eq, Show) - --- | Inspect the list of version intervals. --- -versionIntervals :: VersionIntervals -> [VersionInterval] -versionIntervals (VersionIntervals is) = is - -type VersionInterval = (LowerBound, UpperBound) -data LowerBound = LowerBound Version !Bound deriving (Eq, Show) -data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show) -data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) - -minLowerBound :: LowerBound -minLowerBound = LowerBound (Version [0] []) InclusiveBound - -isVersion0 :: Version -> Bool -isVersion0 (Version [0] _) = True -isVersion0 _ = False - -instance Ord LowerBound where - LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of - LT -> True - EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound) - GT -> False - -instance Ord UpperBound where - _ <= NoUpperBound = True - NoUpperBound <= UpperBound _ _ = False - UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of - LT -> True - EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound) - GT -> False - -invariant :: VersionIntervals -> Bool -invariant (VersionIntervals intervals) = all validInterval intervals - && all doesNotTouch' adjacentIntervals - where - doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool - doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' - - adjacentIntervals :: [(VersionInterval, VersionInterval)] - adjacentIntervals - | null intervals = [] - | otherwise = zip intervals (tail intervals) - -checkInvariant :: VersionIntervals -> VersionIntervals -checkInvariant is = assert (invariant is) is - --- | 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 --- satisfied the function returns @Nothing@. --- -mkVersionIntervals :: [VersionInterval] -> Maybe VersionIntervals -mkVersionIntervals intervals - | invariant (VersionIntervals intervals) = Just (VersionIntervals intervals) - | otherwise = Nothing - -validVersion :: Version -> Bool -validVersion (Version [] _) = False -validVersion (Version vs _) = all (>=0) vs - -validInterval :: (LowerBound, UpperBound) -> Bool -validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i - where - validLower (LowerBound v _) = validVersion v - validUpper NoUpperBound = True - validUpper (UpperBound v _) = validVersion v - --- Check an interval is non-empty --- -nonEmpty :: VersionInterval -> Bool -nonEmpty (_, NoUpperBound ) = True -nonEmpty (LowerBound l lb, UpperBound u ub) = - (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) - --- Check an upper bound does not intersect, or even touch a lower bound: --- --- ---| or ---) but not ---] or ---) or ---] --- |--- (--- (--- [--- [--- --- -doesNotTouch :: UpperBound -> LowerBound -> Bool -doesNotTouch NoUpperBound _ = False -doesNotTouch (UpperBound u ub) (LowerBound l lb) = - u < l - || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) - --- | Check an upper bound does not intersect a lower bound: --- --- ---| or ---) or ---] or ---) but not ---] --- |--- (--- (--- [--- [--- --- -doesNotIntersect :: UpperBound -> LowerBound -> Bool -doesNotIntersect NoUpperBound _ = False -doesNotIntersect (UpperBound u ub) (LowerBound l lb) = - u < l - || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) - --- | Test if a version falls within the version intervals. --- --- It exists mostly for completeness and testing. It satisfies the following --- properties: --- --- > withinIntervals v (toVersionIntervals vr) = withinRange v vr --- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs) --- -withinIntervals :: Version -> VersionIntervals -> Bool -withinIntervals v (VersionIntervals intervals) = any withinInterval intervals - where - withinInterval (lowerBound, upperBound) = withinLower lowerBound - && withinUpper upperBound - withinLower (LowerBound v' ExclusiveBound) = v' < v - withinLower (LowerBound v' InclusiveBound) = v' <= v - - withinUpper NoUpperBound = True - withinUpper (UpperBound v' ExclusiveBound) = v' > v - withinUpper (UpperBound v' InclusiveBound) = v' >= v - --- | Convert a 'VersionRange' to a sequence of version intervals. --- -toVersionIntervals :: VersionRange -> VersionIntervals -toVersionIntervals = foldVersionRange - ( chkIvl (minLowerBound, NoUpperBound)) - (\v -> chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)) - (\v -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound)) - (\v -> if isVersion0 v then VersionIntervals [] else - chkIvl (minLowerBound, UpperBound v ExclusiveBound)) - unionVersionIntervals - intersectVersionIntervals - where - chkIvl interval = checkInvariant (VersionIntervals [interval]) - --- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression --- representing the version intervals. --- -fromVersionIntervals :: VersionIntervals -> VersionRange -fromVersionIntervals (VersionIntervals []) = noVersion -fromVersionIntervals (VersionIntervals intervals) = - foldr1 UnionVersionRanges [ interval l u | (l, u) <- intervals ] - - where - interval (LowerBound v InclusiveBound) - (UpperBound v' InclusiveBound) | v == v' - = ThisVersion v - interval (LowerBound v InclusiveBound) - (UpperBound v' ExclusiveBound) | isWildcardRange v v' - = WildcardVersion v - interval l u = lowerBound l `intersectVersionRanges'` upperBound u - - lowerBound (LowerBound v InclusiveBound) - | isVersion0 v = AnyVersion - | otherwise = orLaterVersion v - lowerBound (LowerBound v ExclusiveBound) = LaterVersion v - - upperBound NoUpperBound = AnyVersion - upperBound (UpperBound v InclusiveBound) = orEarlierVersion v - upperBound (UpperBound v ExclusiveBound) = EarlierVersion v - - intersectVersionRanges' vr AnyVersion = vr - intersectVersionRanges' AnyVersion vr = vr - intersectVersionRanges' vr vr' = IntersectVersionRanges vr vr' - -unionVersionIntervals :: VersionIntervals -> VersionIntervals - -> VersionIntervals -unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = - checkInvariant (VersionIntervals (union is0 is'0)) - where - union is [] = is - union [] is' = is' - union (i:is) (i':is') = case unionInterval i i' of - Left Nothing -> i : union is (i' :is') - Left (Just i'') -> union is (i'':is') - Right Nothing -> i' : union (i :is) is' - Right (Just i'') -> union (i'':is) is' - -unionInterval :: VersionInterval -> VersionInterval - -> Either (Maybe VersionInterval) (Maybe VersionInterval) -unionInterval (lower , upper ) (lower', upper') - - -- Non-intersecting intervals with the left interval ending first - | upper `doesNotTouch` lower' = Left Nothing - - -- Non-intersecting intervals with the right interval first - | upper' `doesNotTouch` lower = Right Nothing - - -- Complete or partial overlap, with the left interval ending first - | upper <= upper' = lowerBound `seq` - Left (Just (lowerBound, upper')) - - -- Complete or partial overlap, with the left interval ending first - | otherwise = lowerBound `seq` - Right (Just (lowerBound, upper)) - where - lowerBound = min lower lower' - -intersectVersionIntervals :: VersionIntervals -> VersionIntervals - -> VersionIntervals -intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = - checkInvariant (VersionIntervals (intersect is0 is'0)) - where - intersect _ [] = [] - intersect [] _ = [] - intersect (i:is) (i':is') = case intersectInterval i i' of - Left Nothing -> intersect is (i':is') - Left (Just i'') -> i'' : intersect is (i':is') - Right Nothing -> intersect (i:is) is' - Right (Just i'') -> i'' : intersect (i:is) is' - -intersectInterval :: VersionInterval -> VersionInterval - -> Either (Maybe VersionInterval) (Maybe VersionInterval) -intersectInterval (lower , upper ) (lower', upper') - - -- Non-intersecting intervals with the left interval ending first - | upper `doesNotIntersect` lower' = Left Nothing - - -- Non-intersecting intervals with the right interval first - | upper' `doesNotIntersect` lower = Right Nothing - - -- Complete or partial overlap, with the left interval ending first - | upper <= upper' = lowerBound `seq` - Left (Just (lowerBound, upper)) - - -- Complete or partial overlap, with the right interval ending first - | otherwise = lowerBound `seq` - Right (Just (lowerBound, upper')) - where - lowerBound = max lower lower' - -------------------------------- --- Parsing and pretty printing --- - -instance Text VersionRange where - disp = fst - . foldVersionRange' -- precedence: - ( Disp.text "-any" , 0 :: Int) - (\v -> (Disp.text "==" <> disp v , 0)) - (\v -> (Disp.char '>' <> disp v , 0)) - (\v -> (Disp.char '<' <> disp v , 0)) - (\v -> (Disp.text ">=" <> disp v , 0)) - (\v -> (Disp.text "<=" <> disp v , 0)) - (\v _ -> (Disp.text "==" <> dispWild v , 0)) - (\(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)) - - where dispWild (Version b _) = - Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) - <> Disp.text ".*" - punct p p' | p < p' = Disp.parens - | otherwise = id - - parse = expr - where - expr = do Parse.skipSpaces - t <- term - Parse.skipSpaces - (do _ <- Parse.string "||" - Parse.skipSpaces - e <- expr - return (UnionVersionRanges t e) - +++ - return t) - term = do f <- factor - Parse.skipSpaces - (do _ <- Parse.string "&&" - Parse.skipSpaces - t <- term - return (IntersectVersionRanges f t) - +++ - return f) - factor = Parse.choice $ parens expr - : parseAnyVersion - : parseWildcardRange - : map parseRangeOp rangeOps - parseAnyVersion = Parse.string "-any" >> return AnyVersion - - parseWildcardRange = do - _ <- Parse.string "==" - Parse.skipSpaces - branch <- Parse.sepBy1 digits (Parse.char '.') - _ <- Parse.char '.' - _ <- Parse.char '*' - return (WildcardVersion (Version branch [])) - - parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces) - (Parse.char ')' >> Parse.skipSpaces) - (do a <- p - Parse.skipSpaces - return (VersionRangeParens a)) - - digits = do - first <- Parse.satisfy Char.isDigit - if first == '0' - then return 0 - else do rest <- Parse.munch Char.isDigit - return (read (first : rest)) - - parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse - rangeOps = [ ("<", EarlierVersion), - ("<=", orEarlierVersion), - (">", LaterVersion), - (">=", orLaterVersion), - ("==", ThisVersion) ] diff --git a/cabal/cabal/LICENSE b/cabal/cabal/LICENSE deleted file mode 100644 --- a/cabal/cabal/LICENSE +++ /dev/null @@ -1,33 +0,0 @@ -Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren, - Bjorn Bringert, Krasimir Angelov, - Malcolm Wallace, Ross Patterson, Ian Lynagh, - Duncan Coutts, Thomas Schilling -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. diff --git a/cabal/cabal/Language/Haskell/Extension.hs b/cabal/cabal/Language/Haskell/Extension.hs deleted file mode 100644 --- a/cabal/cabal/Language/Haskell/Extension.hs +++ /dev/null @@ -1,516 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Language.Haskell.Extension --- Copyright : Isaac Jones 2003-2004 --- --- 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, - - Extension(..), - KnownExtension(..), - knownExtensions, - deprecatedExtensions - ) where - -import Distribution.Text (Text(..)) -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp -import qualified Data.Char as Char (isAlphaNum) -import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) - --- ------------------------------------------------------------ --- * Language --- ------------------------------------------------------------ - --- | This represents a Haskell language dialect. --- --- Language 'Extension's are interpreted relative to one of these base --- languages. --- -data Language = - - -- | The Haskell 98 language as defined by the Haskell 98 report. - -- - Haskell98 - - -- | The Haskell 2010 language as defined by the Haskell 2010 report. - -- - | Haskell2010 - - -- | An unknown language, identified by its name. - | UnknownLanguage String - deriving (Show, Read, Eq) - -knownLanguages :: [Language] -knownLanguages = [Haskell98, Haskell2010] - -instance Text Language where - disp (UnknownLanguage other) = Disp.text other - disp other = Disp.text (show other) - - parse = do - lang <- Parse.munch1 Char.isAlphaNum - return (classifyLanguage lang) - -classifyLanguage :: String -> Language -classifyLanguage = \str -> case lookup str langTable of - Just lang -> lang - Nothing -> UnknownLanguage str - where - langTable = [ (show lang, lang) - | lang <- knownLanguages ] - --- ------------------------------------------------------------ --- * Extension --- ------------------------------------------------------------ - --- 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) --- --- | This represents language extensions beyond a base 'Language' definition --- (such as 'Haskell98') that are supported by some implementations, usually --- in some special mode. --- --- Where applicable, references are given to an implementation's --- official documentation, e.g. \"GHC § 7.2.1\" for an extension --- documented in section 7.2.1 of the GHC User's Guide. - -data Extension = - -- | Enable a known extension - EnableExtension KnownExtension - - -- | Disable a known extension - | DisableExtension KnownExtension - - -- | An unknown extension, identified by the name of its @LANGUAGE@ - -- pragma. - | UnknownExtension String - - deriving (Show, Read, Eq) - -data KnownExtension = - - -- | [GHC § 7.6.3.4] Allow overlapping class instances, - -- provided there is a unique most specific instance for each use. - OverlappingInstances - - -- | [GHC § 7.6.3.3] Ignore structural rules guaranteeing the - -- termination of class instance resolution. Termination is - -- guaranteed by a fixed-depth recursion stack, and compilation - -- may fail if this depth is exceeded. - | UndecidableInstances - - -- | [GHC § 7.6.3.4] Implies 'OverlappingInstances'. Allow the - -- implementation to choose an instance even when it is possible - -- that further instantiation of types will lead to a more specific - -- instance being applicable. - | IncoherentInstances - - -- | [GHC § 7.3.8] Allows recursive bindings in @do@ blocks, - -- using the @rec@ keyword. - | DoRec - - -- | [GHC § 7.3.8.2] Deprecated in GHC. Allows recursive bindings - -- using @mdo@, a variant of @do@. @DoRec@ provides a different, - -- preferred syntax. - | RecursiveDo - - -- | [GHC § 7.3.9] Provide syntax for writing list - -- comprehensions which iterate over several lists together, like - -- the 'zipWith' family of functions. - | ParallelListComp - - -- | [GHC § 7.6.1.1] Allow multiple parameters in a type class. - | MultiParamTypeClasses - - -- | [GHC § 7.17] Enable the dreaded monomorphism restriction. - | MonomorphismRestriction - - -- | [GHC § 7.6.2] Allow a specification attached to a - -- multi-parameter type class which indicates that some parameters - -- are entirely determined by others. The implementation will check - -- that this property holds for the declared instances, and will use - -- this property to reduce ambiguity in instance resolution. - | FunctionalDependencies - - -- | [GHC § 7.8.5] Like 'RankNTypes' but does not allow a - -- higher-rank type to itself appear on the left of a function - -- arrow. - | Rank2Types - - -- | [GHC § 7.8.5] Allow a universally-quantified type to occur on - -- the left of a function arrow. - | RankNTypes - - -- | [GHC § 7.8.5] Allow data constructors to have polymorphic - -- arguments. Unlike 'RankNTypes', does not allow this for ordinary - -- functions. - | PolymorphicComponents - - -- | [GHC § 7.4.4] Allow existentially-quantified data constructors. - | ExistentialQuantification - - -- | [GHC § 7.8.7] Cause a type variable in a signature, which has an - -- explicit @forall@ quantifier, to scope over the definition of the - -- accompanying value declaration. - | ScopedTypeVariables - - -- | Deprecated, use 'ScopedTypeVariables' instead. - | PatternSignatures - - -- | [GHC § 7.8.3] Enable implicit function parameters with dynamic - -- scope. - | ImplicitParams - - -- | [GHC § 7.8.2] Relax some restrictions on the form of the context - -- of a type signature. - | FlexibleContexts - - -- | [GHC § 7.6.3.2] Relax some restrictions on the form of the - -- context of an instance declaration. - | FlexibleInstances - - -- | [GHC § 7.4.1] Allow data type declarations with no constructors. - | EmptyDataDecls - - -- | [GHC § 4.10.3] Run the C preprocessor on Haskell source code. - | CPP - - -- | [GHC § 7.8.4] Allow an explicit kind signature giving the kind of - -- types over which a type variable ranges. - | KindSignatures - - -- | [GHC § 7.11] Enable a form of pattern which forces evaluation - -- before an attempted match, and a form of strict @let@/@where@ - -- binding. - | BangPatterns - - -- | [GHC § 7.6.3.1] Allow type synonyms in instance heads. - | TypeSynonymInstances - - -- | [GHC § 7.9] Enable Template Haskell, a system for compile-time - -- metaprogramming. - | TemplateHaskell - - -- | [GHC § 8] Enable the Foreign Function Interface. In GHC, - -- implements the standard Haskell 98 Foreign Function Interface - -- Addendum, plus some GHC-specific extensions. - | ForeignFunctionInterface - - -- | [GHC § 7.10] Enable arrow notation. - | Arrows - - -- | [GHC § 7.16] Enable generic type classes, with default instances - -- defined in terms of the algebraic structure of a type. - | Generics - - -- | [GHC § 7.3.11] Enable the implicit importing of the module - -- @Prelude@. When disabled, when desugaring certain built-in syntax - -- into ordinary identifiers, use whatever is in scope rather than the - -- @Prelude@ -- version. - | ImplicitPrelude - - -- | [GHC § 7.3.15] Enable syntax for implicitly binding local names - -- corresponding to the field names of a record. Puns bind specific - -- names, unlike 'RecordWildCards'. - | NamedFieldPuns - - -- | [GHC § 7.3.5] Enable a form of guard which matches a pattern and - -- binds variables. - | PatternGuards - - -- | [GHC § 7.5.4] Allow a type declared with @newtype@ to use - -- @deriving@ for any class with an instance for the underlying type. - | GeneralizedNewtypeDeriving - - -- | [Hugs § 7.1] Enable the \"Trex\" extensible records system. - | ExtensibleRecords - - -- | [Hugs § 7.2] Enable type synonyms which are transparent in - -- some definitions and opaque elsewhere, as a way of implementing - -- abstract datatypes. - | RestrictedTypeSynonyms - - -- | [Hugs § 7.3] Enable an alternate syntax for string literals, - -- with string templating. - | HereDocuments - - -- | [GHC § 7.3.2] Allow the character @#@ as a postfix modifier on - -- identifiers. Also enables literal syntax for unboxed values. - | MagicHash - - -- | [GHC § 7.7] Allow data types and type synonyms which are - -- indexed by types, i.e. ad-hoc polymorphism for types. - | TypeFamilies - - -- | [GHC § 7.5.2] Allow a standalone declaration which invokes the - -- type class @deriving@ mechanism. - | StandaloneDeriving - - -- | [GHC § 7.3.1] Allow certain Unicode characters to stand for - -- certain ASCII character sequences, e.g. keywords and punctuation. - | UnicodeSyntax - - -- | [GHC § 8.1.1] Allow the use of unboxed types as foreign types, - -- e.g. in @foreign import@ and @foreign export@. - | UnliftedFFITypes - - -- | [GHC § 7.4.3] Defer validity checking of types until after - -- expanding type synonyms, relaxing the constraints on how synonyms - -- may be used. - | LiberalTypeSynonyms - - -- | [GHC § 7.4.2] Allow the name of a type constructor, type class, - -- or type variable to be an infix operator. - | TypeOperators - ---PArr -- not ready yet, and will probably be renamed to ParallelArrays - - -- | [GHC § 7.3.16] Enable syntax for implicitly binding local names - -- corresponding to the field names of a record. A wildcard binds - -- all unmentioned names, unlike 'NamedFieldPuns'. - | RecordWildCards - - -- | Deprecated, use 'NamedFieldPuns' instead. - | RecordPuns - - -- | [GHC § 7.3.14] Allow a record field name to be disambiguated - -- by the type of the record it's in. - | DisambiguateRecordFields - - -- | [GHC § 7.6.4] Enable overloading of string literals using a - -- type class, much like integer literals. - | OverloadedStrings - - -- | [GHC § 7.4.6] Enable generalized algebraic data types, in - -- which type variables may be instantiated on a per-constructor - -- basis. Implies GADTSyntax. - | GADTs - - -- | Enable GADT syntax for declaring ordinary algebraic datatypes. - | GADTSyntax - - -- | [GHC § 7.17.2] Make pattern bindings monomorphic. - | MonoPatBinds - - -- | [GHC § 7.8.8] Relax the requirements on mutually-recursive - -- polymorphic functions. - | RelaxedPolyRec - - -- | [GHC § 2.4.5] Allow default instantiation of polymorphic - -- types in more situations. - | ExtendedDefaultRules - - -- | [GHC § 7.2.2] Enable unboxed tuples. - | UnboxedTuples - - -- | [GHC § 7.5.3] Enable @deriving@ for classes - -- @Data.Typeable.Typeable@ and @Data.Generics.Data@. - | DeriveDataTypeable - - -- | [GHC § 7.6.1.3] Allow a class method's type to place - -- additional constraints on a class type variable. - | ConstrainedClassMethods - - -- | [GHC § 7.3.18] Allow imports to be qualified by the package - -- name the module is intended to be imported from, e.g. - -- - -- > import "network" Network.Socket - | PackageImports - - -- | [GHC § 7.8.6] Deprecated in GHC 6.12 and will be removed in - -- GHC 7. Allow a type variable to be instantiated at a - -- polymorphic type. - | ImpredicativeTypes - - -- | [GHC § 7.3.3] Change the syntax for qualified infix - -- operators. - | NewQualifiedOperators - - -- | [GHC § 7.3.12] Relax the interpretation of left operator - -- sections to allow unary postfix operators. - | PostfixOperators - - -- | [GHC § 7.9.5] Enable quasi-quotation, a mechanism for defining - -- new concrete syntax for expressions and patterns. - | QuasiQuotes - - -- | [GHC § 7.3.10] Enable generalized list comprehensions, - -- supporting operations such as sorting and grouping. - | TransformListComp - - -- | [GHC § 7.3.6] Enable view patterns, which match a value by - -- applying a function and matching on the result. - | ViewPatterns - - -- | Allow concrete XML syntax to be used in expressions and patterns, - -- as per the Haskell Server Pages extension language: - -- . The ideas behind it are - -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\" - -- by Niklas Broberg, from Haskell Workshop '05. - | XmlSyntax - - -- | Allow regular pattern matching over lists, as discussed in the - -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre - -- and Josef Svenningsson, from ICFP '04. - | RegularPatterns - - -- | Enables the use of tuple sections, e.g. @(, True)@ desugars into - -- @\x -> (x, True)@. - | TupleSections - - -- | Allows GHC primops, written in C--, to be imported into a Haskell - -- file. - | GHCForeignImportPrim - - -- | Support for patterns of the form @n + k@, where @k@ is an - -- integer literal. - | NPlusKPatterns - - -- | Improve the layout rule when @if@ expressions are used in a @do@ - -- block. - | DoAndIfThenElse - - -- | Makes much of the Haskell sugar be desugared into calls to the - -- function with a particular name that is in scope. - | RebindableSyntax - - -- | Make @forall@ a keyword in types, which can be used to give the - -- generalisation explicitly. - | ExplicitForAll - - -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in - -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. - | DatatypeContexts - - -- | Local (@let@ and @where@) bindings are monomorphic. - | MonoLocalBinds - - -- | Enable @deriving@ for the @Data.Functor.Functor@ class. - | DeriveFunctor - - -- | Enable @deriving@ for the @Data.Traversable.Traversable@ class. - | DeriveTraversable - - -- | Enable @deriving@ for the @Data.Foldable.Foldable@ class. - | DeriveFoldable - - -- | Enable non-decreasing indentation for 'do' blocks. - | NondecreasingIndentation - - deriving (Show, Read, Eq, Enum, Bounded) - -{-# DEPRECATED knownExtensions - "KnownExtension is an instance of Enum and Bounded, use those instead." #-} -knownExtensions :: [KnownExtension] -knownExtensions = [minBound..maxBound] - --- | Extensions that have been deprecated, possibly paired with another --- extension that replaces it. --- -deprecatedExtensions :: [(Extension, Maybe Extension)] -deprecatedExtensions = - [ (EnableExtension RecordPuns, Just (EnableExtension NamedFieldPuns)) - , (EnableExtension PatternSignatures, Just (EnableExtension ScopedTypeVariables)) - ] --- 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 --- 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. - -instance Text Extension where - disp (UnknownExtension other) = Disp.text other - disp (EnableExtension ke) = Disp.text (show ke) - disp (DisableExtension ke) = Disp.text ("No" ++ show ke) - - parse = do - extension <- Parse.munch1 Char.isAlphaNum - return (classifyExtension extension) - -instance Text KnownExtension where - disp ke = Disp.text (show ke) - - parse = do - extension <- Parse.munch1 Char.isAlphaNum - case classifyKnownExtension extension of - Just ke -> - return ke - Nothing -> - fail ("Can't parse " ++ show extension ++ " as KnownExtension") - -classifyExtension :: String -> Extension -classifyExtension string - = case classifyKnownExtension string of - Just ext -> EnableExtension ext - Nothing -> - case string of - 'N':'o':string' -> - case classifyKnownExtension string' of - Just ext -> DisableExtension ext - Nothing -> UnknownExtension string - _ -> UnknownExtension string - --- | 'read' for 'KnownExtension's is really really slow so for the Text --- instance --- what we do is make a simple table indexed off the first letter in the --- extension name. The extension names actually cover the range @'A'-'Z'@ --- pretty densely and the biggest bucket is 7 so it's not too bad. We just do --- a linear search within each bucket. --- --- This gives an order of magnitude improvement in parsing speed, and it'll --- also allow us to do case insensitive matches in future if we prefer. --- -classifyKnownExtension :: String -> Maybe KnownExtension -classifyKnownExtension "" = Nothing -classifyKnownExtension string@(c : _) - | inRange (bounds knownExtensionTable) c - = lookup string (knownExtensionTable ! c) - | otherwise = Nothing - -knownExtensionTable :: Array Char [(String, KnownExtension)] -knownExtensionTable = - accumArray (flip (:)) [] ('A', 'Z') - [ (head str, (str, extension)) - | extension <- [toEnum 0 ..] - , let str = show extension ] - diff --git a/cabal/cabal/Makefile b/cabal/cabal/Makefile deleted file mode 100644 --- a/cabal/cabal/Makefile +++ /dev/null @@ -1,130 +0,0 @@ - -VERSION=1.11.2 - -#KIND=devel -KIND=rc -#KIND=cabal-latest - -PREFIX=/usr/local -HC=ghc -GHCFLAGS=-Wall - -all: build - -# build the library itself - -SOURCES=Distribution/*.hs Distribution/Simple/*.hs Distribution/PackageDescription/*.hs Distribution/Simple/GHC/*.hs Distribution/Simple/Build/*.hs Distribution/Compat/*.hs Distribution/Simple/Program/*.hs -CONFIG_STAMP=dist/setup-config -BUILD_STAMP=dist/build/libHSCabal-$(VERSION).a -HADDOCK_STAMP=dist/doc/html/Cabal/index.html -USERGUIDE_STAMP=dist/doc/users-guide/index.html -SDIST_STAMP=dist/Cabal-$(VERSION).tar.gz -DISTLOC=dist/release -DIST_STAMP=$(DISTLOC)/Cabal-$(VERSION).tar.gz - -COMMA=, - -setup: $(SOURCES) Setup.hs - -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) - -build: $(BUILD_STAMP) -$(BUILD_STAMP): $(CONFIG_STAMP) $(SOURCES) - ./setup build - -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) -$(HADDOCK_STAMP) : $(CONFIG_STAMP) $(BUILD_STAMP) - ./setup haddock - -PANDOC=pandoc -PANDOC_OPTIONS= \ - --standalone \ - --smart \ - --css=$(PANDOC_HTML_CSS) -PANDOC_HTML_OUTDIR=dist/doc/users-guide -PANDOC_HTML_CSS=Cabal.css - -users-guide: $(USERGUIDE_STAMP) doc/*.markdown -$(USERGUIDE_STAMP): doc/*.markdown - mkdir -p $(PANDOC_HTML_OUTDIR) - for file in $^; do $(PANDOC) $(PANDOC_OPTIONS) --from=markdown --to=html --output $(PANDOC_HTML_OUTDIR)/$$(basename $${file} .markdown).html $${file}; done - cp doc/$(PANDOC_HTML_CSS) $(PANDOC_HTML_OUTDIR) - -docs: haddock users-guide - -clean: - rm -rf dist/ - rm -f setup - -# testing... - -moduleTest: tests/ModuleTest.hs tests/PackageDescriptionTests.hs - mkdir -p dist/test - $(HC) --make -Wall -DDEBUG -odir dist/test -hidir dist/test \ - -itests tests/ModuleTest.hs -o moduleTest - -#tests: moduleTest clean -# cd tests/A && $(MAKE) clean -# cd tests/HUnit-1.0 && $(MAKE) clean -# cd tests/A && $(MAKE) -# cd tests/HUnit-1.0 && $(MAKE) - -#check: -# rm -f moduleTest -# $(MAKE) moduleTest -# ./moduleTest - -# distribution... - -$(SDIST_STAMP) : $(BUILD_STAMP) - ./setup sdist - -dist: $(DIST_STAMP) -$(DIST_STAMP) : $(HADDOCK_STAMP) $(USERGUIDE_STAMP) $(SDIST_STAMP) - rm -rf $(DISTLOC) - mkdir $(DISTLOC) - tar -xzf $(SDIST_STAMP) -C $(DISTLOC)/ - mkdir $(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)/ - tar -C $(DISTLOC) -c Cabal-$(VERSION) -zf $(DISTLOC)/Cabal-$(VERSION).tar.gz - mv $(DISTLOC)/Cabal-$(VERSION)/doc $(DISTLOC)/ - mv $(DISTLOC)/Cabal-$(VERSION)/changelog $(DISTLOC)/ - rm -r $(DISTLOC)/Cabal-$(VERSION)/ - @echo "Cabal tarball built: $(DIST_STAMP)" - @echo "Release fileset prepared: $(DISTLOC)/" - -release: $(DIST_STAMP) - scp -r $(DISTLOC) haskell.org:/srv/web/haskell.org/cabal/release/cabal-$(VERSION) - ssh haskell.org 'cd /srv/web/haskell.org/cabal/release && rm -f $(KIND) && ln -s cabal-$(VERSION) $(KIND)' - -# tags... - -TAGSSRCDIRS = Distribution Language -tags TAGS: $(SOURCES) - find $(TAGSSRCDIRS) -name \*.\*hs | xargs hasktags diff --git a/cabal/cabal/Paths_Cabal.hs b/cabal/cabal/Paths_Cabal.hs deleted file mode 100644 --- a/cabal/cabal/Paths_Cabal.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Paths_Cabal ( - version, - ) where - -import Data.Version (Version(..)) - -version :: Version -version = Version {versionBranch = [1,12,0], versionTags = []} diff --git a/cabal/cabal/README b/cabal/cabal/README deleted file mode 100644 --- a/cabal/cabal/README +++ /dev/null @@ -1,168 +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 -=============================================== - -Installing as a user (no root or administer 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]: http://hackage.haskell.org/trac/hackage/ - - -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 diff --git a/cabal/cabal/Setup.hs b/cabal/cabal/Setup.hs deleted file mode 100644 --- a/cabal/cabal/Setup.hs +++ /dev/null @@ -1,10 +0,0 @@ -import Distribution.Simple -main :: IO () -main = defaultMain - --- Although this looks like the Simple build type, it is in fact vital that --- we use this Setup.hs because it'll get compiled against the local copy --- of the Cabal lib, thus enabling Cabal to bootstrap itself without relying --- on any previous installation. This also means we can use any new features --- immediately because we never have to worry about building Cabal with an --- older version of itself. diff --git a/cabal/cabal/changelog b/cabal/cabal/changelog deleted file mode 100644 --- a/cabal/cabal/changelog +++ /dev/null @@ -1,385 +0,0 @@ --*-change-log-*- - -1.11.x (current development version) - -1.10.0.x (next stable release version) - -1.10.2.0 Duncan Coutts June 2011 - * Include test suites in cabal sdist - * Fix for conditionals in test suite stanzas in .cabal files - * Fix permissions of directories created during install - * Fix for global builds when $HOME env var is not set - -1.10.1.0 Duncan Coutts February 2011 - * Improved error messages when test suites are not enabled - * Template parameters allowed in test --test-option(s) flag - * Improved documentation of the test feature - * Relaxed QA check on cabal-version when using test-suite sections - * haddock command now allows both --hoogle and --html at the same time - * Find ghc-version-specific instances of the hsc2hs program - * Preserve file executable permissions in sdist tarballs - * Pass gcc location and flags to ./configure scripts - * Get default gcc flags from ghc - -1.10.0.0 Duncan Coutts November 2010 - * New cabal test feature - * Initial support for UHC - * New default-language and other-languages fields (e.g. Haskell98/2010) - * New default-extensions and other-extensions fields - * Deprecated extensions field (for packages using cabal-version >=1.10) - * Cabal-version field must now only be of the form ">= x.y" - * Removed deprecated --copy-prefix= feature - * Auto-reconfigure when .cabal file changes - * Workaround for haddock overwriting .hi and .o files when using TH - * Extra cpp flags used with hsc2hs and c2hs (-D${os}_BUILD_OS etc) - * New cpp define VERSION_ gives string version of dependencies - * User guide source now in markdown format for easier editing - * Improved checks and error messages for C libraries and headers - * Removed BSD4 from the list of suggested licenses - * Updated list of known language extensions - * Fix for include paths to allow C code to import FFI stub.h files - * Fix for intra-package dependencies on OSX - * Stricter checks on various bits of .cabal file syntax - * Minor fixes for c2hs - -1.8.0.6 Duncan Coutts June 2010 - * Fix 'register --global/--user' - -1.8.0.4 Duncan Coutts March 2010 - * Set dylib-install-name for dynalic libs on OSX - * Stricter configure check that compiler supports a package's extensions - * More configure-time warnings - * Hugs can compile Cabal lib again - * Default datadir now follows prefix on Windows - * Support for finding installed packages for hugs - * Cabal version macros now have proper parenthesis - * Reverted change to filter out deps of non-buildable components - * Fix for registering implace when using a specific package db - * Fix mismatch between $os and $arch path template variables - * Fix for finding ar.exe on Windows, always pick ghc's version - * Fix for intra-package dependencies with ghc-6.12 - -1.8.0.2 Duncan Coutts December 2009 - * Support for GHC-6.12 - * New unique installed package IDs which use a package hash - * Allow executables to depend on the lib within the same package - * Dependencies for each component apply only to that component - (previously applied to all the other components too) - * Added new known license MIT and versioned GPL and LGPL - * More liberal package version range syntax - * Package registration files are now UTF8 - * Support for LHC and JHC-0.7.2 - * Deprecated RecordPuns extension in favour of NamedFieldPuns - * Deprecated PatternSignatures extension in favor of ScopedTypeVariables - * New VersionRange semantic view as a sequence of intervals - * Improved package quality checks - * Minor simplification in a couple Setup.hs hooks - * Beginnings of a unit level testsuite using QuickCheck - * Various bug fixes - * Various internal cleanups - -1.6.0.2 Duncan Coutts February 2009 - * New configure-time check for C headers and libraries - * Added language extensions present in ghc-6.10 - * Added support for NamedFieldPuns extension in ghc-6.8 - * Fix in configure step for ghc-6.6 on Windows - * Fix warnings in Path_pkgname.hs module on Windows - * Fix for exotic flags in ld-options field - * Fix for using pkg-config in a package with a lib and an executable - * Fix for building haddock docs for exes that use the Paths module - * Fix for installing header files in subdirectories - * Fix for the case of building profiling libs but not ordinary libs - * Fix read-only attribute of installed files on Windows - * Ignore ghc -threaded flag when profiling in ghc-6.8 and older - -1.6.0.1 Duncan Coutts October 2008 - * Export a compat function to help alex and happy - -1.6.0.0 Duncan Coutts October 2008 - * Support for ghc-6.10 - * Source control repositories can now be specified in .cabal files - * Bug report URLs can be now specified in .cabal files - * Wildcards now allowed in data-files and extra-source-files fields - * New syntactic sugar for dependencies "build-depends: foo ==1.2.*" - * New cabal_macros.h provides macros to test versions of dependencies - * Relocatable bindists now possible on unix via env vars - * New 'exposed' field allows packages to be not exposed by default - * Install dir flags can now use $os and $arch variables - * New --builddir flag allows multiple builds from a single sources dir - * cc-options now only apply to .c files, not for -fvia-C - * cc-options are not longer propagated to dependent packages - * The cpp/cc/ld-options fields no longer use ',' as a separator - * hsc2hs is now called using gcc instead of using ghc as gcc - * New api for manipulating sets and graphs of packages - * Internal api improvements and code cleanups - * Minor improvements to the user guide - * Miscellaneous minor bug fixes - -1.4.0.2 Duncan Coutts August 2008 - * Fix executable stripping default - * Fix striping exes on OSX that export dynamic symbols (like ghc) - * Correct the order of arguments given by --prog-options= - * Fix corner case with overlapping user and global packages - * Fix for modules that use pre-processing and .hs-boot files - * Clarify some points in the user guide and readme text - * Fix verbosity flags passed to sub-command like haddock - * Fix sdist --snapshot - * Allow meta-packages that contain no modules or C code - * Make the generated Paths module -Wall clean on Windows - -1.4.0.1 Duncan Coutts June 2008 - * Fix a bug which caused '.' to always be in the sources search path - * Haddock-2.2 and later do now support the --hoogle flag - -1.4.0.0 Duncan Coutts June 2008 - * Rewritten command line handling support - * Command line completion with bash - * Better support for Haddock 2 - * Improved support for nhc98 - * Removed support for ghc-6.2 - * Haddock markup in .lhs files now supported - * Default colour scheme for highlighted source code - * Default prefix for --user installs is now $HOME/.cabal - * All .cabal files are treaded as UTF-8 and must be valid - * Many checks added for common mistakes - * New --package-db= option for specific package databases - * Many internal changes to support cabal-install - * Stricter parsing for version strings, eg dissalows "1.05" - * Improved user guide introduction - * Programatica support removed - * New options --program-prefix/suffix allows eg versioned programs - * Support packages that use .hs-boot files - * Fix sdist for Main modules that require preprocessing - * New configure -O flag with optimisation level 0--2 - * Provide access to "x-" extension fields through the Cabal api - * Added check for broken installed packages - * Added warning about using inconsistent versions of dependencies - * Strip binary executable files by default with an option to disable - * New options to add site-specific include and library search paths - * Lift the restriction that libraries must have exposed-modules - * Many bugs fixed. - * Many internal structural improvements and code cleanups - -1.2.4.0 Duncan Coutts June 2008 - * Released with GHC 6.8.3 - * Backported several fixes and minor improvements from Cabal-1.4 - * Use a default colour scheme for sources with hscolour >=1.9 - * Support --hyperlink-source for Haddock >= 2.0 - * Fix for running in a non-writable directory - * Add OSX -framework arguments when linking executables - * Updates to the user guide - * Allow build-tools names to include + and _ - * Export autoconfUserHooks and simpleUserHooks - * Export ccLdOptionsBuildInfo for Setup.hs scripts - * Export unionBuildInfo and make BuildInfo an instance of Monoid - * Fix to allow the 'main-is' module to use a pre-processor - -1.2.3.0 Duncan Coutts Nov 2007 - * Released with GHC 6.8.2 - * Includes full list of GHC language extensions - * Fix infamous "dist/conftest.c" bug - * Fix configure --interfacedir= - * Find ld.exe on Windows correctly - * Export PreProcessor constructor and mkSimplePreProcessor - * Fix minor bug in unlit code - * Fix some markup in the haddock docs - -1.2.2.0 Duncan Coutts Nov 2007 - * Released with GHC 6.8.1 - * Support haddock-2.0 - * Support building DSOs with GHC - * Require reconfiguring if the .cabal file has changed - * Fix os(windows) configuration test - * Fix building documentation - * Fix building packages on Solaris - * Other minor bug fixes - -1.2.1 Duncan Coutts Oct 2007 - * To be included in GHC 6.8.1 - * New field "cpp-options" used when preprocessing Haskell modules - * Fixes for hsc2hs when using ghc - * C source code gets compiled with -O2 by default - * OS aliases, to allow os(windows) rather than requiring os(mingw32) - * Fix cleaning of 'stub' files - * Fix cabal-setup, command line ui that replaces "runhaskell Setup.hs" - * Build docs even when dependent packages docs are missing - * Allow the --html-dir to be specified at configure time - * Fix building with ghc-6.2 - * Other minor bug fixes and build fixes - -1.2.0 Duncan Coutts Sept 2007 - * To be included in GHC 6.8.x - * New configurations feature - * Can make haddock docs link to hilighted sources (with hscolour) - * New flag to allow linking to haddock docs on the web - * Supports pkg-config - * New field "build-tools" for tool dependencies - * Improved c2hs support - * Preprocessor output no longer clutters source dirs - * Seperate "includes" and "install-includes" fields - * Makefile command to generate makefiles for building libs with GHC - * New --docdir configure flag - * Generic --with-prog --prog-args configure flags - * Better default installation paths on Windows - * Install paths can be specified relative to each other - * License files now installed - * Initial support for NHC (incomplete) - * Consistent treatment of verbosity - * Reduced verbosity of configure step by default - * Improved helpfulness of output messages - * Help output now clearer and fits in 80 columns - * New setup register --gen-pkg-config flag for distros - * Major internal refactoring, hooks api has changed - * Dozens of bug fixes - -1.1.6.2 Duncan Coutts May 2007 - * Released with GHC 6.6.1 - * Handle windows text file encoding for .cabal files - * Fix compiling a executable for profiling that uses Template Haskell - * Other minor bug fixes and user guide clarifications - -1.1.6.1 Duncan Coutts Oct 2006 - * fix unlit code - * fix escaping in register.sh - -1.1.6 Duncan Coutts Oct 2006 - * Released with GHC 6.6 - * Added support for hoogle - * Allow profiling and normal builds of libs to be chosen indepentantly - * Default installation directories on Win32 changed - * Register haddock docs with ghc-pkg - * Get haddock to make hyperlinks to dependent package docs - * Added BangPatterns language extension - * Various bug fixes - -1.1.4 Duncan Coutts May 2006 - * Released with GHC 6.4.2 - * Better support for packages that need to install header files - * cabal-setup added, but not installed by default yet - * Implemented "setup register --inplace" - * Have packages exposed by default with ghc-6.2 - * It is no longer necessary to run 'configure' before 'clean' or 'sdist' - * Added support for ghc's -split-objs - * Initial support for JHC - * Ignore extension fields in .cabal files (fields begining with "x-") - * Some changes to command hooks API to improve consistency - * Hugs support improvements - * Added GeneralisedNewtypeDeriving language extension - * Added cabal-version field - * Support hidden modules with haddock - * Internal code refactoring - * More bug fixes - -1.1.3 Isaac Jones Sept 2005 - * WARNING: Interfaces not documented in the user's guide may - change in future releases. - * Move building of GHCi .o libs to the build phase rather than - register phase. (from Duncan Coutts) - * Use .tar.gz for source package extension - * Uses GHC instead of cpphs if the latter is not available - * Added experimental "command hooks" which completely override the - default behavior of a command. - * Some bugfixes - -1.1.1 Isaac Jones July 2005 - * WARNING: Interfaces not documented in the user's guide may - change in future releases. - * Handles recursive modules for GHC 6.2 and GHC 6.4. - * Added "setup test" command (Used with UserHook) - * implemented handling of _stub.{c,h,o} files - * Added support for profiling - * Changed install prefix of libraries (pref/pkgname-version - to prefix/pkgname-version/compname-version) - * Added pattern guards as a language extension - * Moved some functionality to Language.Haskell.Extension - * Register / unregister .bat files for windows - * Exposed more of the API - * Added support for the hide-all-packages flag in GHC > 6.4 - * Several bug fixes - -1.0 Isaac Jones March 11 2005 - * Released with GHC 6.4, Hugs March 2005, and nhc98 1.18 - * Some sanity checking - -0.5 Isaac Jones Wed Feb 19 2005 - * WARNING: this is a pre-release and the interfaces are still - likely to change until we reach a 1.0 release. - * Hooks interfaces changed - * Added preprocessors to user hooks - * No more executable-modules or hidden-modules. Use - "other-modules" instead. - * Certain fields moved into BuildInfo, much refactoring - * extra-libs -> extra-libraries - * Added --gen-script to configure and unconfigure. - * modules-ghc (etc) now ghc-modules (etc) - * added new fields including "synopsis" - * Lots of bug fixes - * spaces can sometimes be used instead of commas - * A user manual has appeared (Thanks, ross!) - * for ghc 6.4, configures versionsed depends properly - * more features to ./setup haddock - -0.4 Isaac Jones Sun Jan 16 2005 - - * Much thanks to all the awesome fptools hackers who have been - working hard to build the Haskell Cabal! - - * Interface Changes: - - ** WARNING: this is a pre-release and the interfaces are still - likely to change until we reach a 1.0 release. - - ** Instead of Package.description, you should name your - description files .cabal. In particular, we suggest - that you name it .cabal, but this is not enforced - (yet). Multiple .cabal files in the same directory is an error, - at least for now. - - ** ./setup install --install-prefix is gone. Use ./setup copy - --copy-prefix instead. - - ** The "Modules" field is gone. Use "hidden-modules", - "exposed-modules", and "executable-modules". - - ** Build-depends is now a package-only field, and can't go into - executable stanzas. Build-depends is a package-to-package - relationship. - - ** Some new fields. Use the Source. - - * New Features - - ** Cabal is now included as a package in the CVS version of - fptools. That means it'll be released as "-package Cabal" in - future versions of the compilers, and if you are a bleeding-edge - user, you can grab it from the CVS repository with the compilers. - - ** Hugs compatibility and NHC98 compatibility should both be - improved. - - ** Hooks Interface / Autoconf compatibility: Most of the hooks - interface is hidden for now, because it's not finalized. I have - exposed only "defaultMainWithHooks" and "defaultUserHooks". This - allows you to use a ./configure script to preprocess - "foo.buildinfo", which gets merged with "foo.cabal". In future - releases, we'll expose UserHooks, but we're definitely going to - change the interface to those. The interface to the two functions - I've exposed should stay the same, though. - - ** ./setup haddock is a baby feature which pre-processes the - source code with hscpp and runs haddock on it. This is brand new - and hardly tested, so you get to knock it around and see what you - think. - - ** Some commands now actually implement verbosity. - - ** The preprocessors have been tested a bit more, and seem to work - OK. Please give feedback if you use these. - -0.3 Isaac Jones Sun Jan 16 2005 - * Unstable snapshot release - * From now on, stable releases are even. - -0.2 Isaac Jones - - * Adds more HUGS support and preprocessor support. diff --git a/cabal/cabal/doc/Cabal.css b/cabal/cabal/doc/Cabal.css deleted file mode 100644 --- a/cabal/cabal/doc/Cabal.css +++ /dev/null @@ -1,39 +0,0 @@ -div { - font-family: sans-serif; - color: black; - background: white -} - -h1, h2, h3, h4, h5, h6, p.title { color: #005A9C } - -h1 { font: 170% sans-serif } -h2 { font: 140% sans-serif } -h3 { font: 120% sans-serif } -h4 { font: bold 100% sans-serif } -h5 { font: italic 100% sans-serif } -h6 { font: small-caps 100% sans-serif } - -pre { - font-family: monospace; - border-width: 1px; - border-style: solid; - padding: 0.3em -} - -pre.screen { color: #006400 } -pre.programlisting { color: maroon } - -div.example { - margin: 1ex 0em; - border: solid #412e25 1px; - padding: 0ex 0.4em -} - -div.example, div.example-contents { - background-color: #fffcf5 -} - -a:link { color: #0000C8 } -a:hover { background: #FFFFA8 } -a:active { color: #D00000 } -a:visited { color: #680098 } diff --git a/cabal/cabal/doc/developing-packages.markdown b/cabal/cabal/doc/developing-packages.markdown deleted file mode 100644 --- a/cabal/cabal/doc/developing-packages.markdown +++ /dev/null @@ -1,1447 +0,0 @@ -% Cabal User Guide - -# Developing packages # - -The Cabal package is the unit of distribution. When installed, its -purpose is to make available: - - * One or more Haskell programs. - - * At most one library, exposing a number of Haskell modules. - -However having both a library and executables in a package does not work -very well; if the executables depend on the library, they must -explicitly list all the modules they directly or indirectly import from -that library. Fortunately, starting with Cabal 1.8.0.4, executables can -also declare the package that they are in as a dependency, and Cabal -will treat them as if they were in another package that dependended on -the library. - -Internally, the package may consist of much more than a bunch of Haskell -modules: it may also have C source code and header files, source code -meant for preprocessing, documentation, test cases, auxiliary tools etc. - -A package is identified by a globally-unique _package name_, which -consists of one or more alphanumeric words separated by hyphens. To -avoid ambiguity, each of these words should contain at least one letter. -Chaos will result if two distinct packages with the same name are -installed on the same system. A particular version of the package is -distinguished by a _version number_, consisting of a sequence of one or -more integers separated by dots. These can be combined to form a single -text string called the _package ID_, using a hyphen to separate the name -from the version, e.g. "`HUnit-1.1`". - -Note: Packages are not part of the Haskell language; they simply -populate the hierarchical space of module names. In GHC 6.6 and later a -program may contain multiple modules with the same name if they come -from separate packages; in all other current Haskell systems packages -may not overlap in the modules they provide, including hidden modules. - -## Creating a package ## - -Suppose you have a directory hierarchy containing the source files that -make up your package. You will need to add two more files to the root -directory of the package: - -_package_`.cabal` - -: a Unicode UTF-8 text file containing a package description. - For details of the syntax of this file, see the [section on package - descriptions](#package-descriptions). - -`Setup.hs` - -: a single-module Haskell program to perform various setup tasks (with - the interface described in the section on [building and installing - packages](#building-and-installing-a-package)). This module should - import only modules that will be present in all Haskell - implementations, including modules of the Cabal library. In most - cases it will be trivial, calling on the Cabal library to do most of - the work. - -Once you have these, you can create a source bundle of this directory -for distribution. Building of the package is discussed in the section on -[building and installing packages](#building-and-installing-a-package). - -One of the purposes of Cabal is to make it easier to build a package -with different Haskell implementations. So it provides abstractions of -features present in different Haskell implementations and wherever -possible it is best to take advantage of these to increase portability. -Where necessary however it is possible to use specific features of -specific implementations. For example one of the pieces of information a -package author can put in the package's `.cabal` file is what language -extensions the code uses. This is far preferable to specifying flags for -a specific compiler as it allows Cabal to pick the right flags for the -Haskell implementation that the user picks. It also allows Cabal to -figure out if the language extension is even supported by the Haskell -implementation that the user picks. Where compiler-specific options are -needed however, there is an "escape hatch" available. The developer can -specify implementation-specific options and more generally there is a -configuration mechanism to customise many aspects of how a package is -built depending on the Haskell implementation, the Operating system, -computer architecture and user-specified configuration flags. - -~~~~~~~~~~~~~~~~ -name: Foo -version: 1.0 - -library - build-depends: base - exposed-modules: Foo - extensions: ForeignFunctionInterface - ghc-options: -Wall - nhc98-options: -K4m - if os(windows) - build-depends: Win32 -~~~~~~~~~~~~~~~~ - -#### Example: A package containing a simple library #### - -The HUnit package contains a file `HUnit.cabal` containing: - -~~~~~~~~~~~~~~~~ -name: HUnit -version: 1.1.1 -synopsis: A unit testing framework for Haskell -homepage: http://hunit.sourceforge.net/ -category: Testing -author: Dean Herington -license: BSD3 -license-file: LICENSE -cabal-version: >= 1.10 -build-type: Simple - -library - build-depends: base >= 2 && < 4 - exposed-modules: Test.HUnit.Base, Test.HUnit.Lang, - Test.HUnit.Terminal, Test.HUnit.Text, Test.HUnit - default-extensions: CPP -~~~~~~~~~~~~~~~~ - -and the following `Setup.hs`: - -~~~~~~~~~~~~~~~~ -import Distribution.Simple -main = defaultMain -~~~~~~~~~~~~~~~~ - -#### Example: A package containing executable programs #### - -~~~~~~~~~~~~~~~~ -name: TestPackage -version: 0.0 -synopsis: Small package with two programs -author: Angela Author -license: BSD3 -build-type: Simple -cabal-version: >= 1.2 - -executable program1 - build-depends: HUnit - main-is: Main.hs - hs-source-dirs: prog1 - -executable program2 - main-is: Main.hs - build-depends: HUnit - hs-source-dirs: prog2 - other-modules: Utils -~~~~~~~~~~~~~~~~ - -with `Setup.hs` the same as above. - -#### Example: A package containing a library and executable programs #### - -~~~~~~~~~~~~~~~~ -name: TestPackage -version: 0.0 -synopsis: Package with library and two programs -license: BSD3 -author: Angela Author -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: HUnit - exposed-modules: A, B, C - -executable program1 - main-is: Main.hs - hs-source-dirs: prog1 - other-modules: A, B - -executable program2 - main-is: Main.hs - hs-source-dirs: prog2 - other-modules: A, C, Utils -~~~~~~~~~~~~~~~~ - -with `Setup.hs` the same as above. Note that any library modules -required (directly or indirectly) by an executable must be listed again. - -The trivial setup script used in these examples uses the _simple build -infrastructure_ provided by the Cabal library (see -[Distribution.Simple][dist-simple]). The simplicity lies in its -interface rather that its implementation. It automatically handles -preprocessing with standard preprocessors, and builds packages for all -the Haskell implementations (except nhc98, for now). - -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). - -## Package descriptions ## - -The package description file must have a name ending in "`.cabal`". It -must be a Unicode text file encoded using valid UTF-8. There must be -exactly one such file in the directory. The first part of the name is -usually the package name, and some of the tools that operate on Cabal -packages require this. - -In the package description file, lines whose first non-whitespace characters -are "`--`" are treated as comments and ignored. - -This file should contain of a number global property descriptions and -several sections. - -* The [global properties](#package-properties) describe the package as a - whole, such as name, license, author, etc. - -* Optionally, a number of _configuration flags_ can be declared. These - can be used to enable or disable certain features of a package. (see - the section on [configurations](#configurations)). - -* The (optional) library section specifies the [library - properties](#library) and relevant [build - information](#build-information). - -* Following is an arbitrary number of executable sections - which describe an [executable program](#executable) and relevant - [build information](#build-information). - -Each section consists of a number of property descriptions -in the form of field/value pairs, with a syntax roughly like mail -message headers. - -* Case is not significant in field names, but is significant in field - values. - -* To continue a field value, indent the next line relative to the field - name. - -* Field names may be indented, but all field values in the same section - must use the same indentation. - -* Tabs are *not* allowed as indentation characters due to a missing - standard interpretation of tab width. - -* To get a blank line in a field value, use an indented "`.`" - -The syntax of the value depends on the field. Field types include: - -_token_, _filename_, _directory_ -: Either a sequence of one or more non-space non-comma characters, or - a quoted string in Haskell 98 lexical syntax. Unless otherwise - stated, relative filenames and directories are interpreted from the - package root directory. - -_freeform_, _URL_, _address_ -: An arbitrary, uninterpreted string. - -_identifier_ -: A letter followed by zero or more alphanumerics or underscores. - -_compiler_ -: A compiler flavor (one of: `GHC`, `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`. - -### Modules and preprocessors ### - -Haskell module names listed in the `exposed-modules` and `other-modules` -fields may correspond to Haskell source files, i.e. with names ending in -"`.hs`" or "`.lhs`", or to inputs for various Haskell preprocessors. The -simple build infrastructure understands the extensions: - -* `.gc` ([greencard][]) -* `.chs` ([c2hs][]) -* `.hsc` (`hsc2hs`) -* `.y` and `.ly` ([happy][]) -* `.x` ([alex][]) -* `.cpphs` ([cpphs][]) - -When building, Cabal will automatically run the appropriate preprocessor -and compile the Haskell module it produces. - -Some fields take lists of values, which are optionally separated by commas, except for the -`build-depends` field, where the commas are mandatory. - -Some fields are marked as required. All others are optional, and unless -otherwise specified have empty default values. - -### Package properties ### - -These fields may occur in the first top-level properties section and -describe the package as a whole: - -`name:` _package-name_ (required) -: The unique name of the [package](#packages), without the version - number. - -`version:` _numbers_ (required) -: The package version number, usually consisting of a sequence of - natural numbers separated by dots. - -`cabal-version:` _>= x.y_ -: The version of the Cabal specification that this package description uses. - The Cabal specification does slowly evolve, intoducing new features and - occasionally changing the meaning of existing features. By specifying - which version of the spec you are using it enables programs which process - the package description to know what syntax to expect and what each part - means. - - For historical reasons this is always expressed using _>=_ version range - syntax. No other kinds of version range make sense, in particular upper - bounds do not make sense. In future this field will specify just a version - number, rather than a version range. - - The version number you specify will affect both compatability and - behaviour. Most tools (including the Cabal libray and cabal program) - understand a range of versions of the Cabal specification. Older tools - will of course only work with older versions of the Cabal specification. - Most of the time, tools that are too old will recognise this fact and - produce a suitable error message. - - As for behaviour, new versions of the Cabal spec can change the meaning - of existing syntax. This means if you want to take advantage of the new - meaning or behaviour then you must specify the newer Cabal version. - Tools are expected to use the meaning and behaviour appropriate to the - version given in the package description. - - In particular, the syntax of package descriptions changed significantly - with Cabal version 1.2 and the `cabal-version` field is now required. - Files written in the old syntax are still recognized, so if you require - compatability with very old Cabal versions then you may write your package - description file using the old syntax. Please consult the user's guide of - an older Cabal version for a description of that syntax. - -`build-type:` _identifier_ -: The type of build used by this package. Build types are the - constructors of the [BuildType][] type, defaulting to `Custom`. If - this field is given a value other than `Custom`, some tools such as - `cabal-install` will be able to build the package without using the - setup script. So if you are just using the default `Setup.hs` then - set the build type as `Simple`. - -`license:` _identifier_ (default: `AllRightsReserved`) -: The type of license under which this package is distributed. - License names are the constants of the [License][dist-license] type. - -`license-file:` _filename_ -: The name of a file containing the precise license for this package. - It will be installed with the package. - -`copyright:` _freeform_ -: The content of a copyright notice, typically the name of the holder - of the copyright on the package and the year(s) from which copyright - is claimed. For example: `Copyright: (c) 2006-2007 Joe Bloggs` - -`author:` _freeform_ -: The original author of the package. - - Remember that `.cabal` files are Unicode, using the UTF-8 encoding. - -`maintainer:` _address_ -: The current maintainer or maintainers of the package. This is an e-mail address to which users should send bug - reports, feature requests and patches. - -`stability:` _freeform_ -: The stability level of the package, e.g. `alpha`, `experimental`, `provisional`, - `stable`. - -`homepage:` _URL_ -: The package homepage. - -`bug-reports:` _URL_ -: The URL where users should direct bug reports. This would normally be either: - - * A `mailto:` URL, eg for a person or a mailing list. - - * An `http:` (or `https:`) URL for an online bug tracking system. - - For example Cabal itself uses a web-based bug tracking system - - ~~~~~~~~~~~~~~~~ - bug-reports: http://hackage.haskell.org/trac/hackage/ - ~~~~~~~~~~~~~~~~ - -`package-url:` _URL_ -: The location of a source bundle for the package. The distribution - should be a Cabal package. - -`synopsis:` _freeform_ -: A very short description of the package, for use in a table of - packages. This is your headline, so keep it short (one line) but as - informative as possible. Save space by not including the package - name or saying it's written in Haskell. - -`description:` _freeform_ -: Description of the package. This may be several paragraphs, and - should be aimed at a Haskell programmer who has never heard of your - package before. - - For library packages, this field is used as prologue text by [`setup - haddock`](#setup-haddock), and thus may contain the same markup as - [haddock][] documentation comments. - -`category:` _freeform_ -: A classification category for future use by the package catalogue [Hackage]. These - categories have not yet been specified, but the upper levels of the - module hierarchy make a good start. - -`tested-with:` _compiler list_ -: A list of compilers and versions against which the package has been - tested (or at least built). - -`data-files:` _filename list_ -: A list of files to be installed for run-time use by the package. - This is useful for packages that use a large amount of static data, - such as tables of values or code templates. Cabal provides a way to - [find these files at - run-time](#accessing-data-files-from-package-code). - - A limited form of `*` wildcards in file names, for example - `data-files: images/*.png` matches all the `.png` files in the - `images` directory. - - The limitation is that `*` wildcards are only allowed in place of - the file name, not in the directory name or file extension. In - particular, wildcards do not include directories contents - recursively. Furthermore, if a wildcard is used it must be used with - an extension, so `data-files: data/*` is not allowed. When matching - a wildcard plus extension, a file's full extension must match - exactly, so `*.gz` matches `foo.gz` but not `foo.tar.gz`. A wildcard - that does not match any files is an error. - - The reason for providing only a very limited form of wildcard is to - concisely express the common case of a large number of related files - of the same file type without making it too easy to accidentally - include unwanted files. - -`data-dir:` _directory_ -: The directory where Cabal looks for data files to install, relative - to the source directory. By default, Cabal will look in the source - directory itself. - -`extra-source-files:` _filename list_ -: A list of additional files to be included in source distributions - built with [`setup sdist`](#setup-sdist). As with `data-files` it - can use a limited form of `*` wildcards in file names. - -`extra-tmp-files:` _filename list_ -: A list of additional files or directories to be removed by [`setup - clean`](#setup-clean). These would typically be additional files - created by additional hooks, such as the scheme described in the - section on [system-dependent parameters](#system-dependent-parameters). - -### Library ### - -The library section should contain the following fields: - -`exposed-modules:` _identifier list_ (required if this package contains a library) -: A list of modules added by this package. - -`exposed:` _boolean_ (default: `True`) -: Some Haskell compilers (notably GHC) support the notion of packages - being "exposed" or "hidden" which means the modules they provide can - be easily imported without always having to specify which package - they come from. However this only works effectively if the modules - provided by all exposed packages do not overlap (otherwise a module - import would be ambiguous). - - Almost all new libraries use hierarchical module names that do not - clash, so it is very uncommon to have to use this field. However it - may be necessary to set `exposed: False` for some old libraries that - use a flat module namespace or where it is known that the exposed - modules would clash with other common modules. - -The library section may also contain build information fields (see the -section on [build information](#build-information)). - - -### Executables ### - -Executable sections (if present) describe executable programs contained -in the package and must have an argument after the section label, which -defines the name of the executable. This is a freeform argument but may -not contain spaces. - -The executable may be described using the following fields, as well as -build information fields (see the section on [build -information](#build-information)). - -`main-is:` _filename_ (required) -: The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the - `.hs` filename that must be listed, even if that file is generated - using a preprocessor. The source file must be relative to one of the - directories listed in `hs-source-dirs`. - -### Test suites ### - -Test suite sections (if present) describe package test suites and must have an -argument after the section label, which defines the name of the test suite. -This is a freeform argument, but may not contain spaces. It should be unique -among the names of the package's other test suites, the package's executables, -and the package itself. Using test suite sections requires at least Cabal -version 1.9.2. - -The test suite may be described using the following fields, as well as build -information fields (see the section on [build -information](#build-information)). - -`type:` _interface_ (required) -: The interface type and version of the test suite. Cabal supports two test - suite interfaces, called `exitcode-stdio-1.0` and `detailed-1.0`. 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` -interface. The `exitcode-stdio-1.0` type requires the `main-is` field. - -`main-is:` _filename_ (required: `exitcode-stdio-1.0`, disallowed: `detailed-1.0`) -: The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the - `.hs` filename that must be listed, even if that file is generated - using a preprocessor. The source file must be relative to one of the - directories listed in `hs-source-dirs`. This field is analogous to the - `main-is` field of an executable section. - -Test suites using the `detailed-1.0` interface are modules exporting the symbol -`tests :: [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 -test suite's results case by case, producing detailed human- and -machine-readable log files. The `detailed-1.0` interface requires the -`test-module` field. - -`test-module:` _identifier_ (required: `detailed-1.0`, 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. - -foo.cabal: - -~~~~~~~~~~~~~~~~ -Name: foo -Version: 1.0 -License: BSD3 -Cabal-Version: >= 1.9.2 -Build-Type: Simple - -Test-Suite test-foo - type: exitcode-stdio-1.0 - main-is: test-foo.hs - build-depends: base -~~~~~~~~~~~~~~~~ - -test-foo.hs: - -~~~~~~~~~~~~~~~~ -module Main where - -import System.Exit (exitFailure) - -main = do - putStrLn "This test always fails!" - exitFailure -~~~~~~~~~~~~~~~~ - -#### Example: Package using `detailed-1.0` 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. - -bar.cabal: - -~~~~~~~~~~~~~~~~ -Name: bar -Version: 1.0 -License: BSD3 -Cabal-Version: >= 1.9.2 -Build-Type: Simple - -Test-Suite test-bar - type: detailed-1.0 - test-module: Test.Bar - build-depends: base, Cabal >= 1.9.2 -~~~~~~~~~~~~~~~~ - -Test/Bar.hs: - -~~~~~~~~~~~~~~~~ -{-# LANGUAGE FlexibleInstances #-} -module Test.Bar ( tests ) where - -import Distribution.TestSuite - -instance TestOptions (String, Bool) where - name = fst - options = const [] - defaultOptions _ = return (Options []) - check _ _ = [] - -instance PureTestable (String, Bool) where - run (name, result) _ | result == True = Pass - | result == False = Fail (name ++ " failed!") - -test :: (String, Bool) -> Test -test = pure - --- In actual usage, the instances 'TestOptions (String, Bool)' and --- 'PureTestable (String, Bool)', as well as the function 'test', would be --- provided by the test framework. - -tests :: [Test] -tests = - [ test ("bar-1", True) - , test ("bar-2", False) - ] -~~~~~~~~~~~~~~~~ - -### Build information ### - -The following fields may be optionally present in a library or -executable section, and give information for the building of the -corresponding library or executable. See also the sections on -[system-dependent parameters](#system-dependent-parameters) and -[configurations](#configurations) for a way to supply system-dependent -values for these fields. - -`build-depends:` _package list_ -: A list of packages needed to build this one. Each package can be - annotated with a version constraint. - - Version constraints use the operators `==, >=, >, <, <=` and a - version number. Multiple constraints can be combined using `&&` or - `||`. If no version constraint is specified, any version is assumed - to be acceptable. For example: - - ~~~~~~~~~~~~~~~~ - library - build-depends: - base >= 2, - foo >= 1.2 && < 1.3, - bar - ~~~~~~~~~~~~~~~~ - - Dependencies like `foo >= 1.2 && < 1.3` turn out to be very common - because it is recommended practise for package versions to - correspond to API versions. As of Cabal 1.6, there is a special - syntax to support this use: - - ~~~~~~~~~~~~~~~~ - build-depends: foo ==1.2.* - ~~~~~~~~~~~~~~~~ - - It is only syntactic sugar. It is exactly equivalent to `foo >= 1.2 && < 1.3`. - - Note: Prior to Cabal 1.8, build-depends specified in each section - were global to all sections. This was unintentional, but some packages - were written to depend on it, so if you need your build-depends to - be local to each section, you must specify at least - `Cabal-Version: >= 1.8` in your `.cabal` file. - -`other-modules:` _identifier list_ -: A list of modules used by the component but not exposed to users. - For a library component, these would be hidden modules of the - library. For an executable, these would be auxiliary modules to be - linked with the file named in the `main-is` field. - - Note: Every module in the package *must* be listed in one of - `other-modules`, `exposed-modules` or `main-is` fields. - -`hs-source-dirs:` _directory list_ (default: "`.`") -: Root directories for the module hierarchy. - - For backwards compatibility, the old variant `hs-source-dir` is also - recognized. - -`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. - - Extensions used only by one module may be specified by placing a - `LANGUAGE` pragma in the source file affected, e.g.: - - ~~~~~~~~~~~~~~~~ - {-# LANGUAGE CPP, MultiParamTypeClasses #-} - ~~~~~~~~~~~~~~~~ - - Note: GHC versions prior to 6.6 do not support the `LANGUAGE` pragma. - -`build-tools:` _program list_ -: A list of programs, possibly annotated with versions, needed to - build this package, e.g. `c2hs >= 0.15, cpphs`.If no version - constraint is specified, any version is assumed to be acceptable. - -`buildable:` _boolean_ (default: `True`) -: Is the component buildable? Like some of the other fields below, - this field is more useful with the slightly more elaborate form of - the simple build infrastructure described in the section on - [system-dependent parameters](#system-dependent-parameters). - -`ghc-options:` _token list_ -: Additional options for GHC. You can often achieve the same effect - using the `extensions` field, which is preferred. - - Options required only by one module may be specified by placing an - `OPTIONS_GHC` pragma in the source file affected. - -`ghc-prof-options:` _token list_ -: 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. - -`hugs-options:` _token list_ -: Additional options for Hugs. 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_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. - -`includes:` _filename list_ -: A list of header files to be included in any compilations via C. - This field applies to both header files that are already installed - on the system and to those coming with the package to be installed. - These files typically contain function prototypes for foreign - imports used by the package. - -`install-includes:` _filename list_ -: A list of header files from this package to be installed into - `$libdir/includes` when the package is installed. Files listed in - `install-includes:` should be found in relative to the top of the - source tree or relative to one of the directories listed in - `include-dirs`. - - `install-includes` is typically used to name header files that - contain prototypes for foreign imports used in Haskell code in this - package, for which the C implementations are also provided with the - package. Note that to include them when compiling the package - itself, they need to be listed in the `includes:` field as well. - -`include-dirs:` _directory list_ -: A list of directories to search for header files, when preprocessing - with `c2hs`, `hsc2hs`, `ffihugs`, `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. - -`extra-libraries:` _token list_ -: A list of extra libraries to link with. - -`extra-lib-dirs:` _directory list_ -: A list of directories to search for libraries. - -`cc-options:` _token list_ -: Command-line arguments to be passed to the C compiler. Since the - arguments are compiler-dependent, this field is more useful with the - setup described in the section on [system-dependent - parameters](#system-dependent-parameters). - -`ld-options:` _token list_ -: Command-line arguments to be passed to the linker. Since the - arguments are compiler-dependent, this field is more useful with the - setup described in the section on [system-dependent - parameters](#system-dependent-parameters)>. - -`pkgconfig-depends:` _package list_ -: A list of [pkg-config][] packages, needed to build this package. - They can be annotated with versions, e.g. `gtk+-2.0 >= 2.10, cairo - >= 1.0`. If no version constraint is specified, any version is - assumed to be acceptable. Cabal uses `pkg-config` to find if the - packages are available on the system and to find the extra - compilation and linker options needed to use the packages. - - If you need to bind to a C library that supports `pkg-config` (use - `pkg-config --list-all` to find out if it is supported) then it is - much preferable to use this field rather than hard code options into - the other fields. - -`frameworks:` _token list_ -: On Darwin/MacOS X, a list of frameworks to link to. See Apple's - developer documentation for more details on frameworks. This entry - is ignored on all other platforms. - -### Configurations ### - -Library and executable sections may include conditional -blocks, which test for various system parameters and -configuration flags. The flags mechanism is rather generic, -but most of the time a flag represents certain feature, that -can be switched on or off by the package user. -Here is an example package description file using -configurations: - -#### Example: A package containing a library and executable programs #### - -~~~~~~~~~~~~~~~~ -Name: Test1 -Version: 0.0.1 -Cabal-Version: >= 1.2 -License: BSD3 -Author: Jane Doe -Synopsis: Test package to test configurations -Category: Example - -Flag Debug - Description: Enable debug support - Default: False - -Flag WebFrontend - Description: Include API for web frontend. - -- Cabal checks if the configuration is possible, first - -- with this flag set to True and if not it tries with False - -Library - Build-Depends: base - Exposed-Modules: Testing.Test1 - Extensions: CPP - - if flag(debug) - GHC-Options: -DDEBUG - if !os(windows) - CC-Options: "-DDEBUG" - else - CC-Options: "-DNDEBUG" - - if flag(webfrontend) - Build-Depends: cgi > 0.42 - Other-Modules: Testing.WebStuff - -Executable test1 - Main-is: T1.hs - Other-Modules: Testing.Test1 - Build-Depends: base - - if flag(debug) - CC-Options: "-DDEBUG" - GHC-Options: -DDEBUG -~~~~~~~~~~~~~~~~ - -#### Layout #### - -Flags, conditionals, library and executable sections use layout to -indicate structure. This is very similar to the Haskell layout rule. -Entries in a section have to all be indented to the same level which -must be more than the section header. Tabs are not allowed to be used -for indentation. - -As an alternative to using layout you can also use explicit braces `{}`. -In this case the indentation of entries in a section does not matter, -though different fields within a block must be on different lines. Here -is a bit of the above example again, using braces: - -#### Example: Using explicit braces rather than indentation for layout #### - -~~~~~~~~~~~~~~~~ -Name: Test1 -Version: 0.0.1 -Cabal-Version: >= 1.2 -License: BSD3 -Author: Jane Doe -Synopsis: Test package to test configurations -Category: Example - -Flag Debug { - Description: Enable debug support - Default: False -} - -Library { - Build-Depends: base - Exposed-Modules: Testing.Test1 - Extensions: CPP - if flag(debug) { - GHC-Options: -DDEBUG - if !os(windows) { - CC-Options: "-DDEBUG" - } else { - CC-Options: "-DNDEBUG" - } - } -} -~~~~~~~~~~~~~~~~ - -#### Configuration Flags #### - -A flag section takes the flag name as an argument and may contain the -following fields. - -`description:` _freeform_ -: The description of this flag. - -`default:` _boolean_ (default: `True`) -: The default value of this flag. - - Note that this value may be [overridden in several - ways](#controlling-flag-assignments"). The rationale for having - flags default to True is that users usually want new features as - soon as they are available. Flags representing features that are not - (yet) recommended for most users (such as experimental features or - debugging support) should therefore explicitly override the default - to False. - -`manual:` _boolean_ (default: `False`) -: By default, Cabal will first try to satisfy dependencies with the - default flag value and then, if that is not possible, with the - negated value. However, if the flag is manual, then the default - value (which can be overridden by commandline flags) will be used. - -#### Conditional Blocks #### - -Conditional blocks may appear anywhere inside a library or executable -section. They have to follow rather strict formatting rules. -Conditional blocks must always be of the shape - -~~~~~~~~~~~~~~~~ - `if `_condition_ - _property-descriptions-or-conditionals*_ -~~~~~~~~~~~~~~~~ - -or - -~~~~~~~~~~~~~~~~ - `if `_condition_ - _property-descriptions-or-conditionals*_ - `else` - _property-descriptions-or-conditionals*_ -~~~~~~~~~~~~~~~~ - -Note that the `if` and the condition have to be all on the same line. - -#### Conditions #### - -Conditions can be formed using boolean tests and the boolean operators -`||` (disjunction / logical "or"), `&&` (conjunction / logical "and"), -or `!` (negation / logical "not"). The unary `!` takes highest -precedence, `||` takes lowest. Precedence levels may be overridden -through the use of parentheses. For example, `os(darwin) && !arch(i386) -|| os(freebsd)` is equivalent to `(os(darwin) && !(arch(i386))) || -os(freebsd)`. - -The following tests are currently supported. - -`os(`_name_`)` -: Tests if the current operating system is _name_. The argument is - tested against `System.Info.os` on the target system. There is - unfortunately some disagreement between Haskell implementations - about the standard values of `System.Info.os`. Cabal canonicalises - it so that in particular `os(windows)` works on all implementations. - If the canonicalised os names match, this test evaluates to true, - otherwise false. The match is case-insensitive. - -`arch(`_name_`)` -: Tests if the current architecture is _name_. The argument is - matched against `System.Info.arch` on the target system. If the arch - names match, this test evaluates to true, otherwise false. The match - is case-insensitive. - -`impl(`_compiler_`)` -: Tests for the configured Haskell implementation. An optional version - constraint may be specified (for example `impl(ghc >= 6.6.1)`). If - the configured implementation is of the right type and matches the - version constraint, then this evaluates to true, otherwise false. - The match is case-insensitive. - -`flag(`_name_`)` -: Evaluates to the current assignment of the flag of the given name. - Flag names are case insensitive. Testing for flags that have not - been introduced with a flag section is an error. - -`true` -: Constant value true. - -`false` -: Constant value false. - -#### Resolution of Conditions and Flags #### - -If a package descriptions specifies configuration flags the package user -can [control these in several ways](#controlling-flag-assignments). If -the user does not fix the value of a flag, Cabal will try to find a flag -assignment in the following way. - - * For each flag specified, it will assign its default value, evaluate - all conditions with this flag assignment, and check if all - dependencies can be satisfied. If this check succeeded, the package - will be configured with those flag assignments. - - * If dependencies were missing, the last flag (as by the order in - which the flags were introduced in the package description) is tried - with its alternative value and so on. This continues until either - an assignment is found where all dependencies can be satisfied, or - all possible flag assignments have been tried. - -To put it another way, Cabal does a complete backtracking search to find -a satisfiable package configuration. It is only the dependencies -specified in the `build-depends` field in conditional blocks that -determine if a particular flag assignment is satisfiable (`build-tools` -are not considered). The order of the declaration and the default value -of the flags determines the search order. Flags overridden on the -command line fix the assignment of that flag, so no backtracking will be -tried for that flag. - -If no suitable flag assignment could be found, the configuration phase -will fail and a list of missing dependencies will be printed. Note that -this resolution process is exponential in the worst case (i.e., in the -case where dependencies cannot be satisfied). There are some -optimizations applied internally, but the overall complexity remains -unchanged. - -### Meaning of field values when using conditionals ### - -During the configuration phase, a flag assignment is chosen, all -conditionals are evaluated, and the package description is combined into -a flat package descriptions. If the same field both inside a conditional -and outside then they are combined using the following rules. - - - * Boolean fields are combined using conjunction (logical "and"). - - * List fields are combined by appending the inner items to the outer - items, for example - - ~~~~~~~~~~~~~~~~ - Extensions: CPP - if impl(ghc) || impl(hugs) - Extensions: MultiParamTypeClasses - ~~~~~~~~~~~~~~~~ - - when compiled using Hugs or GHC will be combined to - - ~~~~~~~~~~~~~~~~ - Extensions: CPP, MultiParamTypeClasses - ~~~~~~~~~~~~~~~~ - - Similarly, if two conditional sections appear at the same nesting - level, properties specified in the latter will come after properties - specified in the former. - - * All other fields must not be specified in ambiguous ways. For - example - - ~~~~~~~~~~~~~~~~ - Main-is: Main.hs - if flag(useothermain) - Main-is: OtherMain.hs - ~~~~~~~~~~~~~~~~ - - will lead to an error. Instead use - - ~~~~~~~~~~~~~~~~ - if flag(useothermain) - Main-is: OtherMain.hs - else - Main-is: Main.hs - ~~~~~~~~~~~~~~~~ - -### Source Repositories ### - -It is often useful to be able to specify a source revision control -repository for a package. Cabal lets you specifying this information in -a relatively structured form which enables other tools to interpret and -make effective use of the information. For example the information -should be sufficient for an automatic tool to checkout the sources. - -Cabal supports specifying different information for various common -source control systems. Obviously not all automated tools will support -all source control systems. - -Cabal supports specifying repositories for different use cases. By -declaring which case we mean automated tools can be more useful. There -are currently two kinds defined: - - * The `head` kind refers to the latest development branch of the - package. This may be used for example to track activity of a project - or as an indication to outside developers what sources to get for - making new contributions. - - * The `this` kind refers to the branch and tag of a repository that - contains the sources for this version or release of a package. For most - source control systems this involves specifying a tag, id or hash of - some form and perhaps a branch. The purpose is to be able to - reconstruct the sources corresponding to a particular package - version. This might be used to indicate what sources to get if - someone needs to fix a bug in an older branch that is no longer an - active head branch. - -You can specify one kind or the other or both. As an example here are -the repositories for the Cabal library. Note that the `this` kind of -repo specifies a tag. - -~~~~~~~~~~~~~~~~ -source-repository head - type: darcs - location: http://darcs.haskell.org/cabal/ - -source-repository this - type: darcs - location: http://darcs.haskell.org/cabal-branches/cabal-1.6/ - tag: 1.6.1 -~~~~~~~~~~~~~~~~ - -The exact fields are as follows: - -`type:` _token_ -: The name of the source control system used for this repository. The - currently recognised types are: - - * `darcs` - * `git` - * `svn` - * `cvs` - * `mercurial` (or alias `hg`) - * `bazaar` (or alias `bzr`) - * `arch` - * `monotone` - - This field is required. - -`location:` _URL_ -: The location of the repository. The exact form of this field depends - on the repository type. For example: - - * for darcs: `http://code.haskell.org/foo/` - * for git: `git://github.com/foo/bar.git` - * for CVS: `anoncvs@cvs.foo.org:/cvs` - - This field is required. - -`module:` _token_ -: CVS requires a named module, as each CVS server can host multiple - named repositories. - - This field is required for the CVS repo type and should not be used - otherwise. - -`branch:` _token_ -: Many source control systems support the notion of a branch, as a - distinct concept from having repositories in separate locations. For - example CVS, SVN and git use branches while for darcs uses different - locations for different branches. If you need to specify a branch to - identify a your repository then specify it in this field. - - This field is optional. - -`tag:` _token_ -: A tag identifies a particular state of a source repository. The tag - can be used with a `this` 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. - - This field is required for the `this` repo 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. - - This field is optional. It default to empty which corresponds to the - root directory of the repository. - -## Accessing data files from package code ## - -The placement on the target system of files listed in the `data-files` -field varies between systems, and in some cases one can even move -packages around after installation (see [prefix -independence](#prefix-independence)). To enable packages to find these -files in a portable way, Cabal generates a module called -`Paths_`_pkgname_ (with any hyphens in _pkgname_ replaced by -underscores) during building, so that it may be imported by modules of -the package. This module defines a function - -~~~~~~~~~~~~~~~ -getDataFileName :: FilePath -> IO FilePath -~~~~~~~~~~~~~~~ - -If the argument is a filename listed in the `data-files` field, the -result is the name of the corresponding file on the system on which the -program is running. - -Note: If you decide to import the `Paths_`_pkgname_ module then it -*must* be listed in the `other-modules` field just like any other module -in your package. - -The `Paths_`_pkgname_ module is not platform independent so it does not -get included in the source tarballs generated by `sdist`. - -### Accessing the package version ### - -The aforementioned auto generated `Paths_`_pkgname_ module also -exports the constant `version ::` [Version][data-version] which is -defined as the version of your package as specified in the `version` -field. - -## System-dependent parameters ## - -For some packages, especially those interfacing with C libraries, -implementation details and the build procedure depend on the build -environment. A variant of the simple build infrastructure (the -`build-type` `Configure`) handles many such situations using a slightly -longer `Setup.hs`: - -~~~~~~~~~~~~~~~~ -import Distribution.Simple -main = defaultMainWithHooks autoconfUserHooks -~~~~~~~~~~~~~~~~ - -Most packages, however, would probably do better with -[configurations](#configurations). - -This program differs from `defaultMain` in two ways: - -* The package root directory must contain a shell script called - `configure`. The configure step will run the script. This `configure` - script may be produced by [autoconf][] or may be hand-written. The - `configure` script typically discovers information about the system - and records it for later steps, e.g. by generating system-dependent - header files for inclusion in C source files and preprocessed Haskell - source files. (Clearly this won't work for Windows without MSYS or - Cygwin: other ideas are needed.) - -* If the package root directory contains a file called - _package_`.buildinfo` after the configuration step, subsequent steps - will read it to obtain additional settings for [build - information](#build-information) fields,to be merged with the ones - given in the `.cabal` file. In particular, this file may be generated - by the `configure` script mentioned above, allowing these settings to - vary depending on the build environment. - - The build information file should have the following structure: - - > _buildinfo_ - > - > `executable:` _name_ - > _buildinfo_ - > - > `executable:` _name_ - > _buildinfo_ - > ... - - where each _buildinfo_ consists of settings of fields listed in the - section on [build information](#build-information). The first one (if - present) relates to the library, while each of the others relate to - the named executable. (The names must match the package description, - but you don't have to have entries for all of them.) - -Neither of these files is required. If they are absent, this setup -script is equivalent to `defaultMain`. - -#### Example: Using autoconf #### - -This example is for people familiar with the [autoconf][] tools. - -In the X11 package, the file `configure.ac` contains: - -~~~~~~~~~~~~~~~~ -AC_INIT([Haskell X11 package], [1.1], [libraries@haskell.org], [X11]) - -# Safety check: Ensure that we are in the correct source directory. -AC_CONFIG_SRCDIR([X11.cabal]) - -# Header file to place defines in -AC_CONFIG_HEADERS([include/HsX11Config.h]) - -# Check for X11 include paths and libraries -AC_PATH_XTRA -AC_TRY_CPP([#include ],,[no_x=yes]) - -# Build the package if we found X11 stuff -if test "$no_x" = yes -then BUILD_PACKAGE_BOOL=False -else BUILD_PACKAGE_BOOL=True -fi -AC_SUBST([BUILD_PACKAGE_BOOL]) - -AC_CONFIG_FILES([X11.buildinfo]) -AC_OUTPUT -~~~~~~~~~~~~~~~~ - -Then the setup script will run the `configure` script, which checks for -the presence of the X11 libraries and substitutes for variables in the -file `X11.buildinfo.in`: - -~~~~~~~~~~~~~~~~ -buildable: @BUILD_PACKAGE_BOOL@ -cc-options: @X_CFLAGS@ -ld-options: @X_LIBS@ -~~~~~~~~~~~~~~~~ - -This generates a file `X11.buildinfo` supplying the parameters needed by -later stages: - -~~~~~~~~~~~~~~~~ -buildable: True -cc-options: -I/usr/X11R6/include -ld-options: -L/usr/X11R6/lib -~~~~~~~~~~~~~~~~ - -The `configure` script also generates a header file -`include/HsX11Config.h` containing C preprocessor defines recording the -results of various tests. This file may be included by C source files -and preprocessed Haskell source files in the package. - -Note: Packages using these features will also need to list -additional files such as `configure`, -templates for `.buildinfo` files, files named -only in `.buildinfo` files, header files and -so on in the `extra-source-files` field, -to ensure that they are included in source distributions. -They should also list files and directories generated by -`configure` in the -`extra-tmp-files` field to ensure that they -are removed by `setup clean`. - -## Conditional compilation ## - -Sometimes you want to write code that works with more than one version -of a dependency. You can specify a range of versions for the depenency -in the `build-depends`, but how do you then write the code that can use -different versions of the API? - -Haskell lets you preprocess your code using the C preprocessor (either -the real C preprocessor, or `cpphs`). To enable this, add `extensions: -CPP` to your package description. When using CPP, Cabal provides some -pre-defined macros to let you test the version of dependent packages; -for example, suppose your package works with either version 3 or version -4 of the `base` package, you could select the available version in your -Haskell modules like this: - -~~~~~~~~~~~~~~~~ -#if MIN_VERSION_base(4,0,0) -... code that works with base-4 ... -#else -... code that works with base-3 ... -#endif -~~~~~~~~~~~~~~~~ - -In general, Cabal supplies a macro `MIN_VERSION_`_`package`_`_(A,B,C)` -for each package depended on via `build-depends`. This macro is true if -the actual version of the package in use is greater than or equal to -`A.B.C` (using the conventional ordering on version numbers, which is -lexicographic on the sequence, but numeric on each component, so for -example 1.2.0 is greater than 1.0.3). - -Cabal places the definitions of these macros into an -automatically-generated header file, which is included when -preprocessing Haskell source code by passing options to the C -preprocessor. - -## More complex packages ## - -For packages that don't fit the simple schemes described above, you have -a few options: - - * You can customize the simple build infrastructure using _hooks_. - These allow you to perform additional actions before and after each - command is run, and also to specify additional preprocessors. See - `UserHooks` in [Distribution.Simple][dist-simple] for the details, - but note that this interface is experimental, and likely to change - in future releases. - - * You could delegate all the work to `make`, though this is unlikely - to be very portable. Cabal supports this with the `build-type` - `Make` and a trivial setup library [Distribution.Make][dist-make], - which simply parses the command line arguments and invokes `make`. - Here `Setup.hs` looks like - - ~~~~~~~~~~~~~~~~ - import Distribution.Make - main = defaultMain - ~~~~~~~~~~~~~~~~ - - The root directory of the package should contain a `configure` - script, and, after that has run, a `Makefile` with a default target - that builds the package, plus targets `install`, `register`, - `unregister`, `clean`, `dist` and `docs`. Some options to commands - are passed through as follows: - - * The `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, - `--datadir` and `--libexecdir` options to the `configure` - command are passed on to the `configure` script. In addition the - value of the `--with-compiler` option is passed in a `--with-hc` - option and all options specified with `--configure-option=` are - passed on. - - * The `--destdir` option to the `copy` command becomes a setting - of a `destdir` variable on the invocation of `make copy`. The - supplied `Makefile` should provide a `copy` target, which will - probably look like this: - - ~~~~~~~~~~~~~~~~ - copy : - $(MAKE) install prefix=$(destdir)/$(prefix) \ - bindir=$(destdir)/$(bindir) \ - libdir=$(destdir)/$(libdir) \ - datadir=$(destdir)/$(datadir) \ - libexecdir=$(destdir)/$(libexecdir) - ~~~~~~~~~~~~~~~~ - - * You can write your own setup script conforming to the interface - described in the section on [building and installing - packages](#building-and-installing-a-package), possibly using the - Cabal library for 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 -[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/ -[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/ diff --git a/cabal/cabal/doc/index.markdown b/cabal/cabal/doc/index.markdown deleted file mode 100644 --- a/cabal/cabal/doc/index.markdown +++ /dev/null @@ -1,169 +0,0 @@ -% Cabal User Guide - -Cabal is package system for [Haskell] software. - -Cabal specifies a standard way in which Haskell libraries and -applications can be packaged so that it is easy for consumers to use -them, or re-package them, regardless of the Haskell implementation or -installation platform. - -Cabal defines a common interface -- the _Cabal package_ -- between -package authors, builders and users. There is a library to help package -authors implement this interface, and a tool to enable developers, -builders and users to work with Cabal packages. - -# Contents # - - * [Introduction](#introduction) - - [What's in a package](#whats-in-a-package) - - [A tool for working with packages](#a-tool-for-working-with-packages) - * [Developing packages](developing-packages.html) - - [Package descriptions](developing-packages.html#package-descriptions) - + [Package properties](developing-packages.html#package-properties) - + [Library](developing-packages.html#library) - + [Executables](developing-packages.html#executables) - + [Test suites](developing-packages.html#test-suites) - + [Build information](developing-packages.html#build-information) - + [Configurations](developing-packages.html#configurations) - + [Source Repositories](developing-packages.html#source-repositories) - - [Accessing data files from package code](developing-packages.html#accessing-data-files-from-package-code) - + [Accessing the package version](developing-packages.html#accessing-the-package-version) - - [System-dependent parameters](developing-packages.html#system-dependent-parameters) - - [Conditional compilation](developing-packages.html#conditional-compilation) - - [More complex packages](developing-packages.html#more-complex-packages) - * [Building and installing packages](installing-packages.html) - - [Building and installing a system package](installing-packages.html#building-and-installing-a-system-package) - - [Building and installing a user package](installing-packages.html#building-and-installing-a-user-package) - - [Creating a binary package](installing-packages.html#creating-a-binary-package) - - [setup configure](installing-packages.html#setup-configure) - + [Programs used for building](installing-packages.html#programs-used-for-building) - + [Installation paths](installing-packages.html#installation-paths) - + [Controlling Flag Assignments](installing-packages.html#controlling-flag-assignments) - + [Building Test Suites](installing-packages.html#building-test-suites) - + [Miscellaneous options](installing-packages.html#miscellaneous-options) - - [setup build](installing-packages.html#setup-build) - - [setup haddock](installing-packages.html#setup-haddock) - - [setup hscolour](installing-packages.html#setup-hscolour) - - [setup install](installing-packages.html#setup-install) - - [setup copy](installing-packages.html#setup-copy) - - [setup register](installing-packages.html#setup-register) - - [setup unregister](installing-packages.html#setup-unregister) - - [setup clean](installing-packages.html#setup-clean) - - [setup test](installing-packages.html#setup-test) - - [setup sdist](installing-packages.html#setup-sdist) - * [Reporting bugs and deficiencies](misc.html#reporting-bugs-and-deficiencies) - * [Stability of Cabal interfaces](misc.html#stability-of-cabal-interfaces) - - [Cabal file format](misc.html#cabal-file-format) - - [Command-line interface](misc.html#command-line-interface) - + [Very Stable Command-line interfaces](misc.html#very-stable-command-line-interfaces) - + [Stable Command-line interfaces](misc.html#stable-command-line-interfaces) - + [Unstable command-line](misc.html#unstable-command-line) - - [Functions and Types](misc.html#functions-and-types) - + [Very Stable API](misc.html#very-stable-api) - + [Semi-stable API](misc.html#semi-stable-api) - + [Unstable API](#unstable-api) - - [Hackage](misc.html#hackage) - -# Introduction # - -Cabal is package system for Haskell software. The point of a packaging -system is to enable software developers and users to easily distribute, -use and reuse software. A good packaging system makes it easier for -developers to get their software into the hands of users, but equally -importantly it makes it easier for software developers to be able to -reuse software components written by other developers. - -Packaging systems deal with packages and with Cabal we call them _Cabal -packages_. The Cabal package is the unit of distribution. Every Cabal -package has a name and a version number which are used to identify the -package, e.g. `filepath-1.0`. - -Cabal packages are source based and are typically (but not necessarily) -portable to many platforms and Haskell implementations. The Cabal -package format is designed to make it possible to translate into other -formats, including binary packages for various systems. - -When distributed, Cabal packages use the standard compressed tarball -format, with the file extension `.tar.gz`, e.g. `filepath-1.0.tar.gz`. - -Note that packages are not part of the Haskell language, but most -Haskell implementations have some notion of package, and Cabal supports -most Haskell implementations. - - -## What's in a package ## - -A Cabal package consists of: - - * Haskell software, including libraries, executables and tests - * meta-data about the package in a standard human and machine - readable format (the "`.cabal`" file) - * a standard interface to build the package (the "`Setup.hs`" file) - -The `.cabal` file contains information about the package, supplied by -the package author. Some of this information is used for identifying and -managing the package when it comes to distribution. - -For the majority of packages it is possible to supply enough information -in the `.cabal` file so that it can be built without the package author -needing to write any extra build system scripts. For complex packages it -may be necessary to add code to the `Setup.hs` file. - -Here is an example `foo.cabal` for a very simple Haskell library that -exposes one Haskell module called `Data.Foo`: - -~~~~~~~~~~~~~~~~ -name: foo -version: 1.0 -build-type: Simple -cabal-version: >= 1.2 - -library - exposed-modules: Data.Foo - build-depends: base >= 3 && < 5 -~~~~~~~~~~~~~~~~ - -For full details on what goes in the `.cabal` and `Setup.hs` files, and -for all the other features provided by the build system, see the section -on [developing packages](developing-packages.html). - - -## A tool for working with packages ## - -There is a command line tool, called `cabal`, that users and developers -can use to install Cabal packages. It can be used for both local -packages and for packages available remotely over the network. - -Developers can use the tool with packages in local directories, e.g. - -~~~~~~~~~~~~~~~~ -cd foo/ -cabal install -~~~~~~~~~~~~~~~~ - -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 centeralised Haskell community archive called [Hackage] but it -is possible to use it with any other suitable archive. - -~~~~~~~~~~~~~~~~ -cabal install xmonad -~~~~~~~~~~~~~~~~ - -This will install the `xmonad` package plus all of its dependencies. - -Cabal provides a number of ways for a user to customise how and where a -package is installed. They can decide where a package will be installed, -which Haskell implementation to use and whether to build optimised code -or build with the ability to profile code. It is not expected that users -will have to modify any of the information in the `.cabal` file. - -For full details, see the section on [building and installing -packages](installing-packages.html). - -Note that `cabal` is not the only tool for working with Cabal packages. -Due to the standardised format and a library for reading `.cabal` files, -there are several other special-purpose tools. - -[Haskell]: http://www.haskell.org/ -[Hackage]: http://hackage.haskell.org/ diff --git a/cabal/cabal/doc/installing-packages.markdown b/cabal/cabal/doc/installing-packages.markdown deleted file mode 100644 --- a/cabal/cabal/doc/installing-packages.markdown +++ /dev/null @@ -1,809 +0,0 @@ -% Cabal User Guide - - -# Building and installing packages # - -After you've unpacked a Cabal package, you can build it by moving into -the root directory of the package and using the `Setup.hs` or -`Setup.lhs` script there: - -> `_runhaskell_ Setup.hs` [_command_] [_option_...] - -The _command_ argument selects a particular step in the build/install -process. You can also get a summary of the command syntax with - -> `runhaskell Setup.hs --help` - -## Building and installing a system package ## - -~~~~~~~~~~~~~~~~ -runhaskell Setup.hs configure --ghc -runhaskell Setup.hs build -runhaskell Setup.hs install -~~~~~~~~~~~~~~~~ - -The first line readies the system to build the tool using GHC; for -example, it checks that GHC exists on the system. The second line -performs the actual building, while the last both copies the build -results to some permanent place and registers the package with GHC. - -## Building and installing a user package ## - -~~~~~~~~~~~~~~~~ -runhaskell Setup.hs configure --user -runhaskell Setup.hs build -runhaskell Setup.hs install -~~~~~~~~~~~~~~~~ - -The package is installed under the user's home directory and is -registered in the user's package database (`--user`). - -## Creating a binary package ## - -When creating binary packages (e.g. for RedHat or Debian) one needs to -create a tarball that can be sent to another system for unpacking in the -root directory: - -~~~~~~~~~~~~~~~~ -runhaskell Setup.hs configure --prefix=/usr -runhaskell Setup.hs build -runhaskell Setup.hs copy --destdir=/tmp/mypkg -tar -czf mypkg.tar.gz /tmp/mypkg/ -~~~~~~~~~~~~~~~~ - -If the package contains a library, you need two additional steps: - -~~~~~~~~~~~~~~~~ -runhaskell Setup.hs register --gen-script -runhaskell Setup.hs unregister --gen-script -~~~~~~~~~~~~~~~~ - -This creates shell scripts `register.sh` and `unregister.sh`, which must -also be sent to the target system. After unpacking there, the package -must be registered by running the `register.sh` script. The -`unregister.sh` script would be used in the uninstall procedure of the -package. Similar steps may be used for creating binary packages for -Windows. - - -The following options are understood by all commands: - -`--help`, `-h` or `-?` -: List the available options for the command. - -`--verbose=`_n_ or `-v`_n_ -: Set the verbosity level (0-3). The normal level is 1; a missing _n_ - defaults to 2. - -The various commands and the additional options they support are -described below. In the simple build infrastructure, any other options -will be reported as errors. - -## setup configure ## - -Prepare to build the package. Typically, this step checks that the -target platform is capable of building the package, and discovers -platform-specific features that are needed during the build. - -The user may also adjust the behaviour of later stages using the options -listed in the following subsections. In the simple build -infrastructure, the values supplied via these options are recorded in a -private file read by later stages. - -If a user-supplied `configure` script is run (see the section on -[system-dependent parameters](#system-dependent-parameters) or on -[complex packages](#complex-packages)), it is passed the -`--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, `--datadir` and -`--libexecdir` 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` -: Specify which Haskell implementation to use to build the package. - At most one of these flags may be given. If none is given, the - implementation under which the setup script was compiled or - interpreted is used. - -`--with-compiler=`_path_ or `-w`_path_ -: Specify the path to a particular compiler. If given, this must match - the implementation selected above. The default is to search for the - usual name of the selected implementation. - - This flag also sets the default value of the `--with-hc-pkg` option - to the package tool for this compiler. Check the output of `setup - configure -v` to ensure that it finds the right package tool (or use - `--with-hc-pkg` explicitly). - - -`--with-hc-pkg=`_path_ -: Specify the path to the package tool, e.g. `ghc-pkg`. The package - tool must be compatible with the compiler specified by - `--with-compiler`. If this option is omitted, the default value is - determined from the compiler selected. - -`--with-`_`prog`_`=`_path_ -: Specify the path to the program _prog_. Any program known to Cabal - can be used in place of _prog_. It can either be a fully path or the - name of a program that can be found on the program search path. For - example: `--with-ghc=ghc-6.6.1` or - `--with-cpphs=/usr/local/bin/cpphs`. - -`--`_`prog`_`-options=`_options_ -: Specify additional options to the program _prog_. Any program known - to Cabal can be used in place of _prog_. For example: - `--alex-options="--template=mytemplatedir/"`. The _options_ is split - into program options based on spaces. Any options containing embeded - spaced need to be quoted, for example - `--foo-options='--bar="C:\Program File\Bar"'`. As an alternative - that takes only one option at a time but avoids the need to quote, - use `--`_`prog`_`-option` instead. - -`--`_`prog`_`-option=`_option_ -: Specify a single additional option to the program _prog_. For - passing an option that contain embeded spaces, such as a file name - with embeded spaces, using this rather than `--`_`prog`_`-options` - means you do not need an additional level of quoting. Of course if - you are using a command shell you may still need to quote, for - example `--foo-options="--bar=C:\Program File\Bar"`. - -All of the options passed with either `--`_`prog`_`-options` or -`--`_`prog`_`-option` are passed in the order they were specified on the -configure command line. - -### Installation paths ### - -The following options govern the location of installed files from a -package: - -`--prefix=`_dir_ -: The root of the installation. For example for a global install you - might use `/usr/local` on a Unix system, or `C:\Program Files` on a - Windows system. The other installation paths are usually - subdirectories of _prefix_, but they don't have to be. - - In the simple build system, _dir_ may contain the following path - variables: `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, - `$arch` - -`--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` - -`--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` - -`--libexecdir=`_dir_ -: Executables that are not expected to be invoked directly by the user - are installed here. - - In the simple build system, _dir_ may contain the following path - variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, - `$pkg`, `$version`, `$compiler`, `$os`, `$arch` - -`--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` - -In addition the simple build system supports the following installation path options: - -`--libsubdir=`_dir_ -: A subdirectory of _libdir_ in which libraries are actually - installed. For example, in the simple build system on Unix, the - default _libdir_ is `/usr/local/lib`, and _libsubdir_ contains the - package identifier and compiler, e.g. `mypkg-0.2/ghc-6.4`, so - libraries would be installed in `/usr/local/lib/mypkg-0.2/ghc-6.4`. - - _dir_ may contain the following path variables: `$pkgid`, `$pkg`, - `$version`, `$compiler`, `$os`, `$arch` - -`--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` - -`--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` - -`--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` - -`--program-prefix=`_prefix_ -: Prepend _prefix_ to installed program names. - - _prefix_ may contain the following path variables: `$pkgid`, `$pkg`, - `$version`, `$compiler`, `$os`, `$arch` - -`--program-suffix=`_suffix_ -: Append _suffix_ to installed program names. The most obvious use for - this is to append the program's version number to make it possible - to install several versions of a program at once: - `--program-suffix='$version'`. - - _suffix_ may contain the following path variables: `$pkgid`, `$pkg`, - `$version`, `$compiler`, `$os`, `$arch` - -#### Path variables in the simple build system #### - -For the simple build system, there are a number of variables that can be -used when specifying installation paths. The defaults are also specified -in terms of these variables. A number of the variables are actually for -other paths, like `$prefix`. This allows paths to be specified relative -to each other rather than as absolute paths, which is important for -building relocatable packages (see [prefix -independence](#prefix-independence)). - -`$prefix` -: The path variable that stands for the root of the installation. For - an installation to be relocatable, all other instllation paths must - be relative to the `$prefix` variable. - -`$bindir` -: The path variable that expands to the path given by the `--bindir` - configure option (or the default). - -`$libdir` -: As above but for `--libdir` - -`$libsubdir` -: As above but for `--libsubdir` - -`$datadir` -: As above but for `--datadir` - -`$datasubdir` -: As above but for `--datasubdir` - -`$docdir` -: As above but for `--docdir` - -`$pkgid` -: The name and version of the package, eg `mypkg-0.2` - -`$pkg` -: The name of the package, eg `mypkg` - -`$version` -: The version of the package, eg `0.2` - -`$compiler` -: The compiler being used to build the package, eg `ghc-6.6.1` - -`$os` -: The operating system of the computer being used to build the - package, eg `linux`, `windows`, `osx`, `freebsd` or `solaris` - -`$arch` -: The architecture of the computer being used to build the package, eg - `i386`, `x86_64`, `ppc` or `sparc` - -#### Paths in the simple build system #### - -For the simple build system, the following defaults apply: - -Option Windows Default Unix Default -------- ---------------- ------------- -`--prefix` (global) `C:\Program Files\Haskell` `/usr/local` -`--prefix` (per-user) `C:\Documents And Settings\user\Application Data\cabal` `$HOME/.cabal` -`--bindir` `$prefix\bin` `$prefix/bin` -`--libdir` `$prefix` `$prefix/lib` -`--libsubdir` (Hugs) `hugs\packages\$pkg` `hugs/packages/$pkg` -`--libsubdir` (others) `$pkgid\$compiler` `$pkgid/$compiler` -`--libexecdir` `$prefix\$pkgid` `$prefix/libexec` -`--datadir` (executable) `$prefix` `$prefix/share` -`--datadir` (library) `C:\Program Files\Haskell` `$prefix/share` -`--datasubdir` `$pkgid` `$pkgid` -`--docdir` `$prefix\doc\$pkgid` `$datadir/doc/$pkgid` -`--htmldir` `$docdir\html` `$docdir/html` -`--program-prefix` (empty) (empty) -`--program-suffix` (empty) (empty) - - -#### 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. - -In order to achieve this, we require that for an executable on Windows, -all of `$bindir`, `$libdir`, `$datadir` and `$libexecdir` begin with -`$prefix`. If this is not the case then the compiled executable will -have baked-in all absolute paths. - -The application need do nothing special to achieve prefix-independence. -If it finds any files using `getDataFileName` and the [other functions -provided for the purpose](#accessing-data-files-from-package-code), the -files will be accessed relative to the location of the current -executable. - -A library cannot (currently) be prefix-independent, because it will be -linked into an executable whose file system location bears no relation -to the library package. - -### Controlling Flag Assignments ### - -Flag assignments (see the [resolution of conditions and -flags](#resolution-of-conditions-and-flags)) can be controlled with the -followingcommand line options. - -`-f` _flagname_ or `-f` `-`_flagname_ -: Force the specified flag to `true` or `false` (if preceded with a `-`). Later - specifications for the same flags will override earlier, i.e., - specifying `-fdebug -f-debug` is equivalent to `-f-debug` - -`--flags=`_flagspecs_ -: Same as `-f`, but allows specifying multiple flag assignments at - once. The parameter is a space-separated list of flag names (to - force a flag to `true`), optionally preceded by a `-` (to force a - flag to `false`). For example, `--flags="debug -feature1 feature2"` is - equivalent to `-fdebug -f-feature1 -ffeature2`. - -### Building Test Suites ### - -`--enable-tests` -: Build the test suites defined in the package description file during the - `build` stage. Check for dependencies required by the test suites. If the - package is configured with this option, it will be possible to run the test - suites with the `test` command after the package is built. - -`--disable-tests` -: (default) Do not build any test suites during the `build` stage. - Do not check for dependencies required only by the test suites. It will not - be possible to invoke the `test` command without reconfiguring the package. - -### Miscellaneous options ## - -`--user` -: Does a per-user installation. This changes the [default installation - prefix](#paths-in-the-simple-build-system). It also allow - dependencies to be satisfied by the user's package database, in - addition to the global database. This also implies a default of - `--user` for any subsequent `install` command, as packages - registered in the global database should not depend on packages - registered in a user's database. - -`--global` -: (default) Does a global installation. In this case package - dependencies must be satisfied by the global package database. All - packages in the user's package database will be ignored. Typically - the final instllation step will require administrative privileges. - -`--package-db=`_db_ -: Allows package dependencies to be satisfied from this additional - package database _db_ in addition to the global package database. - All packages in the user's package database will be ignored. The - interpretation of _db_ is implementation-specific. Typically it will - be a file or directory. Not all implementations support arbitrary - package databases. - -`--enable-optimization`[=_n_] or `-O`[_n_] -: (default) Build with optimization flags (if available). This is - appropriate for production use, taking more time to build faster - libraries and programs. - - The optional _n_ value is the optimisation level. Some compilers - support multiple optimisation levels. The range is 0 to 2. Level 0 - is equivalent to `--disable-optimization`, level 1 is the default if - no _n_ parameter is given. Level 2 is higher optimisation if the - compiler supports it. Level 2 is likely to lead to longer compile - times and bigger generated code. - -`--disable-optimization` -: Build without optimization. This is suited for development: building - will be quicker, but the resulting library or programs will be slower. - -`--enable-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). - -`--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. - -`--disable-executable-profiling` -: (default) Do not enable profiling in generated executables. - -`--enable-library-vanilla` -: (default) Build ordinary libraries (as opposed to profiling - libraries). This is independent of the `--enable-library-profiling` - option. If you enable both, you get both. - -`--disable-library-vanilla` -: Do not build ordinary libraries. This is useful in conjunction with - `--enable-library-profiling` to build only profiling libraries, - rather than profiling and ordinary libraries. - -`--enable-library-for-ghci` -: (default) Build libraries suitable for use with GHCi. - -`--disable-library-for-ghci` -: Not all platforms support GHCi and indeed on some platforms, trying - to build GHCi libs fails. In such cases this flag can be used as a - workaround. - -`--enable-split-objs` -: Use the GHC `-split-objs` feature when building the library. This - reduces the final size of the executables that use the library by - allowing them to link with only the bits that they use rather than - the entire library. The downside is that building the library takes - longer and uses considerably more memory. - -`--disable-split-objs` -: (default) Do not use the GHC `-split-objs` feature. This makes - building the library quicker but the final executables that use the - library will be larger. - -`--enable-executable-stripping` -: (default) When installing binary executable programs, run the - `strip` program on the binary. This can considerably reduce the size - of the executable binary file. It does this by removing debugging - information and symbols. While such extra information is useful for - debugging C programs with traditional debuggers it is rarely helpful - for debugging binaries produced by Haskell compilers. - - Not all Haskell implementations generate native binaries. For such - implementations this option has no effect. - -`--disable-executable-stripping` -: Do not strip binary executables during installation. You might want - to use this option if you need to debug a program using gdb, for - example if you want to debug the C parts of a program containing - both Haskell and C code. Another reason is if your are building a - package for a system which has a policy of managing the stripping - itself (such as some linux distributions). - -`--enable-shared` -: Build shared library. This implies a seperate compiler run to - generate position independent code as required on most platforms. - -`--disable-shared` -: (default) Do not build shared library. - -`--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. - -`--extra-include-dirs`[=_dir_] -: An extra directory to search for C header files. You can use this - flag multiple times to get a list of directories. - - You might need to use this flag if you have standard system header - files in a non-standard location that is not mentioned in the - package's `.cabal` file. Using this option has the same affect as - appending the directory _dir_ to the `include-dirs` field in each - library and executable in the package's `.cabal` file. The advantage - of course is that you do not have to modify the package at all. - These extra directories will be used while building the package and - for libraries it is also saved in the package registration - information and used when compiling modules that use the library. - -`--extra-lib-dirs`[=_dir_] -: An extra directory to search for system libraries files. You can use - this flag multiple times to get a list of directories. - - You might need to use this flag if you have standard system - libraries in a non-standard location that is not mentioned in the - package's `.cabal` file. Using this option has the same affect as - appending the directory _dir_ to the `extra-lib-dirs` field in each - library and executable in the package's `.cabal` file. The advantage - of course is that you do not have to modify the package at all. - These extra directories will be used while building the package and - for libraries it is also saved in the package registration - information and used when compiling modules that use the library. - -In the simple build infrastructure, an additional option is recognized: - -`--scratchdir=`_dir_ -: Specify the directory into which the Hugs output will be placed - (default: `dist/scratch`). - -## setup build ## - -Perform any preprocessing or compilation needed to make this package ready for installation. - -This command takes the following options: - ---_prog_-options=_options_, --_prog_-option=_option_ -: These are mostly the same as the [options configure - step](#setup-configure). Unlike the options specified at the - configure step, any program options specified at the build step are - not persistent but are used for that invocation only. They options - specified at the build step are in addition not in replacement of - any options specified at the configure step. - -## setup haddock ## - -Build the documentation for the package using [haddock][]. By default, -only the documentation for the exposed modules is generated (but see the -`--executables` and `--internal` flags below). - -This command takes the following options: - -`--hoogle` -: Generate a file `dist/doc/html/`_pkgid_`.txt`, which can be - converted by [Hoogle](http://www.haskell.org/hoogle/) into a - database for searching. This is equivalent to running [haddock][] - with the `--hoogle` flag. - -`--html-location=`_url_ -: Specify a template for the location of HTML documentation for - prerequisite packages. The substitutions ([see - listing](#paths-in-the-simple-build-system)) are applied to the - template to obtain a location for each package, which will be used - by hyperlinks in the generated documentation. For example, the - following command generates links pointing at [Hackage] pages: - - > setup haddock --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' - - Here the argument is quoted to prevent substitution by the shell. If - this option is omitted, the location for each package is obtained - using the package tool (e.g. `ghc-pkg`). - -`--executables` -: Also run [haddock][] for the modules of all the executable programs. - By default [haddock][] is run only on the exported modules. - -`--internal` -: Run [haddock][] for the all modules, including unexposed ones, and - make [haddock][] generate documentation for unexported symbols as - well. - -`--css=`_path_ -: The argument _path_ denotes a CSS file, which is passed to - [haddock][] and used to set the style of the generated - documentation. This is only needed to override the default style - that [haddock][] uses. - -`--hyperlink-source` -: Generate [haddock][] documentation integrated with [HsColour][]. - First, [HsColour][] is run to generate colourised code. Then - [haddock][] is run to generate HTML documentation. Each entity - shown in the documentation is linked to its definition in the - colourised code. - -`--hscolour-css=`_path_ -: The argument _path_ denotes a CSS file, which is passed to [HsColour][] as in - - > runhaskell Setup.hs hscolour --css=_path_ - -## setup hscolour ## - -Produce colourised code in HTML format using [HsColour][]. Colourised -code for exported modules is put in `dist/doc/html/`_pkgid_`/src`. - -This command takes the following options: - -`--executables` -: Also run [HsColour][] on the sources of all executable programs. - Colourised code is put in `dist/doc/html/`_pkgid_/_executable_`/src`. - -`--css=`_path_ -: Use the given CSS file for the generated HTML files. The CSS file - defines the colours used to colourise code. Note that this copies - the given CSS file to the directory with the generated HTML files - (renamed to `hscolour.css`) rather than linking to it. - -## setup install ## - -Copy the files into the install locations and (for library packages) -register the package with the compiler, i.e. make the modules it -contains available to programs. - -The [install locations](#installation-paths) are determined by options -to `setup configure`. - -This command takes the following options: - -`--global` -: Register this package in the system-wide database. (This is the - default, unless the `--user` option was supplied to the `configure` - command.) - -`--user` -: Register this package in the user's local package database. (This is - the default if the `--user` option was supplied to the `configure` - command.) - -## setup copy ## - -Copy the files without registering them. This command is mainly of use -to those creating binary packages. - -This command takes the following option: - -`--destdir=`_path_ - -Specify the directory under which to place installed files. If this is -not given, then the root directory is assumed. - -## setup register ## - -Register this package with the compiler, i.e. make the modules it -contains available to programs. This only makes sense for library -packages. Note that the `install` command incorporates this action. The -main use of this separate command is in the post-installation step for a -binary package. - -This command takes the following options: - -`--global` -: Register this package in the system-wide database. (This is the default.) - - -`--user` -: Register this package in the user's local package database. - - -`--gen-script` -: Instead of registering the package, generate a script containing - commands to perform the registration. On Unix, this file is called - `register.sh`, on Windows, `register.bat`. This script might be - included in a binary bundle, to be run after the bundle is unpacked - on the target system. - -`--gen-pkg-config`[=_path_] -: Instead of registering the package, generate a package registration - file. This only applies to compilers that support package - registration files which at the moment is only GHC. The file should - be used with the compiler's mechanism for registering packages. This - option is mainly intended for packaging systems. If possible use the - `--gen-script` option instead since it is more portable across - Haskell implementations. The _path_ is - optional and can be used to specify a particular output file to - generate. Otherwise, by default the file is the package name and - version with a `.conf` extension. - -`--inplace` -: Registers the package for use directly from the build tree, without - needing to install it. This can be useful for testing: there's no - need to install the package after modifying it, just recompile and - test. - - This flag does not create a build-tree-local package database. It - still registers the package in one of the user or global databases. - - However, there are some caveats. It only works with GHC - (currently). It only works if your package doesn't depend on having - any supplemental files installed --- plain Haskell libraries should - be fine. - -## setup unregister ## - -Deregister this package with the compiler. - -This command takes the following options: - -`--global` -: Deregister this package in the system-wide database. (This is the default.) - -`--user` -: Deregister this package in the user's local package database. - -`--gen-script` -: Instead of deregistering the package, generate a script containing - commands to perform the deregistration. On Unix, this file is - called `unregister.sh`, on Windows, `unregister.bat`. This script - might be included in a binary bundle, to be run on the target - system. - -## setup clean ## - -Remove any local files created during the `configure`, `build`, -`haddock`, `register` or `unregister` steps, and also any files and -directories listed in the `extra-tmp-files` field. - -This command takes the following options: - -`--save-configure` or `-s` -: Keeps the configuration information so it is not necessary to run - the configure step again before building. - -## setup test ## - -Run the test suites specified in the package description file. Aside from -the following flags, Cabal accepts the name of one or more test suites on the -command line after `test`. When supplied, Cabal will run only the named test -suites, otherwise, Cabal will run all test suites in the package. - -`--builddir=`_dir_ -: The directory where Cabal puts generated build files (default: `dist`). - Test logs will be located in the `test` subdirectory. - -`--human-log=`_path_ -: The template used to name human-readable test logs; the path is relative - to `dist/test`. By default, logs are named according to the template - `$pkgid-$test-suite.log`, so that each test suite will be logged to its own - human-readable log file. Template variables allowed are: `$pkgid`, - `$compiler`, `$os`, `$arch`, `$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`. - -`--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). - -`--test-options=`_options_ -: Give extra options to the test executables. - -`--test-option=`_option_ -: give an extra option to the test executables. There is no need to quote - options containing spaces because a single option is assumed, so options - will not be split on spaces. - -## setup sdist ## - -Create a system- and compiler-independent source distribution in a file -_package_-_version_`.tar.gz` in the `dist` subdirectory, for -distribution to package builders. When unpacked, the commands listed in -this section will be available. - -The files placed in this distribution are the package description file, -the setup script, the sources of the modules named in the package -description file, and files named in the `license-file`, `main-is`, -`c-sources`, `data-files` and `extra-source-files` fields. - -This command takes the following option: - -`--snapshot` -: Append today's date (in "YYYYMMDD" format) to the version number for - the generated source package. The original package is unaffected. - - -[dist-simple]: ../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 -[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/ -[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/ diff --git a/cabal/cabal/doc/misc.markdown b/cabal/cabal/doc/misc.markdown deleted file mode 100644 --- a/cabal/cabal/doc/misc.markdown +++ /dev/null @@ -1,109 +0,0 @@ -% Cabal User Guide - -# Reporting bugs and deficiencies # - -Please report any flaws or feature requests in the [bug tracker][]. - -For general discussion or queries email the libraries mailing list -. There is also a development mailing list -. - -[bug tracker]: http://hackage.haskell.org/trac/hackage/ - -# Stability of Cabal interfaces # - -The Cabal library and related infrastructure is still under active -development. New features are being added and limitations and bugs are -being fixed. This requires internal changes and often user visible -changes as well. We therefor cannot promise complete future-proof -stability, at least not without halting all development work. - -This section documents the aspects of the Cabal interface that we can -promise to keep stable and which bits are subject to change. - -## Cabal file format ## - -This is backwards compatible and mostly forwards compatible. New fields -can be added without breaking older versions of Cabal. Fields can be -deprecated without breaking older packages. - -## Command-line interface ## - -### Very Stable Command-line interfaces ### - -* `./setup configure` - * `--prefix` - * `--user` - * `--ghc`, `--hugs` - * `--verbose` - * `--prefix` - -* `./setup build` -* `./setup install` -* `./setup register` -* `./setup copy` - -### Stable Command-line interfaces ### - -### Unstable command-line ### - -## Functions and Types ## - -The Cabal library follows the [Package Versioning Policy][PVP]. This -means that within a stable major release, for example 1.2.x, there will -be no incompatible API changes. But minor versions increments, for -example 1.2.3, indicate compatible API additions. - -The Package Versioning Policy does not require any API guarantees -between major releases, for example between 1.2.x and 1.4.x. In practise -of course not everything changes between major releases. Some parts of -the API are more prone to change than others. The rest of this section -gives some informal advice on what level of API stability you can expect -between major releases. - -[PVP]: http://haskell.org/haskellwiki/Package_versioning_policy - -### Very Stable API ### - -* `defaultMain` - -* `defaultMainWithHooks defaultUserHooks` - - But regular `defaultMainWithHooks` isn't stable since `UserHooks` - changes. - -### Semi-stable API ### - -* `UserHooks` The hooks API will change in the future - -* `Distribution.*` is mostly declarative information about packages and - is somewhat stable. - -### Unstable API ### - -Everything under `Distribution.Simple.*` has no stability guarantee. - -## Hackage ## - -The index format is a partly stable interface. It consists of a tar.gz -file that contains directories with `.cabal` files in. In future it may -contain more kinds of files so do not assume every file is a `.cabal` -file. Incompatible revisions to the format would involve bumping the -name of the index file, i.e., `00-index.tar.gz`, `01-index.tar.gz` etc. - - -[dist-simple]: ../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 -[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/ -[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/ diff --git a/cabal/cabal/prologue.txt b/cabal/cabal/prologue.txt deleted file mode 100644 --- a/cabal/cabal/prologue.txt +++ /dev/null @@ -1,7 +0,0 @@ -The Haskell Cabal is the Common Architecture for Building Applications -and Libraries. It is a framework which defines a common interface for -authors to more easily build their applications in a portable way. The -Haskell Cabal is meant to be a part of a larger infrastructure for -distributing, organizing, and cataloging Haskell Libraries and -Tools. For more information, please see: -. diff --git a/cabal/cabal/runTests.sh b/cabal/cabal/runTests.sh deleted file mode 100644 --- a/cabal/cabal/runTests.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/bin/sh - -HCBASE=/usr/bin/ -HC=$HCBASE/ghc -GHCFLAGS='--make -Wall -fno-warn-unused-matches -cpp' -ISPOSIX=-DHAVE_UNIX_PACKAGE - -rm -f moduleTest -mkdir -p dist/debug -echo Building... -$HC $GHCFLAGS $ISPOSIX -DDEBUG -odir dist/debug -hidir dist/debug -idist/debug/:.:tests/HUnit-1.0/src tests/ModuleTest.hs -o moduleTest 2> stderr -RES=$? -if [ $RES != 0 ] -then - cat stderr >&2 - exit $RES -fi -echo Running... -./moduleTest -echo Done - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs +++ /dev/null @@ -1,15 +0,0 @@ -module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive1") [] - result <- cabal_build spec - assertEqual "cabal build should fail - see test-log.txt" False (successful result) - assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $ - "Failed to load interface for `Prelude'" `isInfixOf` outputText result diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal +++ /dev/null @@ -1,20 +0,0 @@ -name: GlobalBuildDepsNotAdditive1 -version: 0.1 -license: BSD3 -cabal-version: >= 1.6 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - If you specify 'base' in the global build dependencies, then define - a library without base, it fails to find 'base' for the library. - ---------------------------------------- - -build-depends: base - -Library - exposed-modules: MyLibrary - build-depends: bytestring, old-time diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs +++ /dev/null @@ -1,15 +0,0 @@ -module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive2") [] - result <- cabal_build spec - assertEqual "cabal build should fail - see test-log.txt" False (successful result) - assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $ - "Failed to load interface for `Prelude'" `isInfixOf` outputText result diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal +++ /dev/null @@ -1,20 +0,0 @@ -name: GlobalBuildDepsNotAdditive1 -version: 0.1 -license: BSD3 -cabal-version: >= 1.6 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - If you specify 'base' in the global build dependencies, then define - an executable without base, it fails to find 'base' for the executable - ---------------------------------------- - -build-depends: base - -Executable lemon - main-is: lemon.hs - build-depends: bytestring, old-time diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs +++ /dev/null @@ -1,7 +0,0 @@ -import qualified Data.ByteString.Char8 as C -import System.Time - -main = do - getClockTime - let text = "lemon" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs +++ /dev/null @@ -1,20 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary0.Check where - -import Test.HUnit -import PackageTests.PackageTester -import Control.Monad -import System.FilePath -import Data.Version -import Data.List (isInfixOf, intercalate) - - -suite :: Version -> Test -suite cabalVersion = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary0") [] - result <- cabal_build spec - assertEqual "cabal build should fail" False (successful result) - when (cabalVersion >= Version [1, 7] []) $ do - -- In 1.7 it should tell you how to enable the desired behaviour. - assertEqual "error should say 'library which is defined within the same package.'" True $ - "library which is defined within the same package." `isInfixOf` (intercalate " " $ lines $ outputText result) - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal +++ /dev/null @@ -1,24 +0,0 @@ -name: InternalLibrary0 -version: 0.1 -license: BSD3 -cabal-version: >= 1.6 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - Check that with 'cabal-version:' containing versions less than 1.7, we do *not* - have the new behaviour to allow executables to refer to the library defined - in the same module. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time - -Executable lemon - main-is: lemon.hs - hs-source-dirs: programs - build-depends: base, bytestring, old-time, InternalLibrary0 diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs +++ /dev/null @@ -1,6 +0,0 @@ -import System.Time -import MyLibrary - -main = do - getClockTime - myLibFunc diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs +++ /dev/null @@ -1,12 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary1.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary1") [] - result <- cabal_build spec - assertEqual "cabal build should succeed - see test-log.txt" True (successful result) diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal +++ /dev/null @@ -1,23 +0,0 @@ -name: InternalLibrary1 -version: 0.1 -license: BSD3 -cabal-version: >= 1.7.1 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - Check for the new (in >= 1.7.1) ability to allow executables to refer to - the library defined in the same module. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time - -Executable lemon - main-is: lemon.hs - hs-source-dirs: programs - build-depends: base, bytestring, old-time, InternalLibrary1 diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs +++ /dev/null @@ -1,6 +0,0 @@ -import System.Time -import MyLibrary - -main = do - getClockTime - myLibFunc diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs +++ /dev/null @@ -1,24 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary2.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import qualified Data.ByteString.Char8 as C - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary2") [] - let specTI = PackageSpec (directory spec "to-install") [] - - unregister "InternalLibrary2" - iResult <- cabal_install specTI - assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) - bResult <- cabal_build spec - assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) - unregister "InternalLibrary2" - - (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] - C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) - assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output) - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc internal" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal +++ /dev/null @@ -1,23 +0,0 @@ -name: InternalLibrary2 -version: 0.1 -license: BSD3 -cabal-version: >= 1.7.1 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - This test is to make sure that the internal library is preferred by ghc to - an installed one of the same name and version. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time - -Executable lemon - main-is: lemon.hs - hs-source-dirs: programs - build-depends: base, bytestring, old-time, InternalLibrary2 diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs +++ /dev/null @@ -1,6 +0,0 @@ -import System.Time -import MyLibrary - -main = do - getClockTime - myLibFunc diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc installed" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal +++ /dev/null @@ -1,18 +0,0 @@ -name: InternalLibrary2 -version: 0.1 -license: BSD3 -cabal-version: >= 1.6 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - This test is to make sure that the internal library is preferred by ghc to - an installed one of the same name and version. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs +++ /dev/null @@ -1,24 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary3.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import qualified Data.ByteString.Char8 as C - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary3") [] - let specTI = PackageSpec (directory spec "to-install") [] - - unregister "InternalLibrary3" - iResult <- cabal_install specTI - assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) - bResult <- cabal_build spec - assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) - unregister "InternalLibrary3" - - (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] - C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) - assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output) - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc internal" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal +++ /dev/null @@ -1,23 +0,0 @@ -name: InternalLibrary3 -version: 0.1 -license: BSD3 -cabal-version: >= 1.7.1 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - This test is to make sure that the internal library is preferred by ghc to - an installed one of the same name, but a *newer* version. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time - -Executable lemon - main-is: lemon.hs - hs-source-dirs: programs - build-depends: base, bytestring, old-time, InternalLibrary3 diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs +++ /dev/null @@ -1,6 +0,0 @@ -import System.Time -import MyLibrary - -main = do - getClockTime - myLibFunc diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc installed" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal +++ /dev/null @@ -1,18 +0,0 @@ -name: InternalLibrary3 -version: 0.2 -license: BSD3 -cabal-version: >= 1.6 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - This test is to make sure that the internal library is preferred by ghc to - an installed one of the same name but a *newer* version. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs +++ /dev/null @@ -1,24 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary4.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import qualified Data.ByteString.Char8 as C - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary4") [] - let specTI = PackageSpec (directory spec "to-install") [] - - unregister "InternalLibrary4" - iResult <- cabal_install specTI - assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) - bResult <- cabal_build spec - assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) - unregister "InternalLibrary4" - - (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] - C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) - assertEqual "executable should have linked with the installed library" "myLibFunc installed" (concat $ lines output) - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc internal" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal +++ /dev/null @@ -1,23 +0,0 @@ -name: InternalLibrary4 -version: 0.1 -license: BSD3 -cabal-version: >= 1.7.1 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - This test is to make sure that we can explicitly say we want InternalLibrary4-0.2 - and it will give us the *installed* version 0.2 instead of the internal 0.1. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time - -Executable lemon - main-is: lemon.hs - hs-source-dirs: programs - build-depends: base, bytestring, old-time, InternalLibrary4 >= 0.2 diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs +++ /dev/null @@ -1,6 +0,0 @@ -import System.Time -import MyLibrary - -main = do - getClockTime - myLibFunc diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc installed" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal +++ /dev/null @@ -1,18 +0,0 @@ -name: InternalLibrary4 -version: 0.2 -license: BSD3 -cabal-version: >= 1.6 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - This test is to make sure that the internal library is preferred by ghc to - an installed one of the same name but a *newer* version. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs +++ /dev/null @@ -1,12 +0,0 @@ -module PackageTests.BuildDeps.SameDepsAllRound.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "SameDepsAllRound") [] - result <- cabal_build spec - assertEqual "cabal build should succeed - see test-log.txt" True (successful result) diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal +++ /dev/null @@ -1,31 +0,0 @@ -name: SameDepsAllRound -version: 0.1 -license: BSD3 -cabal-version: >= 1.6 -author: Stephen Blackheath -stability: stable -synopsis: Same dependencies all round -category: PackageTests -build-type: Simple - -description: - Check for the "old build-dep behaviour" namely that we get the same - package dependencies on all build targets, even if different ones - were specified for different targets - . - Here all .hs files use the three packages mentioned, so this shows - that build-depends is not target-specific. This is the behaviour - we want when cabal-version contains versions less than 1.7. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring - -Executable lemon - main-is: lemon.hs - build-depends: old-time - -Executable pineapple - main-is: pineapple.hs diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs +++ /dev/null @@ -1,7 +0,0 @@ -import qualified Data.ByteString.Char8 as C -import System.Time - -main = do - getClockTime - let text = "lemon" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs +++ /dev/null @@ -1,7 +0,0 @@ -import qualified Data.ByteString.Char8 as C -import System.Time - -main = do - getClockTime - let text = "pineapple" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs +++ /dev/null @@ -1,18 +0,0 @@ -module PackageTests.BuildDeps.TargetSpecificDeps1.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps1") [] - result <- cabal_build spec - assertEqual "cabal build should fail - see test-log.txt" False (successful result) - assertBool "error should be in MyLibrary.hs" $ - "MyLibrary.hs:" `isInfixOf` outputText result - assertBool "error should be \"Could not find module `System.Time\"" $ - "Could not find module `System.Time'" `isInfixOf` - (intercalate " " $ lines $ outputText result) diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs +++ /dev/null @@ -1,7 +0,0 @@ -import qualified Data.ByteString.Char8 as C -import System.Time - -main = do - getClockTime - let text = "lemon" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal +++ /dev/null @@ -1,22 +0,0 @@ -name: TargetSpecificDeps1 -version: 0.1 -license: BSD3 -cabal-version: >= 1.7.1 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - Check for the new build-dep behaviour, where build-depends are - handled specifically for each target - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring - -Executable lemon - main-is: lemon.hs - build-depends: base, bytestring, old-time diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs +++ /dev/null @@ -1,13 +0,0 @@ -module PackageTests.BuildDeps.TargetSpecificDeps2.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps2") [] - result <- cabal_build spec - assertEqual "cabal build should succeed - see test-log.txt" True (successful result) diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs +++ /dev/null @@ -1,5 +0,0 @@ -import qualified Data.ByteString.Char8 as C - -main = do - let text = "lemon" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal +++ /dev/null @@ -1,24 +0,0 @@ -name: TargetSpecificDeps1 -version: 0.1 -license: BSD3 -cabal-version: >= 1.7.1 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - Check for the new build-dep behaviour, where build-depends are - handled specifically for each target - This one is a control against TargetSpecificDeps1 - it is correct and should - succeed. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time - -Executable lemon - main-is: lemon.hs - build-depends: base, bytestring diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs +++ /dev/null @@ -1,17 +0,0 @@ -module PackageTests.BuildDeps.TargetSpecificDeps3.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps3") [] - result <- cabal_build spec - assertEqual "cabal build should fail - see test-log.txt" False (successful result) - assertBool "error should be in lemon.hs" $ - "lemon.hs:" `isInfixOf` outputText result - assertBool "error should be \"Could not find module `System.Time\"" $ - "Could not find module `System.Time'" `isInfixOf` (intercalate " " $ lines $ outputText result) diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs +++ /dev/null @@ -1,7 +0,0 @@ -import qualified Data.ByteString.Char8 as C -import System.Time - -main = do - getClockTime - let text = "lemon" - C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal +++ /dev/null @@ -1,22 +0,0 @@ -name: test -version: 0.1 -license: BSD3 -cabal-version: >= 1.7.1 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - Check for the new build-dep behaviour, where build-depends are - handled specifically for each target - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time - -Executable lemon - main-is: lemon.hs - build-depends: base, bytestring diff --git a/cabal/cabal/tests/PackageTests/PackageTester.hs b/cabal/cabal/tests/PackageTests/PackageTester.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/PackageTester.hs +++ /dev/null @@ -1,192 +0,0 @@ -module PackageTests.PackageTester ( - PackageSpec(..), - Success(..), - Result(..), - cabal_configure, - cabal_build, - cabal_test, - cabal_install, - unregister, - run - ) where - -import qualified Control.Exception.Extensible as E -import System.Directory -import System.FilePath -import System.IO -import System.Posix.IO -import System.Process -import System.Exit -import Control.Concurrent.Chan -import Control.Concurrent.MVar -import Control.Concurrent -import Control.Monad -import Data.List -import Data.Maybe -import qualified Data.ByteString.Char8 as C - - -data PackageSpec = - PackageSpec { - directory :: FilePath, - configOpts :: [String] - } - -data Success = Failure | ConfigureSuccess | BuildSuccess | InstallSuccess | TestSuccess deriving (Eq, Show) - -data Result = Result { - successful :: Bool, - success :: Success, - outputText :: String - } - deriving Show - -nullResult :: Result -nullResult = Result True Failure "" - -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 - } - -cabal_configure :: PackageSpec -> IO Result -cabal_configure spec = do - res <- doCabalConfigure spec - record spec res - return res - -doCabalConfigure :: PackageSpec -> IO Result -doCabalConfigure spec = do - cleanResult@(_, _, cleanOutput) <- cabal spec ["clean"] - requireSuccess cleanResult - res <- cabal spec $ ["configure", "--user"] ++ configOpts spec - return $ recordRun res ConfigureSuccess nullResult - -doCabalBuild :: PackageSpec -> IO Result -doCabalBuild spec = do - configResult <- doCabalConfigure spec - if successful configResult - then do - res <- cabal spec ["build"] - return $ recordRun res BuildSuccess configResult - else - return configResult - -cabal_build :: PackageSpec -> IO Result -cabal_build spec = do - res <- doCabalBuild spec - record spec res - return res - -unregister :: String -> IO () -unregister libraryName = do - res@(_, _, output) <- run Nothing "ghc-pkg" ["unregister", "--user", libraryName] - if "cannot find package" `isInfixOf` output - then return () - else requireSuccess res - --- | Install this library in the user area -cabal_install :: PackageSpec -> IO Result -cabal_install spec = do - buildResult <- doCabalBuild spec - res <- if successful buildResult - then do - res <- cabal spec ["install"] - return $ recordRun res InstallSuccess buildResult - else - return buildResult - record spec res - return res - -cabal_test :: PackageSpec -> IO Result -cabal_test spec = do - res <- cabal spec ["test"] - let r = recordRun res TestSuccess nullResult - record spec r - return r - --- | Returns the command that was issued, the return code, and hte output text -cabal :: PackageSpec -> [String] -> IO (String, ExitCode, String) -cabal spec cabalArgs = do - wd <- getCurrentDirectory - r <- run (Just $ directory spec) "ghc" - [ "--make" - , "-fhpc" - , "-package-conf " ++ wd "../dist/package.conf.inplace" - , "Setup.hs" - ] - requireSuccess r - run (Just $ directory spec) (wd directory spec "Setup") cabalArgs - --- | Returns the command that was issued, the return code, and hte output text -run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String) -run cwd cmd args = do - -- Posix-specific - (outf, outf0) <- createPipe - (errf, errf0) <- createPipe - outh <- fdToHandle outf - outh0 <- fdToHandle outf0 - errh <- fdToHandle errf - errh0 <- fdToHandle errf0 - pid <- runProcess cmd args cwd Nothing Nothing (Just outh0) (Just errh0) - - {- - -- ghc-6.10.1 specific - (Just inh, Just outh, Just errh, pid) <- - createProcess (proc cmd args){ std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe, - cwd = cwd } - hClose inh -- done with stdin - -} - - -- fork off a thread to start consuming the output - outChan <- newChan - forkIO $ suckH outChan outh - forkIO $ suckH outChan errh - - output <- suckChan outChan - - hClose outh - hClose errh - - -- wait on the process - ex <- waitForProcess pid - let fullCmd = intercalate " " $ cmd:args - return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, - ex, output) - where - suckH chan h = do - eof <- hIsEOF h - if eof - then writeChan chan Nothing - else do - c <- hGetChar h - writeChan chan $ Just c - suckH chan h - suckChan chan = sc' chan 2 [] - where - sc' _ 0 acc = return $ reverse acc - sc' chan eofs acc = do - mC <- readChan chan - case mC of - Just c -> sc' chan eofs (c:acc) - Nothing -> sc' chan (eofs-1) acc - -requireSuccess :: (String, ExitCode, String) -> IO () -requireSuccess (cmd, exitCode, output) = do - case exitCode of - ExitSuccess -> return () - ExitFailure r -> do - ioError $ userError $ "Command " ++ cmd ++ " failed." - -record :: PackageSpec -> Result -> IO () -record spec res = do - C.writeFile (directory spec "test-log.txt") (C.pack $ outputText res) - diff --git a/cabal/cabal/tests/PackageTests/TestStanza/Check.hs b/cabal/cabal/tests/PackageTests/TestStanza/Check.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/TestStanza/Check.hs +++ /dev/null @@ -1,57 +0,0 @@ -module PackageTests.TestStanza.Check where - -import Test.HUnit -import System.FilePath -import PackageTests.PackageTester -import Data.List (isInfixOf, intercalate) -import Distribution.Version -import Distribution.PackageDescription.Parse - ( readPackageDescription ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) -import Distribution.Package - ( PackageIdentifier(..), PackageName(..), Dependency(..) ) -import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), TestSuite(..), Library(..) - , TestSuiteInterface(..) - , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary - , emptyTestSuite, BuildType(..) ) -import Distribution.Verbosity (silent) -import Distribution.License (License(..)) -import Distribution.ModuleName (fromString) -import Distribution.System (buildPlatform) -import Distribution.Compiler - ( CompilerId(..), CompilerFlavor(..) ) -import Distribution.Text - -suite :: Version -> Test -suite cabalVersion = TestCase $ do - let directory = "PackageTests" "TestStanza" - pdFile = directory "my" <.> "cabal" - spec = PackageSpec directory [] - result <- cabal_configure spec - let message = "cabal configure should recognize test section" - test = "unknown section type" - `isInfixOf` - (intercalate " " $ lines $ outputText result) - assertEqual message False test - genPD <- readPackageDescription silent pdFile - let compiler = CompilerId GHC $ Version [6, 12, 2] [] - anyV = intersectVersionRanges anyVersion anyVersion - anticipatedTestSuite = emptyTestSuite - { testName = "dummy" - , testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs" - , testBuildInfo = emptyBuildInfo - { targetBuildDepends = - [ Dependency (PackageName "base") anyVersion ] - , hsSourceDirs = ["."] - } - , testEnabled = False - } - case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of - Left xs -> let depMessage = "should not have missing dependencies:\n" ++ - (unlines $ map (show . disp) xs) - in assertEqual depMessage True False - Right (f, _) -> let gotTest = head $ testSuites f - in assertEqual "parsed test-suite stanza does not match anticipated" - gotTest anticipatedTestSuite diff --git a/cabal/cabal/tests/PackageTests/TestStanza/Setup.hs b/cabal/cabal/tests/PackageTests/TestStanza/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/TestStanza/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/TestStanza/my.cabal b/cabal/cabal/tests/PackageTests/TestStanza/my.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/TestStanza/my.cabal +++ /dev/null @@ -1,19 +0,0 @@ -name: TestStanza -version: 0.1 -license: BSD3 -author: Thomas Tuegel -stability: stable -category: PackageTests -build-type: Simple - -description: - Check that Cabal recognizes the Test stanza defined below. - -Library - exposed-modules: MyLibrary - build-depends: base - -test-suite dummy - main-is: dummy.hs - type: exitcode-stdio-1.0 - build-depends: base diff --git a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs b/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs +++ /dev/null @@ -1,47 +0,0 @@ -module PackageTests.TestSuiteExeV10.Check - ( checkTest - , checkTestWithHpc - ) where - -import Distribution.PackageDescription ( TestSuite(..), emptyTestSuite ) -import Distribution.Simple.Hpc -import Distribution.Version -import Test.HUnit -import System.Directory -import System.FilePath -import PackageTests.PackageTester - -dir :: FilePath -dir = "PackageTests" "TestSuiteExeV10" - -checkTest :: Version -> Test -checkTest cabalVersion = TestCase $ do - let spec = PackageSpec dir ["--enable-tests"] - buildResult <- cabal_build spec - let buildMessage = "\'setup build\' should succeed" - assertEqual buildMessage True $ successful buildResult - testResult <- cabal_test spec - let testMessage = "\'setup test\' should succeed" - assertEqual testMessage True $ successful testResult - -checkTestWithHpc :: Version -> Test -checkTestWithHpc cabalVersion = TestCase $ do - let spec = PackageSpec dir [ "--enable-tests" - , "--enable-library-coverage" - ] - buildResult <- cabal_build spec - let buildMessage = "\'setup build\' should succeed" - assertEqual buildMessage True $ successful buildResult - testResult <- cabal_test spec - let testMessage = "\'setup test\' should succeed" - assertEqual testMessage True $ successful testResult - let dummy = emptyTestSuite { testName = "test-Foo" } - tixFile = tixFilePath (dir "dist") dummy - tixFileMessage = ".tix file should exist" - markupDir = tixDir (dir "dist") dummy - markupFile = markupDir "hpc_index" <.> "html" - markupFileMessage = "HPC markup file should exist" - tixFileExists <- doesFileExist tixFile - assertEqual tixFileMessage True tixFileExists - markupFileExists <- doesFileExist markupFile - assertEqual markupFileMessage True markupFileExists diff --git a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs b/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Foo where - -fooTest :: [String] -> Bool -fooTest _ = True diff --git a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs b/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal b/cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal +++ /dev/null @@ -1,15 +0,0 @@ -name: my -version: 0.1 -license: BSD3 -cabal-version: >= 1.9.2 -build-type: Simple - -library - exposed-modules: Foo - build-depends: base - -test-suite test-Foo - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: test-Foo.hs - build-depends: base, my diff --git a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs b/cabal/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs deleted file mode 100644 --- a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Main where - -import Foo -import System.Exit - -main :: IO () -main | fooTest [] = exitSuccess - | otherwise = exitFailure diff --git a/cabal/cabal/tests/README b/cabal/cabal/tests/README deleted file mode 100644 --- a/cabal/cabal/tests/README +++ /dev/null @@ -1,14 +0,0 @@ -Building and running the test suite -=================================== - -You can build and run the test suite by running: - - cabal configure && cabal build - cd tests - cabal configure --package-db=../dist/package.conf.inplace \ - --constraint='Cabal == 1.9.1' - cabal build - ./dist/build/suite/suite - -Replace the Cabal constraint with whatever the current development -version of Cabal. diff --git a/cabal/cabal/tests/Setup.hs b/cabal/cabal/tests/Setup.hs deleted file mode 100644 --- a/cabal/cabal/tests/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/cabal/cabal/tests/Test/Distribution/Version.hs b/cabal/cabal/tests/Test/Distribution/Version.hs deleted file mode 100644 --- a/cabal/cabal/tests/Test/Distribution/Version.hs +++ /dev/null @@ -1,644 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-} -module Test.Distribution.Version (properties) where - -import Distribution.Version -import Distribution.Text - -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<>), (<+>)) - -import Test.QuickCheck -import Test.QuickCheck.Utils -import qualified Test.Laws as Laws - -import Control.Monad (liftM, liftM2) -import Data.Maybe (isJust, fromJust) -import Data.List (sort, sortBy, nub) -import Data.Ord (comparing) - -properties :: [Property] -properties = - -- properties to validate the test framework - [ property prop_nonNull - , property prop_gen_intervals1 - , property prop_gen_intervals2 - , property prop_equivalentVersionRange - , property prop_intermediateVersion - - -- the basic syntactic version range functions - , property prop_anyVersion - , property prop_noVersion - , property prop_thisVersion - , property prop_notThisVersion - , property prop_laterVersion - , property prop_orLaterVersion - , property prop_earlierVersion - , property prop_orEarlierVersion - , property prop_unionVersionRanges - , property prop_intersectVersionRanges - , property prop_withinVersion - , property prop_foldVersionRange - , property prop_foldVersionRange' - - -- the semantic query functions - , property prop_isAnyVersion1 - , property prop_isAnyVersion2 - , property prop_isNoVersion - , property prop_isSpecificVersion1 - , property prop_isSpecificVersion2 - , property prop_simplifyVersionRange1 - , property prop_simplifyVersionRange1' - , property prop_simplifyVersionRange2 - , property prop_simplifyVersionRange2' - , property prop_simplifyVersionRange2'' --FIXME - - -- converting between version ranges and version intervals - , property prop_to_intervals - , property prop_to_intervals_canonical - , property prop_to_intervals_canonical' - , property prop_from_intervals - , property prop_to_from_intervals - , property prop_from_to_intervals - , property prop_from_to_intervals' - - -- union and intersection of version intervals - , property prop_unionVersionIntervals - , property prop_unionVersionIntervals_idempotent - , property prop_unionVersionIntervals_commutative - , property prop_unionVersionIntervals_associative - , property prop_intersectVersionIntervals - , property prop_intersectVersionIntervals_idempotent - , property prop_intersectVersionIntervals_commutative - , property prop_intersectVersionIntervals_associative - , property prop_union_intersect_distributive - , property prop_intersect_union_distributive - - -- parsing an pretty printing - , property prop_parse_disp1 - , property prop_parse_disp2 - , property prop_parse_disp3 - ] - -instance Arbitrary Version where - arbitrary = do - branch <- smallListOf1 $ - frequency [(3, return 0) - ,(3, return 1) - ,(2, return 2) - ,(1, return 3)] - return (Version branch []) -- deliberate [] - where - smallListOf1 = adjustSize (\n -> min 5 (n `div` 3)) . listOf1 - - shrink (Version branch []) = - [ Version branch' [] | branch' <- shrink branch, not (null branch') ] - shrink (Version branch _tags) = - [ Version branch [] ] - -instance Arbitrary VersionRange where - arbitrary = sized verRangeExp - where - verRangeExp n = frequency $ - [ (2, return anyVersion) - , (1, liftM thisVersion arbitrary) - , (1, liftM laterVersion arbitrary) - , (1, liftM orLaterVersion arbitrary) - , (1, liftM orLaterVersion' arbitrary) - , (1, liftM earlierVersion arbitrary) - , (1, liftM orEarlierVersion arbitrary) - , (1, liftM orEarlierVersion' arbitrary) - , (1, liftM withinVersion arbitrary) - , (2, liftM VersionRangeParens arbitrary) - ] ++ if n == 0 then [] else - [ (2, liftM2 unionVersionRanges verRangeExp2 verRangeExp2) - , (2, liftM2 intersectVersionRanges verRangeExp2 verRangeExp2) - ] - where - verRangeExp2 = verRangeExp (n `div` 2) - - orLaterVersion' v = - UnionVersionRanges (LaterVersion v) (ThisVersion v) - orEarlierVersion' v = - UnionVersionRanges (EarlierVersion v) (ThisVersion v) - ---------------------------- --- VersionRange properties --- - -prop_nonNull :: Version -> Bool -prop_nonNull = not . null . versionBranch - -prop_anyVersion :: Version -> Bool -prop_anyVersion v' = - withinRange v' anyVersion == True - -prop_noVersion :: Version -> Bool -prop_noVersion v' = - withinRange v' noVersion == False - -prop_thisVersion :: Version -> Version -> Bool -prop_thisVersion v v' = - withinRange v' (thisVersion v) - == (v' == v) - -prop_notThisVersion :: Version -> Version -> Bool -prop_notThisVersion v v' = - withinRange v' (notThisVersion v) - == (v' /= v) - -prop_laterVersion :: Version -> Version -> Bool -prop_laterVersion v v' = - withinRange v' (laterVersion v) - == (v' > v) - -prop_orLaterVersion :: Version -> Version -> Bool -prop_orLaterVersion v v' = - withinRange v' (orLaterVersion v) - == (v' >= v) - -prop_earlierVersion :: Version -> Version -> Bool -prop_earlierVersion v v' = - withinRange v' (earlierVersion v) - == (v' < v) - -prop_orEarlierVersion :: Version -> Version -> Bool -prop_orEarlierVersion v v' = - withinRange v' (orEarlierVersion v) - == (v' <= v) - -prop_unionVersionRanges :: VersionRange -> VersionRange -> Version -> Bool -prop_unionVersionRanges vr1 vr2 v' = - withinRange v' (unionVersionRanges vr1 vr2) - == (withinRange v' vr1 || withinRange v' vr2) - -prop_intersectVersionRanges :: VersionRange -> VersionRange -> Version -> Bool -prop_intersectVersionRanges vr1 vr2 v' = - withinRange v' (intersectVersionRanges vr1 vr2) - == (withinRange v' vr1 && withinRange v' vr2) - -prop_withinVersion :: Version -> Version -> Bool -prop_withinVersion v v' = - withinRange v' (withinVersion v) - == (v' >= v && v' < upper v) - where - upper (Version lower t) = Version (init lower ++ [last lower + 1]) t - -prop_foldVersionRange :: VersionRange -> Bool -prop_foldVersionRange range = - expandWildcard range - == foldVersionRange anyVersion thisVersion - laterVersion earlierVersion - unionVersionRanges intersectVersionRanges - range - where - expandWildcard (WildcardVersion v) = - intersectVersionRanges (orLaterVersion v) (earlierVersion (upper v)) - where - upper (Version lower t) = Version (init lower ++ [last lower + 1]) t - - expandWildcard (UnionVersionRanges v1 v2) = - UnionVersionRanges (expandWildcard v1) (expandWildcard v2) - expandWildcard (IntersectVersionRanges v1 v2) = - IntersectVersionRanges (expandWildcard v1) (expandWildcard v2) - expandWildcard (VersionRangeParens v) = expandWildcard v - expandWildcard v = v - - -prop_foldVersionRange' :: VersionRange -> Bool -prop_foldVersionRange' range = - canonicalise range - == foldVersionRange' anyVersion thisVersion - laterVersion earlierVersion - orLaterVersion orEarlierVersion - (\v _ -> withinVersion v) - unionVersionRanges intersectVersionRanges id - range - where - canonicalise (UnionVersionRanges (LaterVersion v) - (ThisVersion v')) | v == v' - = UnionVersionRanges (ThisVersion v') - (LaterVersion v) - canonicalise (UnionVersionRanges (EarlierVersion v) - (ThisVersion v')) | v == v' - = UnionVersionRanges (ThisVersion v') - (EarlierVersion v) - canonicalise (UnionVersionRanges v1 v2) = - UnionVersionRanges (canonicalise v1) (canonicalise v2) - canonicalise (IntersectVersionRanges v1 v2) = - IntersectVersionRanges (canonicalise v1) (canonicalise v2) - canonicalise (VersionRangeParens v) = canonicalise v - canonicalise v = v - - -prop_isAnyVersion1 :: VersionRange -> Version -> Property -prop_isAnyVersion1 range version = - isAnyVersion range ==> withinRange version range - -prop_isAnyVersion2 :: VersionRange -> Property -prop_isAnyVersion2 range = - isAnyVersion range ==> - foldVersionRange True (\_ -> False) (\_ -> False) (\_ -> False) - (\_ _ -> False) (\_ _ -> False) - (simplifyVersionRange range) - -prop_isNoVersion :: VersionRange -> Version -> Property -prop_isNoVersion range version = - isNoVersion range ==> not (withinRange version range) - -prop_isSpecificVersion1 :: VersionRange -> NonEmptyList Version -> Property -prop_isSpecificVersion1 range (NonEmpty versions) = - isJust version && not (null versions') ==> - allEqual (fromJust version : versions') - where - version = isSpecificVersion range - versions' = filter (`withinRange` range) versions - allEqual xs = and (zipWith (==) xs (tail xs)) - -prop_isSpecificVersion2 :: VersionRange -> Property -prop_isSpecificVersion2 range = - isJust version ==> - foldVersionRange Nothing Just (\_ -> Nothing) (\_ -> Nothing) - (\_ _ -> Nothing) (\_ _ -> Nothing) - (simplifyVersionRange range) - == version - - where - version = isSpecificVersion range - --- | 'simplifyVersionRange' is a semantic identity on 'VersionRange'. --- -prop_simplifyVersionRange1 :: VersionRange -> Version -> Bool -prop_simplifyVersionRange1 range version = - withinRange version range == withinRange version (simplifyVersionRange range) - -prop_simplifyVersionRange1' :: VersionRange -> Bool -prop_simplifyVersionRange1' range = - range `equivalentVersionRange` (simplifyVersionRange range) - --- | 'simplifyVersionRange' produces a canonical form for ranges with --- equivalent semantics. --- -prop_simplifyVersionRange2 :: VersionRange -> VersionRange -> Version -> Property -prop_simplifyVersionRange2 r r' v = - r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==> - withinRange v r == withinRange v r' - -prop_simplifyVersionRange2' :: VersionRange -> VersionRange -> Property -prop_simplifyVersionRange2' r r' = - r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==> - r `equivalentVersionRange` r' - ---FIXME: see equivalentVersionRange for details -prop_simplifyVersionRange2'' :: VersionRange -> VersionRange -> Property -prop_simplifyVersionRange2'' r r' = - r /= r' && r `equivalentVersionRange` r' ==> - simplifyVersionRange r == simplifyVersionRange r' - || isNoVersion r - || isNoVersion r' - --------------------- --- VersionIntervals --- - --- | Generating VersionIntervals --- --- This is a tad tricky as VersionIntervals is an abstract type, so we first --- make a local type for generating the internal representation. Then we check --- that this lets us construct valid 'VersionIntervals'. --- -newtype VersionIntervals' = VersionIntervals' [VersionInterval] - deriving (Eq, Show) - -instance Arbitrary VersionIntervals' where - arbitrary = do - ubound <- arbitrary - bounds <- arbitrary - let intervals = mergeTouching - . map fixEmpty - . replaceUpper ubound - . pairs - . sortBy (comparing fst) - $ bounds - return (VersionIntervals' intervals) - - where - pairs ((l, lb):(u, ub):bs) = (LowerBound l lb, UpperBound u ub) - : pairs bs - pairs _ = [] - - replaceUpper NoUpperBound [(l,_)] = [(l, NoUpperBound)] - replaceUpper NoUpperBound (i:is) = i : replaceUpper NoUpperBound is - replaceUpper _ is = is - - -- merge adjacent intervals that touch - mergeTouching (i1@(l,u):i2@(l',u'):is) - | doesNotTouch u l' = i1 : mergeTouching (i2:is) - | otherwise = mergeTouching ((l,u'):is) - mergeTouching is = is - - doesNotTouch :: UpperBound -> LowerBound -> Bool - doesNotTouch NoUpperBound _ = False - doesNotTouch (UpperBound u ub) (LowerBound l lb) = - u < l - || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) - - fixEmpty (LowerBound l _, UpperBound u _) - | l == u = (LowerBound l InclusiveBound, UpperBound u InclusiveBound) - fixEmpty i = i - - shrink (VersionIntervals' intervals) = - [ VersionIntervals' intervals' | intervals' <- shrink intervals ] - -instance Arbitrary Bound where - arbitrary = elements [ExclusiveBound, InclusiveBound] - -instance Arbitrary LowerBound where - arbitrary = liftM2 LowerBound arbitrary arbitrary - -instance Arbitrary UpperBound where - arbitrary = oneof [return NoUpperBound - ,liftM2 UpperBound arbitrary arbitrary] - --- | Check that our VersionIntervals' arbitrary instance generates intervals --- that satisfies the invariant. --- -prop_gen_intervals1 :: VersionIntervals' -> Bool -prop_gen_intervals1 (VersionIntervals' intervals) = - isJust (mkVersionIntervals intervals) - -instance Arbitrary VersionIntervals where - arbitrary = do - VersionIntervals' intervals <- arbitrary - case mkVersionIntervals intervals of - Just xs -> return xs - --- | Check that constructing our intervals type and converting it to a --- 'VersionRange' and then into the true intervals type gives us back --- the exact same sequence of intervals. This tells us that our arbitrary --- instance for 'VersionIntervals'' is ok. --- -prop_gen_intervals2 :: VersionIntervals' -> Bool -prop_gen_intervals2 (VersionIntervals' intervals') = - asVersionIntervals (fromVersionIntervals intervals) == intervals' - where - Just intervals = mkVersionIntervals intervals' - --- | Check that 'VersionIntervals' models 'VersionRange' via --- 'toVersionIntervals'. --- -prop_to_intervals :: VersionRange -> Version -> Bool -prop_to_intervals range version = - withinRange version range == withinIntervals version intervals - where - intervals = toVersionIntervals range - --- | Check that semantic equality on 'VersionRange's is the same as converting --- to 'VersionIntervals' and doing syntactic equality. --- -prop_to_intervals_canonical :: VersionRange -> VersionRange -> Property -prop_to_intervals_canonical r r' = - r /= r' && r `equivalentVersionRange` r' ==> - toVersionIntervals r == toVersionIntervals r' - -prop_to_intervals_canonical' :: VersionRange -> VersionRange -> Property -prop_to_intervals_canonical' r r' = - r /= r' && toVersionIntervals r == toVersionIntervals r' ==> - r `equivalentVersionRange` r' - --- | Check that 'VersionIntervals' models 'VersionRange' via --- 'fromVersionIntervals'. --- -prop_from_intervals :: VersionIntervals -> Version -> Bool -prop_from_intervals intervals version = - withinRange version range == withinIntervals version intervals - where - range = fromVersionIntervals intervals - --- | @'toVersionIntervals' . 'fromVersionIntervals'@ is an exact identity on --- 'VersionIntervals'. --- -prop_to_from_intervals :: VersionIntervals -> Bool -prop_to_from_intervals intervals = - toVersionIntervals (fromVersionIntervals intervals) == intervals - --- | @'fromVersionIntervals' . 'toVersionIntervals'@ is a semantic identity on --- 'VersionRange', though not necessarily a syntactic identity. --- -prop_from_to_intervals :: VersionRange -> Bool -prop_from_to_intervals range = - range' `equivalentVersionRange` range - where - range' = fromVersionIntervals (toVersionIntervals range) - --- | Equivalent of 'prop_from_to_intervals' --- -prop_from_to_intervals' :: VersionRange -> Version -> Bool -prop_from_to_intervals' range version = - withinRange version range' == withinRange version range - where - range' = fromVersionIntervals (toVersionIntervals range) - --- | The semantics of 'unionVersionIntervals' is (||). --- -prop_unionVersionIntervals :: VersionIntervals -> VersionIntervals - -> Version -> Bool -prop_unionVersionIntervals is1 is2 v = - withinIntervals v (unionVersionIntervals is1 is2) - == (withinIntervals v is1 || withinIntervals v is2) - --- | 'unionVersionIntervals' is idempotent --- -prop_unionVersionIntervals_idempotent :: VersionIntervals -> Bool -prop_unionVersionIntervals_idempotent = - Laws.idempotent_binary unionVersionIntervals - --- | 'unionVersionIntervals' is commutative --- -prop_unionVersionIntervals_commutative :: VersionIntervals - -> VersionIntervals -> Bool -prop_unionVersionIntervals_commutative = - Laws.commutative unionVersionIntervals - --- | 'unionVersionIntervals' is associative --- -prop_unionVersionIntervals_associative :: VersionIntervals - -> VersionIntervals - -> VersionIntervals -> Bool -prop_unionVersionIntervals_associative = - Laws.associative unionVersionIntervals - --- | The semantics of 'intersectVersionIntervals' is (&&). --- -prop_intersectVersionIntervals :: VersionIntervals -> VersionIntervals - -> Version -> Bool -prop_intersectVersionIntervals is1 is2 v = - withinIntervals v (intersectVersionIntervals is1 is2) - == (withinIntervals v is1 && withinIntervals v is2) - --- | 'intersectVersionIntervals' is idempotent --- -prop_intersectVersionIntervals_idempotent :: VersionIntervals -> Bool -prop_intersectVersionIntervals_idempotent = - Laws.idempotent_binary intersectVersionIntervals - --- | 'intersectVersionIntervals' is commutative --- -prop_intersectVersionIntervals_commutative :: VersionIntervals - -> VersionIntervals -> Bool -prop_intersectVersionIntervals_commutative = - Laws.commutative intersectVersionIntervals - --- | 'intersectVersionIntervals' is associative --- -prop_intersectVersionIntervals_associative :: VersionIntervals - -> VersionIntervals - -> VersionIntervals -> Bool -prop_intersectVersionIntervals_associative = - Laws.associative intersectVersionIntervals - --- | 'unionVersionIntervals' distributes over 'intersectVersionIntervals' --- -prop_union_intersect_distributive :: Property -prop_union_intersect_distributive = - Laws.distributive_left unionVersionIntervals intersectVersionIntervals - .&. Laws.distributive_right unionVersionIntervals intersectVersionIntervals - --- | 'intersectVersionIntervals' distributes over 'unionVersionIntervals' --- -prop_intersect_union_distributive :: Property -prop_intersect_union_distributive = - Laws.distributive_left intersectVersionIntervals unionVersionIntervals - .&. Laws.distributive_right intersectVersionIntervals unionVersionIntervals - --------------------------------- --- equivalentVersionRange helper - -prop_equivalentVersionRange :: VersionRange -> VersionRange - -> Version -> Property -prop_equivalentVersionRange range range' version = - equivalentVersionRange range range' && range /= range' ==> - withinRange version range == withinRange version range' - ---FIXME: this is wrong. consider version ranges "<=1" and "<1.0" --- this algorithm cannot distinguish them because there is no version --- that is included by one that is excluded by the other. --- Alternatively we must reconsider the semantics of '<' and '<=' --- in version ranges / version intervals. Perhaps the canonical --- representation should use just < v and interpret "<= v" as "< v.0". -equivalentVersionRange :: VersionRange -> VersionRange -> Bool -equivalentVersionRange vr1 vr2 = - let allVersionsUsed = nub (sort (versionsUsed vr1 ++ versionsUsed vr2)) - minPoint = Version [0] [] - maxPoint | null allVersionsUsed = minPoint - | otherwise = case maximum allVersionsUsed of - Version vs _ -> Version (vs ++ [1]) [] - probeVersions = minPoint : maxPoint - : intermediateVersions allVersionsUsed - - in all (\v -> withinRange v vr1 == withinRange v vr2) probeVersions - - where - versionsUsed = foldVersionRange [] (\x->[x]) (\x->[x]) (\x->[x]) (++) (++) - intermediateVersions (v1:v2:vs) = v1 : intermediateVersion v1 v2 - : intermediateVersions (v2:vs) - intermediateVersions vs = vs - -intermediateVersion :: Version -> Version -> Version -intermediateVersion v1 v2 | v1 >= v2 = error "intermediateVersion: v1 >= v2" -intermediateVersion (Version v1 _) (Version v2 _) = - Version (intermediateList v1 v2) [] - where - intermediateList :: [Int] -> [Int] -> [Int] - intermediateList [] (_:_) = [0] - intermediateList (x:xs) (y:ys) - | x < y = x : xs ++ [0] - | otherwise = x : intermediateList xs ys - -prop_intermediateVersion :: Version -> Version -> Property -prop_intermediateVersion v1 v2 = - (v1 /= v2) && not (adjacentVersions v1 v2) ==> - if v1 < v2 - then let v = intermediateVersion v1 v2 - in (v1 < v && v < v2) - else let v = intermediateVersion v2 v1 - in v1 > v && v > v2 - -adjacentVersions :: Version -> Version -> Bool -adjacentVersions (Version v1 _) (Version v2 _) = v1 ++ [0] == v2 - || v2 ++ [0] == v1 - --------------------------------- --- Parsing and pretty printing --- - -prop_parse_disp1 :: VersionRange -> Bool -prop_parse_disp1 vr = - fmap stripParens (simpleParse (display vr)) == Just (canonicalise vr) - - where - canonicalise = swizzle . swap - - swizzle (UnionVersionRanges (UnionVersionRanges v1 v2) v3) - | not (isOrLaterVersion v1 v2) && not (isOrEarlierVersion v1 v2) - = swizzle (UnionVersionRanges v1 (UnionVersionRanges v2 v3)) - - swizzle (IntersectVersionRanges (IntersectVersionRanges v1 v2) v3) - = swizzle (IntersectVersionRanges v1 (IntersectVersionRanges v2 v3)) - - swizzle (UnionVersionRanges v1 v2) = - UnionVersionRanges (swizzle v1) (swizzle v2) - swizzle (IntersectVersionRanges v1 v2) = - IntersectVersionRanges (swizzle v1) (swizzle v2) - swizzle (VersionRangeParens v) = swizzle v - swizzle v = v - - isOrLaterVersion (ThisVersion v) (LaterVersion v') = v == v' - isOrLaterVersion _ _ = False - - isOrEarlierVersion (ThisVersion v) (EarlierVersion v') = v == v' - isOrEarlierVersion _ _ = False - - swap = - foldVersionRange' anyVersion thisVersion - laterVersion earlierVersion - orLaterVersion orEarlierVersion - (\v _ -> withinVersion v) - unionVersionRanges intersectVersionRanges id - - stripParens :: VersionRange -> VersionRange - stripParens (VersionRangeParens v) = stripParens v - stripParens (UnionVersionRanges v1 v2) = - UnionVersionRanges (stripParens v1) (stripParens v2) - stripParens (IntersectVersionRanges v1 v2) = - IntersectVersionRanges (stripParens v1) (stripParens v2) - stripParens v = v - -prop_parse_disp2 :: VersionRange -> Bool -prop_parse_disp2 vr = - fmap (display :: VersionRange -> String) (simpleParse (display vr)) - == Just (display vr) - -prop_parse_disp3 :: VersionRange -> Bool -prop_parse_disp3 vr = - fmap displayRaw (simpleParse (display vr)) == Just (display vr) - -displayRaw :: VersionRange -> String -displayRaw = - Disp.render - . foldVersionRange' -- precedence: - -- All the same as the usual pretty printer, except for the parens - ( Disp.text "-any") - (\v -> Disp.text "==" <> disp v) - (\v -> Disp.char '>' <> disp v) - (\v -> Disp.char '<' <> disp v) - (\v -> Disp.text ">=" <> disp v) - (\v -> Disp.text "<=" <> disp v) - (\v _ -> Disp.text "==" <> dispWild v) - (\r1 r2 -> r1 <+> Disp.text "||" <+> r2) - (\r1 r2 -> r1 <+> Disp.text "&&" <+> r2) - (\r -> Disp.parens r) -- parens - - where - dispWild (Version b _) = - Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) - <> Disp.text ".*" diff --git a/cabal/cabal/tests/Test/Laws.hs b/cabal/cabal/tests/Test/Laws.hs deleted file mode 100644 --- a/cabal/cabal/tests/Test/Laws.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Test.Laws where - -import Prelude hiding (Num((+), (*))) -import Data.Monoid (Monoid(..), Endo(..)) -import qualified Data.Foldable as Foldable - -idempotent_unary f x = f fx == fx where fx = f x - --- Basic laws on binary operators - -idempotent_binary (+) x = x + x == x - -commutative (+) x y = x + y == y + x - -associative (+) x y z = (x + y) + z == x + (y + z) - -distributive_left (*) (+) x y z = x * (y + z) == (x * y) + (x * z) - -distributive_right (*) (+) x y z = (y + z) * x == (y * x) + (z * x) - - --- | The first 'fmap' law --- --- > fmap id == id --- -fmap_1 :: (Eq (f a), Functor f) => f a -> Bool -fmap_1 x = fmap id x == x - --- | The second 'fmap' law --- --- > fmap (f . g) == fmap f . fmap g --- -fmap_2 :: (Eq (f c), Functor f) => (b -> c) -> (a -> b) -> f a -> Bool -fmap_2 f g x = fmap (f . g) x == (fmap f . fmap g) x - - --- | The monoid identity law, 'mempty' is a left and right identity of --- 'mappend': --- --- > mempty `mappend` x = x --- > x `mappend` mempty = x --- -monoid_1 :: (Eq a, Data.Monoid.Monoid a) => a -> Bool -monoid_1 x = mempty `mappend` x == x - && x `mappend` mempty == x - --- | The monoid associativity law, 'mappend' must be associative. --- --- > (x `mappend` y) `mappend` z = x `mappend` (y `mappend` z) --- -monoid_2 :: (Eq a, Data.Monoid.Monoid a) => a -> a -> a -> Bool -monoid_2 x y z = (x `mappend` y) `mappend` z - == x `mappend` (y `mappend` z) - --- | The 'mconcat' definition. It can be overidden for the sake of effeciency --- but it must still satisfy the property given by the default definition: --- --- > mconcat = foldr mappend mempty --- -monoid_3 :: (Eq a, Data.Monoid.Monoid a) => [a] -> Bool -monoid_3 xs = mconcat xs == foldr mappend mempty xs - - --- | First 'Foldable' law --- --- > Foldable.fold = Foldable.foldr mappend mempty --- -foldable_1 :: (Foldable.Foldable t, Monoid m, Eq m) => t m -> Bool -foldable_1 x = Foldable.fold x == Foldable.foldr mappend mempty x - --- | Second 'Foldable' law --- --- > foldr f z t = appEndo (foldMap (Endo . f) t) z --- -foldable_2 :: (Foldable.Foldable t, Eq b) - => (a -> b -> b) -> b -> t a -> Bool -foldable_2 f z t = Foldable.foldr f z t - == appEndo (Foldable.foldMap (Endo . f) t) z diff --git a/cabal/cabal/tests/Test/QuickCheck/Utils.hs b/cabal/cabal/tests/Test/QuickCheck/Utils.hs deleted file mode 100644 --- a/cabal/cabal/tests/Test/QuickCheck/Utils.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Test.QuickCheck.Utils where - -import Test.QuickCheck.Gen - - --- | Adjust the size of the generated value. --- --- In general the size gets bigger and bigger linearly. For some types --- it is not appropriate to generate ever bigger values but instead --- to generate lots of intermediate sized values. You could do that using: --- --- > adjustSize (\n -> min n 5) --- --- Similarly, for some types the linear size growth may mean getting too big --- too quickly relative to other values. So you may want to adjust how --- quickly the size grows. For example dividing by a constant, or even --- something like the integer square root or log. --- --- > adjustSize (\n -> n `div` 2) --- --- Putting this together we can make for example a relatively short list: --- --- > adjustSize (\n -> min 5 (n `div` 3)) (listOf1 arbitrary) --- --- Not only do we put a limit on the length but we also scale the growth to --- prevent it from hitting the maximum size quite so early. --- -adjustSize :: (Int -> Int) -> Gen a -> Gen a -adjustSize adjust gen = sized (\n -> resize (adjust n) gen) diff --git a/cabal/cabal/tests/UnitTest.hs b/cabal/cabal/tests/UnitTest.hs deleted file mode 100644 --- a/cabal/cabal/tests/UnitTest.hs +++ /dev/null @@ -1,474 +0,0 @@ ------------------------------------------------------------------------------ - --- | --- Module : UnitTest --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : GHC --- --- Explanation: Test this module and sub modules. - -{- 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 Main where --- Import everything, since we want to test the compilation of them: - -import qualified UnitTest.Distribution.Version as D.V (hunitTests) -import qualified UnitTest.Distribution.PackageDescription as D.PD (hunitTests) - -import Distribution.Simple.Compiler (CompilerFlavor(..), compilerVersion) -import Distribution.Simple.Program (defaultProgramConfiguration) -import Distribution.Version (Version(..)) - -import System.FilePath( () ) - -import Distribution.Simple.Configure (configCompiler) -import Distribution.Verbosity ( silent ) --- base -import Data.List (intersperse) -import Control.Monad (when) -import System.Directory (setCurrentDirectory, doesFileExist, - doesDirectoryExist, getCurrentDirectory, - getPermissions, Permissions(..), - removeDirectoryRecursive) -import System.Cmd (system) -import System.Exit(ExitCode(..)) -import System.Environment (getArgs) - -import Test.HUnit(runTestTT, Test(..), Counts(..), assertBool, - assertEqual, Assertion, showCounts) - - --- ------------------------------------------------------------ --- * Helpers --- ------------------------------------------------------------ - -combineCounts :: Counts -> Counts -> Counts -combineCounts (Counts a b c d) (Counts a' b' c' d') - = Counts (a + a') (b + b') (c + c') (d + d') - -label :: String -> String -label t = "-= " ++ t ++ " =-" - -runTestTT' :: Test -> IO Counts -runTestTT' t@(TestList _) = runTestTT t -runTestTT' (TestLabel l t) - = putStrLn (label l) >> runTestTT t -runTestTT' t = runTestTT t - -checkTargetDir :: FilePath - -> [String] -- ^suffixes - -> IO () -checkTargetDir targetDir suffixes - = do doesDirectoryExist targetDir >>= - assertBool "target dir exists" - let mods = ["A", "B/A"] - allFilesE <- mapM anyExists [[(targetDir ++ t ++ y) - | y <- suffixes] - | t <- mods] - - sequence [assertBool ("target file missing: " ++ targetDir ++ f) e - | (e, f) <- zip allFilesE mods] - return () - - where anyExists :: [FilePath] -> IO Bool - anyExists l = do l' <- mapM doesFileExist l - return $ any (== True) l' - --- |Run this command, and assert it returns a successful error code. -assertCmd :: String -- ^Command - -> String -- ^Comment - -> Assertion -assertCmd command comment - = system command >>= assertEqual (command ++ ":" ++ comment) ExitSuccess - --- |like assertCmd, but separates command and args -assertCmd' :: String -- ^Command - -> String -- ^args - -> String -- ^Comment - -> Assertion -assertCmd' command args comment - = system (command ++ " "++ args ++ ">>out.build") - >>= assertEqual (command ++ ":" ++ comment) ExitSuccess - --- |Run this command, and assert it returns an unsuccessful error code. -assertCmdFail :: String -- ^Command - -> String -- ^Comment - -> Assertion -assertCmdFail command comment - = do code <- system command - assertBool (command ++ ":" ++ comment) (code /= ExitSuccess) - - --- ------------------------------------------------------------ --- * Integration Tests --- ------------------------------------------------------------ - -tests :: FilePath -- ^Currdir - -> CompilerFlavor -- ^build setup with compiler - -> CompilerFlavor -- ^configure with which compiler - -> Version -- ^version of the compiler to use - -> [Test] -tests currDir comp compConf compVersion = [ --- executableWithC - TestLabel ("package exeWithC: " ++ compIdent) $ TestCase $ - do let targetDir = ",tmp" - setCurrentDirectory (testdir "exeWithC") - testPrelude - assertConfigure targetDir - assertClean - assertConfigure targetDir - assertBuild - assertCopy - assertCmd (targetDir "bin/tt" ++ " > " - ++ targetDir "out") - "exeWithC failed" --- A - ,TestLabel ("package A: " ++ compIdent) $ TestCase $ - do let targetDir = ",tmp" - setCurrentDirectory (testdir "A") - testPrelude - assertConfigure targetDir - assertHaddock - assertBuild - when (comp == GHC) -- are these tests silly? - (do doesDirectoryExist "dist/build" >>= - assertBool "dist/build doesn't exist" - doesFileExist "dist/build/testA/testA" >>= - assertBool "build did not create the executable: testA" - doesFileExist "dist/build/testB/testB" >>= - assertBool "build did not create the executable: testB" - doesFileExist "dist/build/testA/testA-tmp/c_src/hello.o" >>= - assertBool "build did not build c source for testA" - doesFileExist "dist/build/hello.o" >>= - assertBool "build did not build c source for A library" - ) - assertCopy - libForA targetDir - doesFileExist ",tmp/bin/testA" >>= - assertBool "testA not produced" - doesFileExist ",tmp/bin/testB" >>= - assertBool "testB not produced" - assertCmd' compCmd "sdist -v0" "setup sdist returned error code" - doesFileExist "dist/test-1.0.tar.gz" >>= - assertBool "sdist did not put the expected file in place" - doesFileExist "dist/src" >>= - assertEqual "dist/src exists" False - assertCmd' compCmd "register -v0 --user" "pkg A, register failed" - assertCmd' compCmd "unregister -v0 --user" "pkg A, unregister failed" - -- tricky, script-based register - registerAndExecute "pkg A: register with script failed" - unregisterAndExecute "pkg A: unregister with script failed" - -- non-trick non-script based register - assertCmd' compCmd "register -v0 --user" "regular register returned error" - assertCmd' compCmd "unregister -v0 --user" "regular unregister returned error" - - ,TestLabel ("package A copy-prefix: " ++ compIdent) $ TestCase $ -- (uses above config) - do let targetDir = ",tmp2" - assertCmd' compCmd ("copy --copy-prefix=" ++ targetDir) "copy --copy-prefix failed" - doesFileExist ",tmp2/bin/testA" >>= - assertBool "testA not produced" - doesFileExist ",tmp2/bin/testB" >>= - assertBool "testB not produced" - libForA ",tmp2" - ,TestLabel ("package A and install w/ no prefix: " ++ compIdent) $ TestCase $ - do let targetDir = ",tmp" - removeDirectoryRecursive targetDir - when (comp == GHC) -- FIX: hugs can't do --user yet - (do assertCmd "make -s unregister-test" "unregister test" - assertCmd' compCmd "install -v0 --user" "install --user failed" - libForA targetDir - assertCmd' compCmd "unregister -v0 --user" "unregister failed") --- HUnit - ,TestLabel ("testing the HUnit package" ++ compIdent) $ TestCase $ - do setCurrentDirectory $ (testdir "HUnit-1.0") - system "make -s clean" - system "make -s" - assertCmd' compCmd "configure -v0" "configure failed" - assertCmd' compCmd "unregister -v0 --user" "unregister failed" - - system $ "touch dist/setup-config" - system $ "touch dist/installed-pkg-config" - doesFileExist "dist/setup-config" >>= - assertBool ("touch dist/setup-config failed") - - -- Test clean: - assertBuild - doesDirectoryExist "dist/build" >>= - assertBool "HUnit build did not create build directory" - assertCmd' compCmd "clean -v0" "hunit clean" - doesDirectoryExist "dist/build" >>= - assertEqual "HUnit clean did not get rid of build directory" False - - doesFileExist "dist/setup-config" >>= - assertEqual ("clean dist/setup-config failed") False - doesFileExist "dist/installed-pkg-config" >>= - assertEqual ("clean dist/installed-pkg-config failed") False - - assertConfigure ",tmp" - assertHaddock - doesDirectoryExist "dist/doc" >>= assertEqual "create of dist/doc" True - assertBuild - when (comp == GHC) -- tests building w/ an installed -package - (do assertCmd' compCmd "install -v0 --user" "hunit install" - assertCmd ("ghc -package HUnitTest HUnitTester.hs -o ./hunitTest") - "compile w/ hunit" - assertCmd "./hunitTest" "hunit test" - assertCmd' compCmd "unregister --user" "unregister failed") - assertClean - doesDirectoryExist "dist/doc" >>= assertEqual "clean dist/doc" False - assertCmd "make -s clean" "make clean failed" - --- twoMains - ,TestLabel ("package twoMains: building " ++ compIdent) $ TestCase $ - do setCurrentDirectory (testdir "twoMains") - testPrelude - assertConfigure ",tmp" - assertCmd' compCmd "haddock" "setup haddock returned error code." - assertBuild - assertCopy - doesFileExist ",tmp/bin/testA" >>= - assertBool "install did not create the executable: testA" - doesFileExist ",tmp/bin/testB" >>= - assertBool "install did not create the executable: testB" - assertCmd "./,tmp/bin/testA isA > out" "A is not A" - assertCmd "./,tmp/bin/testB isB >> out" "B is not B" - -- no register, since there's no library --- buildinfo - ,TestLabel ("buildinfo with multiple executables " ++ compIdent) $ TestCase $ - do setCurrentDirectory (testdir "buildInfo") - testPrelude - assertConfigure ",tmp" - assertHaddock - assertBuild - assertCopy - doesFileExist ",tmp/bin/exe1" >>= - assertBool "install did not create the executable: exe1" - doesFileExist ",tmp/bin/exe2" >>= - assertBool "install did not create the executable: exe2" - -- no register, since there's no library --- mutually recursive modules - ,TestLabel ("package recursive: building " ++ compIdent) $ TestCase $ - when (comp == GHC) (do - setCurrentDirectory (testdir "recursive") - testPrelude - assertConfigure ",tmp" - assertBuild - assertCopy - doesFileExist "dist/build/A.hi-boot" >>= - assertBool "build did not move A.hi-boot file into place lib" - doesFileExist (",tmp/lib/recursive-1.0/ghc-" ++ compVerStr - ++ "/libHSrecursive-1.0.a") >>= - assertBool "recursive build didn't create library" - doesFileExist "dist/build/testExe/testExe-tmp/A.hi" >>= - assertBool "build did not move A.hi-boot file into place exe" - doesFileExist "dist/build/testExe/testExe" >>= - assertBool "recursive build didn't create binary") --- linking in ffi stubs - ,TestLabel ("package ffi: " ++ compIdent) $ TestCase $ - do setCurrentDirectory (testdir "ffi-package") - testPrelude - assertConfigure "/tmp" - assertBuild - -- install it so we can test building with it. - assertCmd' compCmd "install -v0 --user" "ffi-package install" - assertClean - doesFileExist "src/TestFFI_stub.c" >>= - assertEqual "FFI-generated stub not cleaned." False - -- now build something that depends on it - setCurrentDirectory (".." "ffi-bin") - testPrelude - assertConfigure ",tmp" - assertBuild - assertCopy --- depOnLib - ,TestLabel ("package depOnLib: (executable depending on its lib)" ++ compIdent) $ TestCase $ - do setCurrentDirectory (testdir "depOnLib") - testPrelude - assertConfigure ",tmp" - assertHaddock - assertBuild - assertCopy - registerAndExecute "pkg depOnLib: register with script failed" - unregisterAndExecute "pkg DepOnLib: unregister with script failed" - when (comp == GHC) (do - doesFileExist "dist/build/mainForA/mainForA" >>= - assertBool "build did not create the executable: mainForA" - doesFileExist ("dist/build/" "libHStest-1.0.a") - >>= assertBool "library doesn't exist" - doesFileExist (",tmp/bin/mainForA") - >>= assertBool "installed bin doesn't exist" - doesFileExist (",tmp/lib/test-1.0/ghc-" ++ compVerStr ++ "/libHStest-1.0.a") - >>= assertBool "installed lib doesn't exist") --- wash2hs - ,TestLabel ("testing the wash2hs package" ++ compIdent) $ TestCase $ - do setCurrentDirectory (testdir "wash2hs") - testPrelude - assertCmdFail (compCmd ++ " configure -v0 --someUnknownFlag 2> err") - "wash2hs configure with unknown flag" - assertConfigure ",tmp" - assertHaddock - assertBuild - assertCopy - -- no library to register - doesFileExist ",tmp/bin/wash2hs" - >>= assertBool "wash2hs didn't put executable into place." - perms <- getPermissions ",tmp/bin/wash2hs" - assertBool "wash2hs isn't +x" (executable perms) - assertClean - -- no unregister, because it has no libs! --- withHooks - ,TestLabel ("package withHooks: " ++ compIdent) $ TestCase $ - do setCurrentDirectory (testdir "withHooks") - testPrelude - assertCmd' compCmd ("configure -v0 --prefix=,tmp --woohoo " ++ compFlag) - "configure returned error code" - assertCmdFail (compCmd ++ " test -v0 --asdf > out") "test was supposed to fail" - assertCmd' compCmd ("test -v0 --pass >> out") "test should not have failed" - - assertHaddock - assertBuild - assertCmd' compCmd "copy -v0 --copy-prefix=,tmp" "copy w/ prefix" - doesFileExist ",tmp/withHooks" >>= -- this file is added w/ the hook. - assertBool "hooked copy, redirecting prefix didn't work." - assertCmd' compCmd "register -v0 --user" "regular register returned error" - assertCmd' compCmd "unregister -v0 --user" "regular unregister returned error" - when (comp == GHC) -- FIX: come up with good test for Hugs - (do doesFileExist "dist/build/C.o" >>= - assertBool "C.testSuffix did not get compiled to C.o." - doesFileExist "dist/build/D.o" >>= - assertBool "D.gc did not get compiled to D.o this is an overriding test" - doesFileExist (",tmp/lib/withHooks-1.0/ghc-" ++ compVerStr - ++ "/" "libHSwithHooks-1.0.a") - >>= assertBool "library doesn't exist") - - doesFileExist ",tmp/bin/withHooks" >>= - assertBool "copy did not create the executable: withHooks" - assertClean - doesFileExist "C.hs" >>= - assertEqual "C.hs (a generated file) not cleaned." False --- HSQL -{- ,TestLabel ("package HSQL (make-based): " ++ show compIdent) $ - TestCase $ unless (compFlag == "--hugs") $ -- FIX: won't compile w/ hugs - do setCurrentDirectory $ (testdir "HSQL") - system "make distclean" - system "rm -rf /tmp/lib/HSQL" - when (comp == GHC) - (system "ghc -cpp --make -i../.. Setup.lhs -o setup 2>out.build" >> return()) - assertConfigure "/tmp" - doesFileExist "config.mk" >>= - assertBool "config.mk not generated after configure" - assertBuild - assertCopy - when (comp == GHC) -- FIX: do something for hugs - (doesFileExist "/tmp/lib/HSQL/GHC/libHSsql.a" >>= - assertBool "libHSsql.a doesn't exist. copy failed.")-} - ] - where testdir = currDir "systemTests" - compStr = show comp - compVerStr = concat . intersperse "." . map show . versionBranch $ compVersion - compCmd = command comp - compFlag = case compConf of - GHC -> "--ghc" - Hugs -> "--hugs" - _ -> error ("Unhandled compiler: " ++ show compConf) - compIdent = compStr ++ "/" ++ compFlag - testPrelude = system "make clean >> out.build" >> system "make >> out.build" - assertConfigure pref - = assertCmd' compCmd ("configure -v0 --user --prefix=" ++ pref ++ " " ++ compFlag) - "configure returned error code" - -- XXX redirecting stderr is a hack. ar says - -- /usr/bin/ar: creating dist/build/libHStest-1.0.a - -- in the A test - assertBuild = assertCmd' compCmd "build -v0 2> err" "build returned error code" - assertCopy = assertCmd' compCmd "copy -v0" "copy returned error code" - assertClean = assertCmd' compCmd "clean -v0" "clean returned error code" - -- XXX Redirecting stderr is a hack - haddock needs to allow - -- us to tell it to be quiet - assertHaddock = assertCmd' compCmd "haddock -v0 2> err" "setup haddock returned error code." - command GHC = "./setup" - command Hugs = "runhugs -98 Setup.lhs" - command c = error ("Unhandled compiler: " ++ show c) - libForA pref -- checks to see if the lib exists, for tests/A - = let ghcTargetDir = pref ++ "/lib/test-1.0/ghc-" ++ compVerStr ++ "/" in - case compConf of - Hugs -> checkTargetDir (pref ++ "/lib/hugs/packages/test/") [".hs", ".lhs"] - GHC -> do checkTargetDir ghcTargetDir [".hi"] - doesFileExist (ghcTargetDir "libHStest-1.0.a") - >>= assertBool "library doesn't exist" - _ -> error ("Unhandled compiler: " ++ show compConf) - dumpScriptFlag = "--gen-script" - registerAndExecute comment = do - assertCmd' compCmd ("register -v0 --user "++dumpScriptFlag) comment - if comp == GHC - then assertCmd' "./register.sh" "" "reg script failed" - else do ex <- doesFileExist "register.sh" - assertBool "hugs should not produce register.sh" (not ex) - unregisterAndExecute comment = do - assertCmd' compCmd ("unregister -v0 --user "++dumpScriptFlag) comment - if comp == GHC - then assertCmd' "./unregister.sh" "" "reg script failed" - else do ex <- doesFileExist "unregister.sh" - assertBool "hugs should not produce unregister.sh" (not ex) - -main :: IO () -main = do putStrLn "compile successful" - putStrLn "-= Setup Tests =-" - setupCount <- runTestTT' $ TestList (D.V.hunitTests ++ D.PD.hunitTests) - dir <- getCurrentDirectory --- count' <- runTestTT' $ TestList (tests dir Hugs GHC) - args <- getArgs - let testList :: CompilerFlavor -> Version -> [Test] - testList compiler version - | null args = tests dir compiler compiler version - | otherwise = - case reads (head args) of - [(n,_)] -> [ tests dir compiler compiler version !! n ] - _ -> error "usage: moduleTest [test_num]" - compilers = [GHC] --, Hugs] - globalTests <- - flip mapM compilers $ \compilerFlavour -> do - (compiler, _) <- configCompiler (Just compilerFlavour) - Nothing Nothing - defaultProgramConfiguration silent - let version = compilerVersion compiler - runTestTT' $ TestList (testList compilerFlavour version) - putStrLn "-------------" - putStrLn "Test Summary:" - putStrLn $ showCounts $ - foldl1 combineCounts (setupCount:globalTests) - return () - --- Local Variables: --- compile-command: "ghc -i../:/usr/local/src/HUnit-1.0 -Wall --make ModuleTest.hs -o moduleTest" --- End: diff --git a/cabal/cabal/tests/UnitTest/Distribution/PackageDescription.hs b/cabal/cabal/tests/UnitTest/Distribution/PackageDescription.hs deleted file mode 100644 --- a/cabal/cabal/tests/UnitTest/Distribution/PackageDescription.hs +++ /dev/null @@ -1,416 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : PackageDescriptionTests --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Package description and parsing. - -{- 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 UnitTest.Distribution.PackageDescription ( - -- * Debugging - hunitTests, - - ) where - - -import Distribution.ParseUtils -import Distribution.Package (PackageIdentifier(..), Dependency(..)) -import Distribution.Version (Version(..), VersionRange(..)) -import Distribution.Compiler (CompilerFlavor(..), CompilerId(..)) -import Distribution.System (OS(..), buildOS, Arch(..), buildArch) - -import Distribution.PackageDescription -import Distribution.PackageDescription.Configuration -import Distribution.PackageDescription.Parse -import Distribution.PackageDescription.Check -import qualified Distribution.Simple.PackageIndex as PackageIndex - -import Data.Maybe (catMaybes) -import Data.List (sortBy) -import Control.Monad (liftM) -import Test.HUnit (Test(..), assertBool, Assertion, assertEqual) -import Distribution.License -import Language.Haskell.Extension - - --- ------------------------------------------------------------ --- * Testing --- ------------------------------------------------------------ - -compatTestPkgDesc :: String -compatTestPkgDesc = unlines [ - "-- Required", - "Name: Cabal", - "Version: 0.1.1.1.1-rain", - "License: LGPL", - "License-File: foo", - "Copyright: Free Text String", - "Cabal-version: >1.1.1", - "-- Optional - may be in source?", - "Author: Happy Haskell Hacker", - "Homepage: http://www.haskell.org/foo", - "Package-url: http://www.haskell.org/foo", - "Synopsis: a nice package!", - "Description: a really nice package!", - "Category: tools", - "buildable: True", - "CC-OPTIONS: -g -o", - "LD-OPTIONS: -BStatic -dn", - "Frameworks: foo", - "Tested-with: GHC", - "Stability: Free Text String", - "Build-Depends: haskell-src, HUnit>=1.0.0-rain", - "Other-Modules: Distribution.Package, Distribution.Version,", - " Distribution.Simple.GHCPackageConfig", - "Other-files: file1, file2", - "Extra-Tmp-Files: file1, file2", - "C-Sources: not/even/rain.c, such/small/hands", - "HS-Source-Dirs: src, src2", - "Exposed-Modules: Distribution.Void, Foo.Bar", - "Extensions: OverlappingInstances, TypeSynonymInstances", - "Extra-Libraries: libfoo, bar, bang", - "Extra-Lib-Dirs: \"/usr/local/libs\"", - "Include-Dirs: your/slightest, look/will", - "Includes: /easily/unclose, /me, \"funky, path\\\\name\"", - "Install-Includes: /easily/unclose, /me, \"funky, path\\\\name\"", - "GHC-Options: -fTH -fglasgow-exts", - "Hugs-Options: +TH", - "Nhc-Options: ", - "Jhc-Options: ", - "", - "-- Next is an executable", - "Executable: somescript", - "Main-is: SomeFile.hs", - "Other-Modules: Foo1, Util, Main", - "HS-Source-Dir: scripts", - "Extensions: OverlappingInstances", - "GHC-Options: ", - "Hugs-Options: ", - "Nhc-Options: ", - "Jhc-Options: " - ] - -compatTestPkgDescAnswer :: PackageDescription -compatTestPkgDescAnswer = - emptyPackageDescription - { package = PackageIdentifier - { pkgName = "Cabal", - pkgVersion = Version {versionBranch = [0,1,1,1,1], - versionTags = ["rain"]}}, - license = LGPL, - licenseFile = "foo", - copyright = "Free Text String", - author = "Happy Haskell Hacker", - homepage = "http://www.haskell.org/foo", - pkgUrl = "http://www.haskell.org/foo", - synopsis = "a nice package!", - description = "a really nice package!", - category = "tools", - descCabalVersion = LaterVersion (Version [1,1,1] []), - buildType = Just Custom, - buildDepends = [Dependency "haskell-src" AnyVersion, - Dependency "HUnit" - (UnionVersionRanges - (ThisVersion (Version [1,0,0] ["rain"])) - (LaterVersion (Version [1,0,0] ["rain"])))], - testedWith = [(GHC, AnyVersion)], - maintainer = "", - stability = "Free Text String", - extraTmpFiles = ["file1", "file2"], - extraSrcFiles = ["file1", "file2"], - dataFiles = [], - - library = Just $ Library { - exposedModules = ["Distribution.Void", "Foo.Bar"], - libBuildInfo = emptyBuildInfo { - buildable = True, - ccOptions = ["-g", "-o"], - ldOptions = ["-BStatic", "-dn"], - frameworks = ["foo"], - cSources = ["not/even/rain.c", "such/small/hands"], - hsSourceDirs = ["src", "src2"], - otherModules = ["Distribution.Package", - "Distribution.Version", - "Distribution.Simple.GHCPackageConfig"], - extensions = [OverlappingInstances, TypeSynonymInstances], - extraLibs = ["libfoo", "bar", "bang"], - extraLibDirs = ["/usr/local/libs"], - includeDirs = ["your/slightest", "look/will"], - includes = ["/easily/unclose", "/me", "funky, path\\name"], - installIncludes = ["/easily/unclose", "/me", "funky, path\\name"], - ghcProfOptions = [], - options = [(GHC,["-fTH","-fglasgow-exts"]) - ,(Hugs,["+TH"]),(NHC,[]),(JHC,[])] - }}, - - executables = [Executable "somescript" - "SomeFile.hs" (emptyBuildInfo { - otherModules=["Foo1","Util","Main"], - hsSourceDirs = ["scripts"], - extensions = [OverlappingInstances], - options = [(GHC,[]),(Hugs,[]),(NHC,[]),(JHC,[])] - })] - } - --- Parse an old style package description. Assumes no flags etc. being used. -compatParseDescription :: String -> ParseResult PackageDescription -compatParseDescription descr = do - gpd <- parsePackageDescription descr - case finalizePackageDescription [] (Nothing :: Maybe (PackageIndex.PackageIndex PackageIdentifier)) - buildOS buildArch (CompilerId GHC (Version [] [])) [] gpd of - Left _ -> syntaxError (-1) "finalize failed" - Right (pd,_) -> return pd - -hunitTests :: [Test] -hunitTests = - [ TestLabel "license parsers" $ TestCase $ - sequence_ [ assertParseOk ("license " ++ show lVal) lVal - (runP 1 "license" parseLicenseQ (show lVal)) - | lVal <- [GPL,LGPL,BSD3,BSD4] ] - - , TestLabel "Required fields" $ TestCase $ - do assertParseOk "some fields" - emptyPackageDescription { - package = (PackageIdentifier "foo" - (Version [0,0] ["asdf"])) } - (compatParseDescription "Name: foo\nVersion: 0.0-asdf") - - assertParseOk "more fields foo" - emptyPackageDescription { - package = (PackageIdentifier "foo" - (Version [0,0] ["asdf"])), - license = GPL } - (compatParseDescription "Name: foo\nVersion:0.0-asdf\nLicense: GPL") - - assertParseOk "required fields for foo" - emptyPackageDescription { - package = (PackageIdentifier "foo" - (Version [0,0] ["asdf"])), - license = GPL, copyright="2004 isaac jones" } - (compatParseDescription $ "Name: foo\nVersion:0.0-asdf\n" - ++ "Copyright: 2004 isaac jones\nLicense: GPL") - - , TestCase $ assertParseOk "no library" Nothing - (library `liftM` (compatParseDescription $ - "Name: foo\nVersion: 1\nLicense: GPL\n" ++ - "Maintainer: someone\n\nExecutable: script\n" ++ - "Main-is: SomeFile.hs\n")) - - , TestCase $ assertParseOk "translate deprecated fields" - emptyPackageDescription { - extraSrcFiles = ["foo.c", "bar.ml"], - library = Just $ emptyLibrary { - libBuildInfo = emptyBuildInfo { hsSourceDirs = ["foo","bar"] }}} - (compatParseDescription $ - "hs-source-dir: foo bar\nother-files: foo.c bar.ml") - - , TestLabel "Package description" $ TestCase $ - assertParseOk "entire package description" - compatTestPkgDescAnswer - (compatParseDescription compatTestPkgDesc) - , TestLabel "Package description pretty" $ TestCase $ - case compatParseDescription compatTestPkgDesc of - ParseFailed _ -> assertBool "can't parse description" False - ParseOk _ d -> - case compatParseDescription $ showPackageDescription d of - ParseFailed _ -> - assertBool "can't parse description after pretty print!" False - ParseOk _ d' -> - assertBool ("parse . show . parse not identity." - ++" Incorrect fields:\n" - ++ (unlines $ comparePackageDescriptions d d')) - (d == d') - , TestLabel "Sanity checker" $ TestCase $ do - let checks = checkConfiguredPackage emptyPackageDescription - ers = [ s | PackageBuildImpossible s <- checks ] - warns = [ s | PackageBuildWarning s <- checks ] - assertEqual "Wrong number of errors" 2 (length ers) - assertEqual "Wrong number of warnings" 3 (length warns) - ] - --- |Compare two package descriptions and see which fields aren't the same. -comparePackageDescriptions :: PackageDescription - -> PackageDescription - -> [String] -- ^Errors -comparePackageDescriptions p1 p2 - = catMaybes $ myCmp package "package" - : myCmp license "license" - : myCmp licenseFile "licenseFile" - : myCmp copyright "copyright" - : myCmp maintainer "maintainer" - : myCmp author "author" - : myCmp stability "stability" - : myCmp testedWith "testedWith" - : myCmp homepage "homepage" - : myCmp pkgUrl "pkgUrl" - : myCmp synopsis "synopsis" - : myCmp description "description" - : myCmp category "category" - : myCmp buildDepends "buildDepends" - : myCmp library "library" - : myCmp executables "executables" - : myCmp descCabalVersion "cabal-version" - : myCmp buildType "build-type" : [] - where canon_p1 = canonOptions p1 - canon_p2 = canonOptions p2 - - myCmp :: (Eq a, Show a) => (PackageDescription -> a) - -> String -- Error message - -> Maybe String -- - myCmp f er = let e1 = f canon_p1 - e2 = f canon_p2 - in if e1 /= e2 - then Just $ er ++ " Expected: " ++ show e1 - ++ " Got: " ++ show e2 - else Nothing - -canonOptions :: PackageDescription -> PackageDescription -canonOptions pd = - pd{ library = fmap canonLib (library pd), - executables = map canonExe (executables pd) } - where - canonLib l = l { libBuildInfo = canonBI (libBuildInfo l) } - canonExe e = e { buildInfo = canonBI (buildInfo e) } - - canonBI bi = bi { options = canonOptions (options bi) } - - canonOptions opts = sortBy (comparing fst) opts - - comparing f a b = f a `compare` f b - --- |Assert that the 2nd value parses correctly and matches the first value -assertParseOk :: (Eq val) => String -> val -> ParseResult val -> Assertion -assertParseOk mes expected actual - = assertBool mes - (case actual of - ParseOk _ v -> v == expected - _ -> False) - ------------------------------------------------------------------------------- - -test_stanzas' = parsePackageDescription testFile --- ParseOk _ x -> putStrLn $ show x --- _ -> return () - -testFile = unlines $ - [ "Name: dwim" - , "Cabal-version: >= 1.7" - , "" - , "Description: This is a test file " - , " with a description longer than two lines. " - , "" - , "flag Debug {" - , " Description: Enable debug information" - , " Default: False" - , "}" - , "flag build_wibble {" - , "}" - , "" - , "library {" - , " build-depends: blub" - , " exposed-modules: DWIM.Main, DWIM" - , " if os(win32) && flag(debug) {" - , " build-depends: hunit" - , " ghc-options: -DDEBUG" - , " exposed-modules: DWIM.Internal" - , " if !flag(debug) {" - , " build-depends: impossible" - , " }" - , " }" - , "}" - , "" - , "executable foo-bar {" - , " Main-is: Foo.hs" - , " Build-depends: blab" - , "}" - , "executable wobble {" - , " Main-is: Wobble.hs" - , " if flag(debug) {" - , " Build-depends: hunit" - , " }" - , "}" - , "executable wibble {" - , " Main-is: Wibble.hs" - , " hs-source-dirs: wib-stuff" - , " if flag(build_wibble) {" - , " Build-depends: wiblib >= 0.42" - , " } else {" - , " buildable: False" - , " }" - , "}" - ] - -{- -test_compatParsing = - let ParseOk ws (p, pold) = do - fs <- readFields testPkgDesc - ppd <- parsePackageDescription' fs - let Right (pd,_) = finalizePackageDescription [] (Just pkgs) os arch ppd - pdold <- parsePackageDescription testPkgDesc - return (pd, pdold) - in do putStrLn $ unlines $ map show ws - putStrLn "===========" - putStrLn $ showPackageDescription p - putStrLn "===========" - putStrLn $ showPackageDescription testPkgDescAnswer - putStrLn "===========" - putStrLn $ showPackageDescription pold - putStrLn $ show (p == pold) - where - pkgs = [ PackageIdentifier "haskell-src" (Version [1,0] []) - , PackageIdentifier "HUnit" (Version [1,1] ["rain"]) - ] - os = (MkOSName "win32") - arch = (MkArchName "amd64") --} -test_finalizePD = - case parsePackageDescription testFile of - ParseFailed err -> print err - ParseOk _ ppd -> do - case finalizePackageDescription [(FlagName "debug",True)] (Just pkgs) os arch impl [] ppd of - Right (pd,fs) -> do putStrLn $ showPackageDescription pd - print fs - Left missing -> putStrLn $ "missing: " ++ show missing - putStrLn $ showPackageDescription $ - flattenPackageDescription ppd - where - pkgs = PackageIndex.fromList[ PackageIdentifier "blub" (Version [1,0] []) - --, PackageIdentifier "hunit" (Version [1,1] []) - , PackageIdentifier "blab" (Version [0,1] []) - ] - os = Windows - arch = X86_64 - impl = CompilerId GHC (Version [6,6] []) diff --git a/cabal/cabal/tests/UnitTest/Distribution/PackageDescription/Configuration.hs b/cabal/cabal/tests/UnitTest/Distribution/PackageDescription/Configuration.hs deleted file mode 100644 --- a/cabal/cabal/tests/UnitTest/Distribution/PackageDescription/Configuration.hs +++ /dev/null @@ -1,135 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Configuration --- Copyright : Thomas Schilling, 2007 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Configurations - -{- 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 UnitTest.Distribution.PackageDescription.Configuration where - -import Distribution.PackageDescription.Configuration - -import Distribution.Package (Package) -import Distribution.PackageDescription - ( GenericPackageDescription(..), PackageDescription(..) - , Library(..), Executable(..), BuildInfo(..) - , Flag(..), CondTree(..), ConfVar(..), ConfFlag(..), Condition(..) ) -import Distribution.Simple.PackageIndex (PackageIndex) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Version - ( Version(..), Dependency(..), VersionRange(..) - , withinRange, parseVersionRange ) -import Distribution.Compiler (CompilerFlavor, parseCompilerFlavor) -import Distribution.System - ( OS, readOS, Arch, readArch ) -import Distribution.Simple.Utils (currentDir) - -import Distribution.Compat.ReadP as ReadP hiding ( char ) -import qualified Distribution.Compat.ReadP as ReadP ( char ) - -import Data.Char ( isAlphaNum, toLower ) -import Data.Maybe ( catMaybes, maybeToList ) -import Data.List ( nub ) -import Data.Monoid - -import Data.List ( (\\) ) -import Distribution.ParseUtils - ------------------------------------------------------------------------------- --- Testing - -tstTree :: CondTree ConfVar [Int] String -tstTree = CondNode "A" [0] - [ (CNot (Var (Flag (ConfFlag "a"))), - CondNode "B" [1] [], - Nothing) - , (CAnd (Var (Flag (ConfFlag "b"))) (Var (Flag (ConfFlag "c"))), - CondNode "C" [2] [], - Just $ CondNode "D" [3] - [ (Lit True, - CondNode "E" [4] [], - Just $ CondNode "F" [5] []) ]) - ] - - -test_simplify = simplifyWithSysParams i386 darwin ("ghc",Version [6,6] []) tstCond - where - tstCond = COr (CAnd (Var (Arch ppc)) (Var (OS darwin))) - (CAnd (Var (Flag (ConfFlag "debug"))) (Var (OS darwin))) - [ppc,i386] = ["ppc","i386"] - [darwin,windows] = ["darwin","windows"] - - - -test_parseCondition = map (runP 1 "test" parseCondition) testConditions - where - testConditions = [ "os(darwin)" - , "arch(i386)" - , "!os(linux)" - , "! arch(ppc)" - , "os(windows) && arch(i386)" - , "os(windows) && arch(i386) && flag(debug)" - , "true && false || false && true" -- should be same - , "(true && false) || (false && true)" -- as this - , "(os(darwin))" - , " ( os ( darwin ) ) " - , "true && !(false || os(plan9))" - , "flag( foo_bar )" - , "flag( foo_O_-_O_bar )" - , "impl ( ghc )" - , "impl( ghc >= 6.6.1 )" - ] - -test_ppCondTree = render $ ppCondTree tstTree (text . show) - - -test_simpCondTree = simplifyCondTree env tstTree - where - env x = maybe (Left x) Right (lookup x flags) - flags = [(mkFlag "a",False), (mkFlag "b",False), (mkFlag "c", True)] - mkFlag = Flag . ConfFlag - -test_resolveWithFlags = resolveWithFlags dom "os" "arch" ("ghc",Version [6,6] []) [tstTree] check - where - dom = [("a", [False,True]), ("b", [True,False]), ("c", [True,False])] - check ds = let missing = ds \\ avail in - case missing of - [] -> DepOk - _ -> MissingDeps missing - avail = [0,1,3,4] - -test_ignoreConditions = ignoreConditions tstTree diff --git a/cabal/cabal/tests/UnitTest/Distribution/ParseUtils.hs b/cabal/cabal/tests/UnitTest/Distribution/ParseUtils.hs deleted file mode 100644 --- a/cabal/cabal/tests/UnitTest/Distribution/ParseUtils.hs +++ /dev/null @@ -1,215 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.ParseUtils --- Copyright : (c) The University of Glasgow 2004 --- --- Maintainer : libraries@haskell.org --- Stability : alpha --- Portability : portable --- --- Utilities for parsing PackageDescription and InstalledPackageInfo. - - -{- 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 UnitTest.Distribution.ParseUtils where - -import Distribution.ParseUtils -import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat) -import Distribution.License (License) -import Distribution.Version -import Distribution.Package ( parsePackageName ) -import Distribution.Compat.ReadP as ReadP hiding (get) -import Distribution.Simple.Utils (intercalate) -import Language.Haskell.Extension (Extension) - -import Text.PrettyPrint.HughesPJ hiding (braces) -import Data.Char (isSpace, isUpper, toLower, isAlphaNum, isSymbol, isDigit) -import Data.Maybe (fromMaybe) -import Data.Tree as Tree (Tree(..), flatten) - -import Test.HUnit (Test(..), assertBool, Assertion, runTestTT, Counts, assertEqual) -import IO -import System.Environment ( getArgs ) -import Control.Monad ( zipWithM_ ) - ------------------------------------------------------------------------------- --- TESTING - -test_readFields = case - readFields testFile - of - ParseOk _ x -> x == expectedResult - _ -> False - where - testFile = unlines $ - [ "Cabal-version: 3" - , "" - , "Description: This is a test file " - , " with a description longer than two lines. " - , "if os(windows) {" - , " License: You may not use this software" - , " ." - , " If you do use this software you will be seeked and destroyed." - , "}" - , "if os(linux) {" - , " Main-is: foo1 " - , "}" - , "" - , "if os(vista) {" - , " executable RootKit {" - , " Main-is: DRMManager.hs" - , " }" - , "} else {" - , " executable VistaRemoteAccess {" - , " Main-is: VCtrl" - , "}}" - , "" - , "executable Foo-bar {" - , " Main-is: Foo.hs" - , "}" - ] - expectedResult = - [ F 1 "cabal-version" "3" - , F 3 "description" - "This is a test file\nwith a description longer than two lines." - , IfBlock 5 "os(windows) " - [ F 6 "license" - "You may not use this software\n\nIf you do use this software you will be seeked and destroyed." - ] - [] - , IfBlock 10 "os(linux) " - [ F 11 "main-is" "foo1" ] - [ ] - , IfBlock 14 "os(vista) " - [ Section 15 "executable" "RootKit " - [ F 16 "main-is" "DRMManager.hs"] - ] - [ Section 19 "executable" "VistaRemoteAccess " - [F 20 "main-is" "VCtrl"] - ] - , Section 23 "executable" "Foo-bar " - [F 24 "main-is" "Foo.hs"] - ] - -test_readFieldsCompat' = case test_readFieldsCompat of - ParseOk _ fs -> mapM_ (putStrLn . show) fs - x -> putStrLn $ "Failed: " ++ show x -test_readFieldsCompat = readFields testPkgDesc - where - testPkgDesc = unlines [ - "-- Required", - "Name: Cabal", - "Version: 0.1.1.1.1-rain", - "License: LGPL", - "License-File: foo", - "Copyright: Free Text String", - "Cabal-version: >1.1.1", - "-- Optional - may be in source?", - "Author: Happy Haskell Hacker", - "Homepage: http://www.haskell.org/foo", - "Package-url: http://www.haskell.org/foo", - "Synopsis: a nice package!", - "Description: a really nice package!", - "Category: tools", - "buildable: True", - "CC-OPTIONS: -g -o", - "LD-OPTIONS: -BStatic -dn", - "Frameworks: foo", - "Tested-with: GHC", - "Stability: Free Text String", - "Build-Depends: haskell-src, HUnit>=1.0.0-rain", - "Other-Modules: Distribution.Package, Distribution.Version,", - " Distribution.Simple.GHCPackageConfig", - "Other-files: file1, file2", - "Extra-Tmp-Files: file1, file2", - "C-Sources: not/even/rain.c, such/small/hands", - "HS-Source-Dirs: src, src2", - "Exposed-Modules: Distribution.Void, Foo.Bar", - "Extensions: OverlappingInstances, TypeSynonymInstances", - "Extra-Libraries: libfoo, bar, bang", - "Extra-Lib-Dirs: \"/usr/local/libs\"", - "Include-Dirs: your/slightest, look/will", - "Includes: /easily/unclose, /me, \"funky, path\\\\name\"", - "Install-Includes: /easily/unclose, /me, \"funky, path\\\\name\"", - "GHC-Options: -fTH -fglasgow-exts", - "Hugs-Options: +TH", - "Nhc-Options: ", - "Jhc-Options: ", - "", - "-- Next is an executable", - "Executable: somescript", - "Main-is: SomeFile.hs", - "Other-Modules: Foo1, Util, Main", - "HS-Source-Dir: scripts", - "Extensions: OverlappingInstances", - "GHC-Options: ", - "Hugs-Options: ", - "Nhc-Options: ", - "Jhc-Options: " - ] -{- -test' = do h <- openFile "../Cabal.cabal" ReadMode - s <- hGetContents h - let r = readFields s - case r of - ParseOk _ fs -> mapM_ (putStrLn . show) fs - x -> putStrLn $ "Failed: " ++ show x - putStrLn "===================" - mapM_ (putStrLn . show) $ - merge . zip [1..] . lines $ s - hClose h --} - --- ghc -DDEBUG --make Distribution/ParseUtils.hs -o test - -main :: IO () -main = do - inputFiles <- getArgs - ok <- mapM checkResult inputFiles - - zipWithM_ summary inputFiles ok - putStrLn $ show (length (filter not ok)) ++ " out of " ++ show (length ok) ++ " failed" - - where summary f True = return () - summary f False = putStrLn $ f ++ " failed :-(" - -checkResult :: FilePath -> IO Bool -checkResult inputFile = do - file <- readTextFile inputFile - case readFields file of - ParseOk _ result -> do - hPutStrLn stderr $ inputFile ++ " parses ok :-)" - return True - ParseFailed err -> do - hPutStrLn stderr $ inputFile ++ " parse failed:" - hPutStrLn stderr $ show err - return False diff --git a/cabal/cabal/tests/UnitTest/Distribution/Simple/PreProcess/UnlitTest.hs b/cabal/cabal/tests/UnitTest/Distribution/Simple/PreProcess/UnlitTest.hs deleted file mode 100644 --- a/cabal/cabal/tests/UnitTest/Distribution/Simple/PreProcess/UnlitTest.hs +++ /dev/null @@ -1,60 +0,0 @@ - -module UnitTest.Distribution.Simple.PreProcess.Unlit where - -import Distribution.Simple.PreProcess.Unlit -import Control.Exception - -cases = - ( "", "" ) : - -- latex state - ( "\\begin{code}\n\\end{code}\na\n", "\n\n-- a\n") : -- latex -> comment - ( "\\begin{code}\nx=x\n\\end{code}\n", "\nx=x\n\n") : -- latex -> latex (code) - ( "\\begin{code}\n\\begin{code}\n", "\\begin{code} in code section") : -- latex -> error - -- blank state - ( "\\end{code}\n", "\\end{code} without \\begin{code}") : -- blank -> error - ( "\\begin{code}\n\\end{code}\n", "\n\n") : -- blank -> latex - ( " \n#pre\n \n", " \n#pre\n \n" ) : -- blank -> blank (CPP) - ( "\n \n#pre\n \n", "\n \n#pre\n \n" ) : -- blank -> blank (CPP) - ( "\n> x=x\n", "\n x=x\n" ) : -- blank -> bird (> ) - ( "\n>x=x\n", "\n x=x\n" ) : -- blank -> bird (>) - ( "\n", "\n" ) : -- blank -> blank - ( " \n", " \n" ) : -- blank -> blank - ( " \na\n", " \n-- a\n" ) : -- blank -> comment - -- bird state - ( "> x=x\n\\end{code}\n", "\\end{code} without \\begin{code}") : -- bird -> error - ( "> x=x\n\\begin{code}\ny=y\n", " x=x\n\ny=y\n" ) : -- bird -> latex - ( "> x=x\n#abc\n> y=y\n", " x=x\n#abc\n y=y\n" ) : -- bird -> bird (CPP) - ( "> x=x\n> y=y\n", " x=x\n y=y\n" ) : -- bird -> bird (> ) - ( ">x=x\n>y=y\n", " x=x\n y=y\n" ) : -- bird -> bird (>) - ( "> x=x\n \n", " x=x\n \n" ) : -- bird -> empty - ( "> x=x\na\n", "program line before comment line" ) : -- bird -> error - -- comment state - -- comment -> error - ( "a\n\\end{code}\n", "\\end{code} without \\begin{code}") : - -- comment -> latex - ( "a\n\\begin{code}\nx=x\n\\end{code}\nb\n", "-- a\n\nx=x\n\n-- b\n" ) : - ( "a\n#pre\nb\n", "-- a\n#pre\n-- b\n" ) : -- comment -> comment (CPP) - ( "a\n> x=x\n", "comment line before program line" ) : -- comment -> error - ( "abc\n", "-- abc\n" ) : - ( "a\nb\n", "-- a\n-- b\n") : - ( "a\n\n", "-- a\n\n") : -- comment -> blank - ( "a\n\nb\n", "-- a\n--\n-- b\n" ) : -- comment -> blank - ( "a\n \n\n", "-- a\n \n\n" ) : -- comment -> comment - ( "a\n \n> x=x\n", "-- a\n \n x=x\n" ) : -- comment -> blank (> ) - ( "a\n \n>x=x\n", "-- a\n \n x=x\n" ) : -- comment -> blank (>) - ( "a\n \nb\n", "-- a\n-- \n-- b\n" ) : -- comment -> comment - [] - - -assertEq :: Int -> String -> String -> IO () -assertEq n actual expect = - if actual /= expect - then putStrLn ("Test "++show n++" failed:\n expect: "++expect++"\n actual: "++(take 200 actual)++"\n") - else putStrLn ("Test "++show n++" passed.") - -runTest (n, (input, expect)) = do - let actual = either id stripErr $ unlit ("test"++show n) input - assertEq n actual (expect ++ "\n") - where stripErr = (++"\n") . drop 2 . dropWhile (/= ':') . tail . dropWhile (/= ':') - -runTests = mapM_ runTest (zip [1..] cases) diff --git a/cabal/cabal/tests/UnitTest/Distribution/Version.hs b/cabal/cabal/tests/UnitTest/Distribution/Version.hs deleted file mode 100644 --- a/cabal/cabal/tests/UnitTest/Distribution/Version.hs +++ /dev/null @@ -1,118 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Version --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- --- Maintainer : Isaac Jones --- Stability : alpha --- Portability : portable --- --- Versions for packages, based on the 'Version' datatype. - -{- 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 UnitTest.Distribution.Version (hunitTests) where - -import Distribution.Version -import Distribution.Text ( simpleParse ) - -import Data.Version ( Version(..), showVersion ) - -import Control.Monad ( liftM ) -import Data.Char ( isSpace, isDigit, isAlphaNum ) -import Data.Maybe ( listToMaybe ) - -import Distribution.Compat.ReadP - -import Test.HUnit - --- ------------------------------------------------------------ --- * Testing --- ------------------------------------------------------------ - -branch1 :: [Int] -branch1 = [1] - -branch2 :: [Int] -branch2 = [1,2] - -branch3 :: [Int] -branch3 = [1,2,3] - -release1 :: Version -release1 = Version{versionBranch=branch1, versionTags=[]} - -release2 :: Version -release2 = Version{versionBranch=branch2, versionTags=[]} - -release3 :: Version -release3 = Version{versionBranch=branch3, versionTags=[]} - -hunitTests :: [Test] -hunitTests - = [ - "released version 1" ~: "failed" - ~: (Just release1) ~=? simpleParse "1", - "released version 3" ~: "failed" - ~: (Just release3) ~=? simpleParse "1.2.3", - - "range comparison LaterVersion 1" ~: "failed" - ~: True - ~=? release3 `withinRange` (LaterVersion release2), - "range comparison LaterVersion 2" ~: "failed" - ~: False - ~=? release2 `withinRange` (LaterVersion release3), - "range comparison EarlierVersion 1" ~: "failed" - ~: True - ~=? release3 `withinRange` (LaterVersion release2), - "range comparison EarlierVersion 2" ~: "failed" - ~: False - ~=? release2 `withinRange` (LaterVersion release3), - "range comparison orLaterVersion 1" ~: "failed" - ~: True - ~=? release3 `withinRange` (orLaterVersion release3), - "range comparison orLaterVersion 2" ~: "failed" - ~: True - ~=? release3 `withinRange` (orLaterVersion release2), - "range comparison orLaterVersion 3" ~: "failed" - ~: False - ~=? release2 `withinRange` (orLaterVersion release3), - "range comparison orEarlierVersion 1" ~: "failed" - ~: True - ~=? release2 `withinRange` (orEarlierVersion release2), - "range comparison orEarlierVersion 2" ~: "failed" - ~: True - ~=? release2 `withinRange` (orEarlierVersion release3), - "range comparison orEarlierVersion 3" ~: "failed" - ~: False - ~=? release3 `withinRange` (orEarlierVersion release2) - ] diff --git a/cabal/cabal/tests/hackage/check.sh b/cabal/cabal/tests/hackage/check.sh deleted file mode 100644 --- a/cabal/cabal/tests/hackage/check.sh +++ /dev/null @@ -1,25 +0,0 @@ -#!/bin/sh - -base_version=1.4.0.2 -test_version=1.5.6 - -for setup in archive/*/*/Setup.hs archive/*/*/Setup.lhs; do - - pkgname=$(basename ${setup}) - - if test $(wc -w < ${setup}) -gt 21; then - if ghc -package Cabal-${base_version} -S ${setup} -o /dev/null 2> /dev/null; then - - if ghc -package Cabal-${test_version} -S ${setup} -o /dev/null 2> /dev/null; then - echo "OK ${setup}" - else - echo "FAIL ${setup} does not compile with Cabal-${test_version}" - fi - else - echo "OK ${setup} (does not compile with Cabal-${base_version})" - fi - else - echo "trivial ${setup}" - fi - -done diff --git a/cabal/cabal/tests/hackage/download.sh b/cabal/cabal/tests/hackage/download.sh deleted file mode 100644 --- a/cabal/cabal/tests/hackage/download.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/bin/sh - -if test ! -f archive/archive.tar; then - - wget http://hackage.haskell.org/cgi-bin/hackage-scripts/archive.tar - mkdir -p archive - mv archive.tar archive/ - tar -C archive -xf archive/archive.tar - -fi - -if test ! -f archive/00-index.tar.gz; then - - wget http://hackage.haskell.org/packages/archive/00-index.tar.gz - mkdir -p archive - mv 00-index.tar.gz archive/ - tar -C archive -xzf archive/00-index.tar.gz - -fi diff --git a/cabal/cabal/tests/hackage/unpack.sh b/cabal/cabal/tests/hackage/unpack.sh deleted file mode 100644 --- a/cabal/cabal/tests/hackage/unpack.sh +++ /dev/null @@ -1,16 +0,0 @@ -#!/bin/sh - -for tarball in archive/*/*/*.tar.gz; do - - pkgdir=$(dirname ${tarball}) - pkgname=$(basename ${tarball} .tar.gz) - - if tar -tzf ${tarball} ${pkgname}/Setup.hs 2> /dev/null; then - tar -xzf ${tarball} ${pkgname}/Setup.hs -O > ${pkgdir}/Setup.hs - elif tar -tzf ${tarball} ${pkgname}/Setup.lhs 2> /dev/null; then - tar -xzf ${tarball} ${pkgname}/Setup.lhs -O > ${pkgdir}/Setup.lhs - else - echo "${pkgname} has no Setup.hs or .lhs at all!!?!" - fi - -done diff --git a/cabal/cabal/tests/misc/ghc-supported-languages.hs b/cabal/cabal/tests/misc/ghc-supported-languages.hs deleted file mode 100644 --- a/cabal/cabal/tests/misc/ghc-supported-languages.hs +++ /dev/null @@ -1,99 +0,0 @@ --- | A test program to check that ghc has got all of its extensions registered --- -module Main where - -import Language.Haskell.Extension -import Distribution.Text -import Distribution.Simple.Utils -import Distribution.Verbosity - -import Data.List ((\\)) -import Data.Maybe -import Control.Applicative -import Control.Monad -import System.Environment -import System.Exit - --- | A list of GHC extensions that are deliberately not registered, --- e.g. due to being experimental and not ready for public consumption --- -exceptions = map readExtension - [ "PArr" -- still classed as experimental, will be renamed and registered - ] - -checkProblems :: [Extension] -> [String] -checkProblems implemented = - - let unregistered = - [ ext | ext <- implemented -- extensions that ghc knows about - , not (registered ext) -- but that are not registered - , ext `notElem` exceptions ] -- except for the exceptions - - -- check if someone has forgotten to update the exceptions list... - - -- exceptions that are not implemented - badExceptions = exceptions \\ implemented - - -- exceptions that are now registered - badExceptions' = filter registered exceptions - - in catMaybes - [ check unregistered $ unlines - [ "The following extensions are known to GHC but are not in the " - , "extension registry in Language.Haskell.Extension." - , " " ++ intercalate "\n " (map display unregistered) - , "If these extensions are ready for public consumption then they " - , "should be registered. If they are still experimental and you " - , "think they are not ready to be registered then please add them " - , "to the exceptions list in this test program along with an " - , "explanation." - ] - , check badExceptions $ unlines - [ "Error in the extension exception list. The following extensions" - , "are listed as exceptions but are not even implemented by GHC:" - , " " ++ intercalate "\n " (map display badExceptions) - , "Please fix this test program by correcting the list of" - , "exceptions." - ] - , check badExceptions' $ unlines - [ "Error in the extension exception list. The following extensions" - , "are listed as exceptions to registration but they are in fact" - , "now registered in Language.Haskell.Extension:" - , " " ++ intercalate "\n " (map display badExceptions') - , "Please fix this test program by correcting the list of" - , "exceptions." - ] - ] - where - registered (UnknownExtension _) = False - registered _ = True - - check [] _ = Nothing - check _ i = Just i - - -main = topHandler $ do - [ghcPath] <- getArgs - exts <- getExtensions ghcPath - let problems = checkProblems exts - putStrLn (intercalate "\n" problems) - if null problems - then exitSuccess - else exitFailure - -getExtensions :: FilePath -> IO [Extension] -getExtensions ghcPath = - map readExtension . lines - <$> rawSystemStdout normal ghcPath ["--supported-languages"] - -readExtension :: String -> Extension -readExtension str = handleNoParse $ do - -- GHC defines extensions in a positive way, Cabal defines them - -- relative to H98 so we try parsing ("No" ++ extName) first - ext <- simpleParse ("No" ++ str) - case ext of - UnknownExtension _ -> simpleParse str - _ -> return ext - where - handleNoParse :: Maybe Extension -> Extension - handleNoParse = fromMaybe (error $ "unparsable extension " ++ show str) diff --git a/cabal/cabal/tests/suite.cabal b/cabal/cabal/tests/suite.cabal deleted file mode 100644 --- a/cabal/cabal/tests/suite.cabal +++ /dev/null @@ -1,30 +0,0 @@ -name: suite -version: 0.1 -license: BSD3 -author: Stephen Blackheath -stability: stable -synopsis: test suite for cabal -category: Distribution -build-type: Simple -cabal-version: >= 1.6 -description: - A test suite for cabal. Run it often, maintain it, add tests to it, - and it will work for you. - -Executable suite - main-is: suite.hs - build-depends: - base, - test-framework, - test-framework-quickcheck2, - test-framework-hunit, - HUnit, - QuickCheck >= 2.1.0.1, - Cabal, - filepath, - process, - directory, - extensible-exceptions, - bytestring, - unix - diff --git a/cabal/cabal/tests/suite.hs b/cabal/cabal/tests/suite.hs deleted file mode 100644 --- a/cabal/cabal/tests/suite.hs +++ /dev/null @@ -1,66 +0,0 @@ --- The intention is that this will be the new unit test framework. --- Please add any working tests here. This file should do nothing --- but import tests from other modules. --- --- Stephen Blackheath, 2009 - -module Main where - -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 -import qualified Test.HUnit as HUnit -import PackageTests.BuildDeps.SameDepsAllRound.Check -import PackageTests.BuildDeps.TargetSpecificDeps1.Check -import PackageTests.BuildDeps.TargetSpecificDeps1.Check -import PackageTests.BuildDeps.TargetSpecificDeps2.Check -import PackageTests.BuildDeps.TargetSpecificDeps3.Check -import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check -import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check -import PackageTests.BuildDeps.InternalLibrary0.Check -import PackageTests.BuildDeps.InternalLibrary1.Check -import PackageTests.BuildDeps.InternalLibrary2.Check -import PackageTests.BuildDeps.InternalLibrary3.Check -import PackageTests.BuildDeps.InternalLibrary4.Check -import PackageTests.TestStanza.Check -import PackageTests.TestSuiteExeV10.Check -import Distribution.Text (display) -import Distribution.Simple.Utils (cabalVersion) -import Data.Version -import System.Directory - -hunit :: TestName -> HUnit.Test -> Test -hunit name test = testGroup name $ hUnitTestToTests test - -tests :: Version -> [Test] -tests cabalVersion = [ - hunit "PackageTests/BuildDeps/SameDepsAllRound/" PackageTests.BuildDeps.SameDepsAllRound.Check.suite, - hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check.suite, - hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check.suite, - hunit "PackageTests/BuildDeps/InternalLibrary0/" (PackageTests.BuildDeps.InternalLibrary0.Check.suite cabalVersion), - hunit "PackageTests/TestStanza/" (PackageTests.TestStanza.Check.suite cabalVersion), - -- ^ The Test stanza test will eventually be required - -- only for higher versions. - hunit "PackageTests/TestSuiteExeV10/Test" - (PackageTests.TestSuiteExeV10.Check.checkTest cabalVersion), - hunit "PackageTests/TestSuiteExeV10/TestWithHpc" - (PackageTests.TestSuiteExeV10.Check.checkTestWithHpc cabalVersion) - ] ++ - -- These tests are only required to pass on cabal version >= 1.7 - (if cabalVersion >= Version [1, 7] [] - then [ - hunit "PackageTests/BuildDeps/TargetSpecificDeps1/" PackageTests.BuildDeps.TargetSpecificDeps1.Check.suite, - hunit "PackageTests/BuildDeps/TargetSpecificDeps2/" PackageTests.BuildDeps.TargetSpecificDeps2.Check.suite, - hunit "PackageTests/BuildDeps/TargetSpecificDeps3/" PackageTests.BuildDeps.TargetSpecificDeps3.Check.suite, - hunit "PackageTests/BuildDeps/InternalLibrary1/" PackageTests.BuildDeps.InternalLibrary1.Check.suite, - hunit "PackageTests/BuildDeps/InternalLibrary2/" PackageTests.BuildDeps.InternalLibrary2.Check.suite, - hunit "PackageTests/BuildDeps/InternalLibrary3/" PackageTests.BuildDeps.InternalLibrary3.Check.suite, - hunit "PackageTests/BuildDeps/InternalLibrary4/" PackageTests.BuildDeps.InternalLibrary4.Check.suite - ] - else []) - -main = do - putStrLn $ "Cabal test suite - testing cabal version "++display cabalVersion - setCurrentDirectory "tests" - defaultMain (tests cabalVersion) - diff --git a/cabal/cabal/tests/systemTests/A/A.cabal b/cabal/cabal/tests/systemTests/A/A.cabal deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/A/A.cabal +++ /dev/null @@ -1,23 +0,0 @@ -Name: test -cabal-version: > 1.1 -Version: 1.0 -copyright: filler for test suite -maintainer: Isaac Jones -synopsis: this package is really awesome. -Build-Depends: base -Other-Modules: B.A -Exposed-Modules: A -C-Sources: hello.c, c_src/hello.c -Extensions: ForeignFunctionInterface -x-darcs-repo: http://darcs.haskell.org/tmp -unknown-field: Filler. - -Executable: testA -Other-Modules: A -Main-is: MainA.hs -C-Sources: c_src/hello.c -Extensions: OverlappingInstances - -Executable: testB -Other-Modules: B.A -Main-is: B/MainB.hs diff --git a/cabal/cabal/tests/systemTests/A/A.hs b/cabal/cabal/tests/systemTests/A/A.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/A/A.hs +++ /dev/null @@ -1,4 +0,0 @@ -module A where -a = 42 :: Int - -main2 = print a diff --git a/cabal/cabal/tests/systemTests/A/B/A.lhs b/cabal/cabal/tests/systemTests/A/B/A.lhs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/A/B/A.lhs +++ /dev/null @@ -1,4 +0,0 @@ -> module B.A where -> a = 42 :: Int - -> main = print a diff --git a/cabal/cabal/tests/systemTests/A/B/MainB.hs b/cabal/cabal/tests/systemTests/A/B/MainB.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/A/B/MainB.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main where - -import A - -main = print a diff --git a/cabal/cabal/tests/systemTests/A/MainA.hs b/cabal/cabal/tests/systemTests/A/MainA.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/A/MainA.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main where - -import A - -main = print a diff --git a/cabal/cabal/tests/systemTests/A/Makefile b/cabal/cabal/tests/systemTests/A/Makefile deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/A/Makefile +++ /dev/null @@ -1,1 +0,0 @@ -include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/A/Setup.lhs b/cabal/cabal/tests/systemTests/A/Setup.lhs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/A/Setup.lhs +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env runhaskell - -> module Main where - -> import Distribution.Simple - -> main :: IO () -> main = defaultMain diff --git a/cabal/cabal/tests/systemTests/A/c_src/hello.c b/cabal/cabal/tests/systemTests/A/c_src/hello.c deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/A/c_src/hello.c +++ /dev/null @@ -1,1 +0,0 @@ -int foo () {return 9;} diff --git a/cabal/cabal/tests/systemTests/A/hello.c b/cabal/cabal/tests/systemTests/A/hello.c deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/A/hello.c +++ /dev/null @@ -1,1 +0,0 @@ -int main () {return 9;} diff --git a/cabal/cabal/tests/systemTests/buildInfo/Makefile b/cabal/cabal/tests/systemTests/buildInfo/Makefile deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/buildInfo/Makefile +++ /dev/null @@ -1,1 +0,0 @@ -include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/buildInfo/Setup.lhs b/cabal/cabal/tests/systemTests/buildInfo/Setup.lhs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/buildInfo/Setup.lhs +++ /dev/null @@ -1,5 +0,0 @@ -#!/usr/bin/runhaskell - -> import Distribution.Simple -> main = defaultMainWithHooks defaultUserHooks - diff --git a/cabal/cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo b/cabal/cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo +++ /dev/null @@ -1,5 +0,0 @@ -Executable: exe1 -Buildable: True - -Executable: exe2 -Buildable: True diff --git a/cabal/cabal/tests/systemTests/buildInfo/buildinfo2.cabal b/cabal/cabal/tests/systemTests/buildInfo/buildinfo2.cabal deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/buildInfo/buildinfo2.cabal +++ /dev/null @@ -1,19 +0,0 @@ -Name: buildinfo2 -Version: 0.0 -License: GPL -License-file: COPYING -Build-Depends: base -Author: Evgeny Chukreev -Copyright: Evgeny Chukreev (C) 2005 -Maintainer: Evgeny Chukreev -Synopsis: Buildinfo testcase -Description: - Buildinfo testcase - -Executable: exe1 -Main-is: exe1.hs -HS-source-dirs: src - -Executable: exe2 -Main-is: exe2.hs -HS-source-dirs: src diff --git a/cabal/cabal/tests/systemTests/buildInfo/src/exe1.hs b/cabal/cabal/tests/systemTests/buildInfo/src/exe1.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/buildInfo/src/exe1.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main () where - -main :: IO () -main = return () diff --git a/cabal/cabal/tests/systemTests/buildInfo/src/exe2.hs b/cabal/cabal/tests/systemTests/buildInfo/src/exe2.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/buildInfo/src/exe2.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main () where - -main :: IO () -main = return () diff --git a/cabal/cabal/tests/systemTests/dataDir/Exe.hs b/cabal/cabal/tests/systemTests/dataDir/Exe.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/dataDir/Exe.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Main where - -import Control.Monad (unless) -import Paths_test (getDataFileName) -import System.Directory (doesFileExist) -import System.Exit (exitFailure) -import System.IO (putStrLn) - -main :: IO () -main = do - fname <- getDataFileName "data-file" - exists <- doesFileExist fname - if exists - then return () - else do putStrLn "Failure." - print fname - exitFailure diff --git a/cabal/cabal/tests/systemTests/dataDir/data-file b/cabal/cabal/tests/systemTests/dataDir/data-file deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/dataDir/data-file +++ /dev/null diff --git a/cabal/cabal/tests/systemTests/dataDir/dataDir.cabal b/cabal/cabal/tests/systemTests/dataDir/dataDir.cabal deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/dataDir/dataDir.cabal +++ /dev/null @@ -1,13 +0,0 @@ -name: test -version: 0.1 -build-type: Simple -cabal-version: >= 1.2 -data-files: data-file - --- This test passes if running the below executeable doesn't return an --- 'exitFailure' status code. - -executable exe - main-is: Exe.hs --- other-modules: Paths_test - build-depends: base, directory diff --git a/cabal/cabal/tests/systemTests/depOnLib/Makefile b/cabal/cabal/tests/systemTests/depOnLib/Makefile deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/depOnLib/Makefile +++ /dev/null @@ -1,1 +0,0 @@ -include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/depOnLib/Setup.lhs b/cabal/cabal/tests/systemTests/depOnLib/Setup.lhs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/depOnLib/Setup.lhs +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/runhugs - -> module Main where - -> import Distribution.Simple - -> main :: IO () -> main = defaultMain diff --git a/cabal/cabal/tests/systemTests/depOnLib/libs/A.hs b/cabal/cabal/tests/systemTests/depOnLib/libs/A.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/depOnLib/libs/A.hs +++ /dev/null @@ -1,4 +0,0 @@ -module A where - -a :: Char -a = 'a' diff --git a/cabal/cabal/tests/systemTests/depOnLib/mains/Main.hs b/cabal/cabal/tests/systemTests/depOnLib/mains/Main.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/depOnLib/mains/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where -import A - -main = putStrLn "Hello, cabal." diff --git a/cabal/cabal/tests/systemTests/depOnLib/test.cabal b/cabal/cabal/tests/systemTests/depOnLib/test.cabal deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/depOnLib/test.cabal +++ /dev/null @@ -1,13 +0,0 @@ -Name: test -Version: 1.0 -hs-source-dir: libs -copyright: filler for test suite -maintainer: filler for test suite -synopsis: filler for test suite -build-depends: base -exposed-modules: A - -Executable: mainForA -Other-Modules: Main, A -hs-source-dirs: mains, libs -Main-is: Main.hs diff --git a/cabal/cabal/tests/systemTests/exeWithC/Makefile b/cabal/cabal/tests/systemTests/exeWithC/Makefile deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/exeWithC/Makefile +++ /dev/null @@ -1,1 +0,0 @@ -include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/exeWithC/Setup.lhs b/cabal/cabal/tests/systemTests/exeWithC/Setup.lhs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/exeWithC/Setup.lhs +++ /dev/null @@ -1,2 +0,0 @@ -> import Distribution.Simple -> main = defaultMainWithHooks defaultUserHooks diff --git a/cabal/cabal/tests/systemTests/exeWithC/a.c b/cabal/cabal/tests/systemTests/exeWithC/a.c deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/exeWithC/a.c +++ /dev/null @@ -1,1 +0,0 @@ -int foo(int v) { return 2*v; } diff --git a/cabal/cabal/tests/systemTests/exeWithC/test.hs b/cabal/cabal/tests/systemTests/exeWithC/test.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/exeWithC/test.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# CFILES a.c #-} -foreign import ccall unsafe "foo" foo :: Int -> Int - -main = print $ foo 6 diff --git a/cabal/cabal/tests/systemTests/exeWithC/tt.cabal b/cabal/cabal/tests/systemTests/exeWithC/tt.cabal deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/exeWithC/tt.cabal +++ /dev/null @@ -1,13 +0,0 @@ -Name: tt -Version: 0.0 -Copyright: Einar Karttunen -Maintainer: Isaac Jones -Synopsis: Provided as a test. -License: BSD3 -Author: This Test Case Contributed by: Einar Karttunen Thanks! -Build-Depends: base - -Executable: tt -Main-Is: test.hs -C-Sources: a.c -Extensions: ForeignFunctionInterface diff --git a/cabal/cabal/tests/systemTests/ffi-bin/Main.hs b/cabal/cabal/tests/systemTests/ffi-bin/Main.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/ffi-bin/Main.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import TestFFI - -main :: IO () -main = putStrLn "test" - diff --git a/cabal/cabal/tests/systemTests/ffi-bin/Makefile b/cabal/cabal/tests/systemTests/ffi-bin/Makefile deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/ffi-bin/Makefile +++ /dev/null @@ -1,1 +0,0 @@ -include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/ffi-bin/Setup.lhs b/cabal/cabal/tests/systemTests/ffi-bin/Setup.lhs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/ffi-bin/Setup.lhs +++ /dev/null @@ -1,4 +0,0 @@ -#! /usr/bin/env runhaskell - -> import Distribution.Simple -> main = defaultMain diff --git a/cabal/cabal/tests/systemTests/ffi-bin/main.cabal b/cabal/cabal/tests/systemTests/ffi-bin/main.cabal deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/ffi-bin/main.cabal +++ /dev/null @@ -1,6 +0,0 @@ -Name: test-bin -Build-Depends: base, testffi -Version: 0.0 - -Executable: test -Main-Is: Main.hs diff --git a/cabal/cabal/tests/systemTests/ffi-package/Makefile b/cabal/cabal/tests/systemTests/ffi-package/Makefile deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/ffi-package/Makefile +++ /dev/null @@ -1,1 +0,0 @@ -include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/ffi-package/Setup.lhs b/cabal/cabal/tests/systemTests/ffi-package/Setup.lhs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/ffi-package/Setup.lhs +++ /dev/null @@ -1,4 +0,0 @@ -#! /usr/bin/env runhugs - -> import Distribution.Simple -> main = defaultMain diff --git a/cabal/cabal/tests/systemTests/ffi-package/TestFFIExe.hs b/cabal/cabal/tests/systemTests/ffi-package/TestFFIExe.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/ffi-package/TestFFIExe.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Main where - -import Foreign - -type Action = IO () - -foreign import ccall "wrapper" - mkAction :: Action -> IO (FunPtr Action) - -main :: IO () -main = return () diff --git a/cabal/cabal/tests/systemTests/ffi-package/src/TestFFI.hs b/cabal/cabal/tests/systemTests/ffi-package/src/TestFFI.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/ffi-package/src/TestFFI.hs +++ /dev/null @@ -1,8 +0,0 @@ -module TestFFI where - -import Foreign - -type Action = IO () - -foreign import ccall "wrapper" - mkAction :: Action -> IO (FunPtr Action) diff --git a/cabal/cabal/tests/systemTests/ffi-package/testffi.cabal b/cabal/cabal/tests/systemTests/ffi-package/testffi.cabal deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/ffi-package/testffi.cabal +++ /dev/null @@ -1,10 +0,0 @@ -Name: testffi -Version: 0.0 -Build-Depends: base -hs-source-dir: src -Exposed-modules: TestFFI -Extensions: ForeignFunctionInterface - -executable: foo -main-is: TestFFIExe.hs -Extensions: ForeignFunctionInterface diff --git a/cabal/cabal/tests/systemTests/preprocess/preprocess.cabal b/cabal/cabal/tests/systemTests/preprocess/preprocess.cabal deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/preprocess/preprocess.cabal +++ /dev/null @@ -1,9 +0,0 @@ --- The point of this test is to check that the c2hs pre-processed .hs sources --- end up in dist/build and that the happy one stays in the src dir. --- Also, the happy one should be included into the sdist tarball. - -name: preprocess -version: 0.0 -build-depends: base -hs-source-dirs: src -exposed-modules: C2HsExample, HappyExample diff --git a/cabal/cabal/tests/systemTests/preprocess/src/C2HsExample.chs b/cabal/cabal/tests/systemTests/preprocess/src/C2HsExample.chs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/preprocess/src/C2HsExample.chs +++ /dev/null @@ -1,3 +0,0 @@ -module C2HsExample where - --- we don't actually need anything diff --git a/cabal/cabal/tests/systemTests/preprocess/src/HappyExample.y b/cabal/cabal/tests/systemTests/preprocess/src/HappyExample.y deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/preprocess/src/HappyExample.y +++ /dev/null @@ -1,92 +0,0 @@ -{ -module HappyExample where -import Data.Char -} - -%name calc -%tokentype { Token } -%expect 0 - - -%token - let { TokenLet } - in { TokenIn } - int { TokenInt $$ } - var { TokenVar $$ } - '=' { TokenEq } - '+' { TokenPlus } - '-' { TokenMinus } - '*' { TokenTimes } - '/' { TokenDiv } - '(' { TokenOB } - ')' { TokenCB } - - -%% - -Exp :: { Exp } -Exp : let var '=' Exp in Exp { Let $2 $4 $6 } - | Exp1 { Exp1 $1 } - -Exp1 : Exp1 '+' Term { Plus $1 $3 } - | Exp1 '-' Term { Minus $1 $3 } - | Term { Term $1 } - -Term : Term '*' Factor { Times $1 $3 } - | Term '/' Factor { Div $1 $3 } - | Factor { Factor $1 } - -Factor : int { Int $1 } - | var { Var $1 } - | '(' Exp ')' { Brack $2 } - - -{ - -happyError :: [Token] -> a -happyError _ = error ("Parse error\n") - - -data Exp = Let String Exp Exp | Exp1 Exp1 -data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term -data Term = Times Term Factor | Div Term Factor | Factor Factor -data Factor = Int Int | Var String | Brack Exp - - -data Token - = TokenLet - | TokenIn - | TokenInt Int - | TokenVar String - | TokenEq - | TokenPlus - | TokenMinus - | TokenTimes - | TokenDiv - | TokenOB - | TokenCB - -lexer :: String -> [Token] -lexer [] = [] -lexer (c:cs) - | isSpace c = lexer cs - | isAlpha c = lexVar (c:cs) - | isDigit c = lexNum (c:cs) -lexer ('=':cs) = TokenEq : lexer cs -lexer ('+':cs) = TokenPlus : lexer cs -lexer ('-':cs) = TokenMinus : lexer cs -lexer ('*':cs) = TokenTimes : lexer cs -lexer ('/':cs) = TokenDiv : lexer cs -lexer ('(':cs) = TokenOB : lexer cs -lexer (')':cs) = TokenCB : lexer cs - -lexNum cs = TokenInt (read num) : lexer rest - where (num,rest) = span isDigit cs - -lexVar cs = - case span isAlpha cs of - ("let",rest) -> TokenLet : lexer rest - ("in",rest) -> TokenIn : lexer rest - (var,rest) -> TokenVar var : lexer rest - -} diff --git a/cabal/cabal/tests/systemTests/recursive/A.hi-boot b/cabal/cabal/tests/systemTests/recursive/A.hi-boot deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/recursive/A.hi-boot +++ /dev/null @@ -1,2 +0,0 @@ -module A where -newtype TA = MkTA GHC.Base.Int diff --git a/cabal/cabal/tests/systemTests/recursive/A.hs b/cabal/cabal/tests/systemTests/recursive/A.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/recursive/A.hs +++ /dev/null @@ -1,8 +0,0 @@ -module A where - -import B( TB(..) ) - -newtype TA = MkTA Int - -f :: TB -> TA -f (MkTB x) = MkTA x diff --git a/cabal/cabal/tests/systemTests/recursive/A.hs-boot b/cabal/cabal/tests/systemTests/recursive/A.hs-boot deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/recursive/A.hs-boot +++ /dev/null @@ -1,2 +0,0 @@ -module A where -newtype TA = MkTA Int diff --git a/cabal/cabal/tests/systemTests/recursive/B.hs b/cabal/cabal/tests/systemTests/recursive/B.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/recursive/B.hs +++ /dev/null @@ -1,8 +0,0 @@ -module B where -import {-# SOURCE #-} A( TA(..) ) - -data TB = MkTB !Int - -g :: TA -> TB -g (MkTA x) = MkTB x - diff --git a/cabal/cabal/tests/systemTests/recursive/C.hs b/cabal/cabal/tests/systemTests/recursive/C.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/recursive/C.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where -import B -import A -- FIX: GHC doesn't seem to figure out this dependency?! - -main :: IO () -main = let f = g in putStrLn "C" diff --git a/cabal/cabal/tests/systemTests/recursive/Makefile b/cabal/cabal/tests/systemTests/recursive/Makefile deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/recursive/Makefile +++ /dev/null @@ -1,1 +0,0 @@ -include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/recursive/Setup.lhs b/cabal/cabal/tests/systemTests/recursive/Setup.lhs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/recursive/Setup.lhs +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env runhaskell - -> module Main where - -> import Distribution.Simple - -> main :: IO () -> main = defaultMain diff --git a/cabal/cabal/tests/systemTests/recursive/recursive.cabal b/cabal/cabal/tests/systemTests/recursive/recursive.cabal deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/recursive/recursive.cabal +++ /dev/null @@ -1,11 +0,0 @@ -name: recursive -build-depends: base -version: 1.0 -copyright: filler for test suite -maintainer: Isaac Jones -synopsis: this package is really awesome. -Exposed-Modules: A, B - -Executable: testExe -Main-is: C.hs -other-modules: A, B diff --git a/cabal/cabal/tests/systemTests/sdist/Exe1.hs b/cabal/cabal/tests/systemTests/sdist/Exe1.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/sdist/Exe1.hs +++ /dev/null @@ -1,1 +0,0 @@ -main = print "exe1" diff --git a/cabal/cabal/tests/systemTests/sdist/Exe2.hs b/cabal/cabal/tests/systemTests/sdist/Exe2.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/sdist/Exe2.hs +++ /dev/null @@ -1,1 +0,0 @@ -main = print "exe2" diff --git a/cabal/cabal/tests/systemTests/sdist/sdist.cabal b/cabal/cabal/tests/systemTests/sdist/sdist.cabal deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/sdist/sdist.cabal +++ /dev/null @@ -1,19 +0,0 @@ -Name: test -Version: 0.1 -Build-Type: Simple -Cabal-Version: >=1.2 - --- http://hackage.haskell.org/trac/hackage/ticket/257 --- This is a test to make sure we're including all sections into the sdist --- irrespective of the buildable status. --- So the test passes if the tarball includes both Exe1.hs and Exe2.hs - -Executable exe1 - Main-Is: Exe1.hs - Build-Depends: base - -Executable exe2 - Main-Is: Exe2.hs - Build-Depends: base - if !os(linux) - Buildable: False diff --git a/cabal/cabal/tests/systemTests/twoMains/MainA.hs b/cabal/cabal/tests/systemTests/twoMains/MainA.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/twoMains/MainA.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Main where - -import System.Environment (getArgs) -import Control.Monad (when) - -main = do print 'a' - args <- getArgs - let isB = head args - when (isB /= "isA") (error "A is not A!") diff --git a/cabal/cabal/tests/systemTests/twoMains/MainB.hs b/cabal/cabal/tests/systemTests/twoMains/MainB.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/twoMains/MainB.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Main where - -import System.Environment (getArgs) -import Control.Monad (when) - -main = do print 'b' - args <- getArgs - let isB = head args - when (isB /= "isB") (error "B is not B!") diff --git a/cabal/cabal/tests/systemTests/twoMains/Makefile b/cabal/cabal/tests/systemTests/twoMains/Makefile deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/twoMains/Makefile +++ /dev/null @@ -1,1 +0,0 @@ -include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/twoMains/Setup.lhs b/cabal/cabal/tests/systemTests/twoMains/Setup.lhs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/twoMains/Setup.lhs +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/runhugs - -> module Main where - -> import Distribution.Simple - -> main :: IO () -> main = defaultMain diff --git a/cabal/cabal/tests/systemTests/twoMains/test.cabal b/cabal/cabal/tests/systemTests/twoMains/test.cabal deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/twoMains/test.cabal +++ /dev/null @@ -1,14 +0,0 @@ -Name: test -Version: 1.0 -copyright: filler for test suite -maintainer: filler for test suite -build-depends: base -synopsis: filler for test suite - -Executable: testA -Other-Modules: MainA -Main-is: MainA.hs - -Executable: testB -Other-Modules: MainB -Main-is: MainB.hs diff --git a/cabal/cabal/tests/systemTests/wash2hs/CHANGES b/cabal/cabal/tests/systemTests/wash2hs/CHANGES deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/wash2hs/CHANGES +++ /dev/null @@ -1,5 +0,0 @@ -* 20031112 - added JSP-style string escape: - <%= my nice haskell code %> - is mapped to - text (my nice haskell code) diff --git a/cabal/cabal/tests/systemTests/wash2hs/LICENSE b/cabal/cabal/tests/systemTests/wash2hs/LICENSE deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/wash2hs/LICENSE +++ /dev/null @@ -1,27 +0,0 @@ -Copyright (C) 2000-2003 Erik Meijer, Danny van Velzen, and Peter Thiemann - -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. -3. The names of the authors may not be used to endorse or promote - products derived from this software without specific prior written - permission. - -THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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. diff --git a/cabal/cabal/tests/systemTests/wash2hs/Makefile b/cabal/cabal/tests/systemTests/wash2hs/Makefile deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/wash2hs/Makefile +++ /dev/null @@ -1,1 +0,0 @@ -include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/wash2hs/Setup.lhs b/cabal/cabal/tests/systemTests/wash2hs/Setup.lhs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/wash2hs/Setup.lhs +++ /dev/null @@ -1,9 +0,0 @@ -> module Main where - -> import Distribution.Simple - -> main :: IO () -> main = defaultMain - -to compile: -ghc -package Cabal -package parsec Setup.lhs -o setup diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHClean.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHClean.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHClean.hs +++ /dev/null @@ -1,58 +0,0 @@ -module WASHClean where - -import Data.Char - -import WASHData - -data CM a = CM ([String] -> a) -instance Monad CM where -- Reader monad - return x = CM (const x) - m >>= f = CM (\strs -> - case m of - CM mfun -> - case f (mfun strs) of - CM ffun -> - ffun strs) - -class Clean n where - clean :: n -> CM n - -cleanCodeFragList :: [CodeFrag] -> [CodeFrag] -cleanCodeFragList = map g - where g (EFrag el) = EFrag (cleanElement el) - g (CFrag cs) = CFrag (cleanContentList cs) - g cf = cf - -cleanElement :: Element -> Element -cleanElement e@Element{elemName = en, elemContent = ec} = - if en == "pre" - then e - else let ec' = cleanContentList ec in - e{elemContent = ec'} - -cleanContentList :: [Content] -> [Content] -cleanContentList = remove . map g . combine - where g c = case c of CElement{celem = el} -> CElement{celem = cleanElement el} - CText{ctext = et} -> CText{ctext = et { textString = cleanText (textString et) }} - CCode{ccode = ec} -> CCode{ccode = cleanCodeFragList ec} - _ -> c - combine (CText {ctext = t1} : CText {ctext = t2} : rest ) = - combine (CText {ctext = Text {textString = textString t1++ textString t2, textMode = textMode t1}} : rest) - combine (x : xs) = x : combine xs - combine [] = [] - remove (CText{ctext = tt} : rest) | textString tt == " " = remove rest - -- remove (CText{ctext = tt} : rest@(CElement{} : _)) = CText{ctext = dropRight tt} : remove rest - -- remove (e@CElement{} : (CText{ctext = tt} : rest)) = e : remove (CText{ctext = dropLeft tt} : rest) - remove (x : rest) = x : remove rest - remove [] = [] - -cleanText "" = "" -cleanText xs@[x] | isSpace x = " " - | otherwise = xs -cleanText (x : ys@(y : _)) | isSpace x = if isSpace y - then cleanText ys - else ' ' : cleanText ys - | otherwise = x : cleanText ys - -dropRight tt = tt { textString = reverse (dropWhile isSpace (reverse (textString tt))) } -dropLeft tt = tt { textString = dropWhile isSpace (textString tt) } diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHData.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHData.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHData.hs +++ /dev/null @@ -1,74 +0,0 @@ -module WASHData -- derived from HSPData - ( File (..) - , Mode (..) - , Element (..) - , Text (..) - , Content (..) - , CodeFrag (..) - , Attribute (..) - , AttrValue (..) - ) -where { - - --- Data type. - -data File = File { - fcode :: [CodeFrag], - topElem :: Element - } deriving Show; - -data Mode = V | S | F - deriving (Eq,Show); - -data Element = Element - { elemMode :: Mode - , elemName :: String - , elemAttrs :: [Attribute] - , elemContent :: [Content] - , elemEmptyTag :: Bool } - deriving Show; - -data Text = Text - { textMode :: Mode - , textString :: String - } - deriving Show; - -data Content - = CElement { celem :: Element } - | CText { ctext :: Text } - | CReference { creference :: Text } - | CPI { cpi :: String } - | CComment { ccomment :: String } - | CCode { ccode :: [CodeFrag] } - deriving Show; - -data CodeFrag - = HFrag String - | EFrag Element - | HSFrag String - | CFrag [Content] - | AFrag [Attribute] - | VFrag String - deriving Show; - -data Attribute - = Attribute - { attrMode :: Mode - , attrName :: String - , attrValue :: AttrValue } - | AttrPattern - { attrPattern :: String } - deriving Show; - -data AttrValue - = AText String - | ACode String - deriving Show; - -data Reference = Reference String deriving Show; - - - -} diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs +++ /dev/null @@ -1,158 +0,0 @@ -module WASHExpression where - -import Control.Monad - -import WASHFlags -import qualified WASHUtil -import WASHData -import WASHOut - -code :: FLAGS -> [CodeFrag] -> ShowS -code flags [] = id -code flags (x:xs) = code' flags x . code flags xs - -code' :: FLAGS -> CodeFrag -> ShowS -code' flags (HFrag h) = - showString h -code' flags (EFrag e) = - runOut $ element flags e -code' flags (CFrag cnts) = - showChar '(' . - runOut (contents flags [] cnts) . - showChar ')' -code' flags (AFrag attrs) = - showChar '(' . - WASHUtil.itemList (attribute flags) "CGI.empty" " >> " attrs . - showChar ')' -code' flags (VFrag var) = - id -code' flags _ = error "Unknown type: code" - -outMode :: Mode -> Out () -outMode = outShowS . showMode - -showMode :: Mode -> ShowS -showMode V = id -showMode S = showString "_T" -showMode F = showString "_S" - -element :: FLAGS -> Element -> Out [String] -element flags (Element mode nm ats cnt et) = - do outChar '(' - outString "CGI." - outString nm - when (generateBT flags) $ outMode mode - outChar '(' - outShowS $ attributes flags ats - rvs <- contents flags [] cnt - outString "))" - return rvs - -outRVS :: [String] -> Out () -outRVS [] = outString "()" -outRVS (x:xs) = - do outChar '(' - outString x - mapM_ g xs - outChar ')' - where g x = do { outChar ','; outString x; } - -outRVSpat :: [String] -> Out () -outRVSpat [] = outString "(_)" -outRVSpat xs = outRVS xs - -contents :: FLAGS -> [String] -> [Content] -> Out [String] -contents flags inRVS cts = - case cts of - [] -> - do outString "return" - outRVS inRVS - return inRVS - ct:cts -> - do rvs <- content flags ct - case rvs of - [] -> - case (cts, inRVS) of - ([],[]) -> - return [] - _ -> - do outString " >> " - contents flags inRVS cts - _ -> - case (cts, inRVS) of - ([],[]) -> - return rvs - _ -> - do outString " >>= \\ " - outRVSpat rvs - outString " -> " - contents flags (rvs ++ inRVS) cts - -content :: FLAGS -> Content -> Out [String] -content flags (CElement elem) = - element flags elem -content flags (CText txt) = - do text flags txt - return [] -content flags (CCode (VFrag var:c)) = - do outShowS $ (showChar '(' . code flags c . showChar ')') - return [var] -content flags (CCode c) = - do outShowS $ (showChar '(' . code flags c . showChar ')') - return [] -content flags (CComment cc) = - do outShowS $ (showString "return (const () " . shows cc . showChar ')') - return [] -content flags (CReference txt) = - do text flags txt - return [] -content flags c = - error $ "Unknown type: content -- " ++ (show c) - -text :: FLAGS -> Text -> Out [String] -text flags txt = - do outString "CGI.rawtext" - when (generateBT flags) $ outMode (textMode txt) - outChar ' ' - outs (textString txt) - return [] - -attributes :: FLAGS -> [Attribute] -> ShowS -attributes flags atts = - f atts - where - f [] = id - f (att:atts) = - attribute flags att . - showString " >> " . - f atts - -attribute :: FLAGS -> Attribute -> ShowS -attribute flags (Attribute m n v) = - showString "(CGI.attr" . - (if generateBT flags then (attrvalueBT m v) else id) . - showChar ' ' . - shows n . - showString " " . - attrvalue v . - showString ")" -attribute flags (AttrPattern pat) = - showString "( " . - showString pat . - showString " )" -attribute flags a = error $ "Unknown type: attribute -- " ++ (show a) - -attrvalue :: AttrValue -> ShowS -attrvalue (AText t) = - shows t -attrvalue (ACode c) = - showString "( " . - showString c . - showString " )" -attrvalue a = error $ "Unknown type: attrvalue -- " ++ (show a) - -attrvalueBT :: Mode -> AttrValue -> ShowS -attrvalueBT V _ = id -attrvalueBT m (AText _) = showMode m . showChar 'S' -attrvalueBT m (ACode _) = showMode m . showChar 'D' -attrvalueBT m a = error $ "Unknown type: attrvalueBT -- " ++ (show a) diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs +++ /dev/null @@ -1,7 +0,0 @@ -module WASHFlags where --- -flags0 = FLAGS { generateBT = False } - -data FLAGS = FLAGS { generateBT :: Bool } - - diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs +++ /dev/null @@ -1,57 +0,0 @@ -module WASHGenerator (preprocess, preprocessPIPE) where { - -import Data.List; -import System.IO; - -import WASHData ; -import Parsec hiding (try) ; -import qualified WASHParser ; -import qualified WASHExpression ; -import qualified WASHClean ; -import WASHFlags ; - --- import Trace; - -preprocess :: FLAGS -> String -> String -> String -> IO (); -preprocess flags srcName dstName globalDefs = - bracket (openFile srcName ReadMode) - (\ srcHandle -> hClose srcHandle) - (\ srcHandle -> - bracket (openFile dstName WriteMode) - (\ dstHandle -> hClose dstHandle) - (\ dstHandle -> - preprocessPIPE flags srcName srcHandle dstHandle globalDefs)); - - -preprocessPIPE :: FLAGS -> String -> Handle -> Handle -> String -> IO (); -preprocessPIPE flags srcName srcHandle dstHandle globalDefs = do { - input <- hGetContents srcHandle; - let { parsing = parse WASHParser.washfile srcName input }; - case parsing of { - Left error -> ioError $ userError $ show error; - Right washfile -> - hPutStrLn dstHandle (postprocess $ file flags globalDefs washfile ""); - }; -}; - -file :: FLAGS -> String -> [CodeFrag] -> ShowS ; -file flags globalDefs fcode = - WASHExpression.code flags (WASHClean.cleanCodeFragList fcode) . - showString globalDefs . - showString "\n" - ; - -imports :: [String] -> String ; -imports is = concat $ map (\m -> "import " ++ m ++ ";\n") is ; - -postprocess :: String -> String ; -postprocess = unlines . postprocess' . lines ; - -postprocess' :: [String] -> [String] ; -postprocess' [] = [] ; -postprocess' xs'@(x:xs) = - if "import" `isPrefixOf` x - then "import qualified CGI" : xs' - else x : postprocess' xs ; - -} diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHMain.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHMain.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHMain.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Main where - --- ghc --make WASHMain -package text -o WASHMain - -import System.IO -import Data.List -import System -import WASHGenerator -import WASHFlags - -main = - do args <- getArgs - runPreprocessor flags0 args - -runPreprocessor flags [washfile] = - if ".wash" `isSuffixOf` washfile - then - preprocess flags washfile (take (length washfile - 5) washfile ++ ".hs") "" - else - preprocess flags - (washfile ++ ".wash") - (washfile ++ ".hs") - "" -runPreprocessor flags [washfile, hsfile] = - preprocess flags (washfile) (hsfile) "" -runPreprocessor flags [originalFile, washfile, hsfile] = - preprocess flags (washfile) (hsfile) "" -runPreprocessor flags [] = - preprocessPIPE flags "" stdin stdout "" -runPreprocessor flags args = - do progName <- getProgName - hPutStrLn stderr ("Usage: " ++ progName ++ " washfile [hsfile]") - hPutStrLn stderr (" or: " ++ progName ++ " originalFile infile outfile") - hPutStrLn stderr (" or: " ++ progName) - hPutStrLn stderr (" to run as pipe processor") - hPutStrLn stderr ("Actual arguments: " ++ show args) diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHOut.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHOut.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHOut.hs +++ /dev/null @@ -1,30 +0,0 @@ -module WASHOut where - --- output monad - -data Out a = Out a ShowS - -instance Monad Out where - return a = Out a id - m >>= f = case m of - Out x shw1 -> - case f x of - Out y shw2 -> - Out y (shw1 . shw2) - -runOut :: Out a -> ShowS -runOut (Out a shw) = shw - -wrapper = (Out () .) - -outString :: String -> Out () -outString = wrapper showString - -outChar :: Char -> Out () -outChar = wrapper showChar - -outs :: Show a => a -> Out () -outs = wrapper shows - -outShowS :: ShowS -> Out () -outShowS = Out () diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHParser.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHParser.hs deleted file mode 100644 --- a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHParser.hs +++ /dev/null @@ -1,541 +0,0 @@ -module WASHParser ( xmlfile, washfile ) where { - -import Data.Char ; -import Parsec hiding (letter) ; -import WASHData; -import WASHUtil; - - -notImplemented = char '\xff' >> return undefined - "something that isn't implemented yet"; - -f <$> p = do { x <- p; return $ f x; }; - -testParser p s = - case parse (do { x <- p; eof; return x; }) "bla" s of { - Left x -> print x; - Right y -> print y; - }; - -washfile :: Parser [CodeFrag] ; -washfile = - do code <- hBody - eof - return $ code - ; - -setMode :: Bool -> Mode ; -setMode toplevel = if toplevel then S else F ; - --- The numbers given for each parser identify the section and --- grammar production within the XML 1.0 definition (W3C --- REC-xml-19980210). - - --- 2.1 / 1 -xmlfile :: Parser File; -xmlfile = do { - prolog; - code <- option [] (do { - hs <- haskell; - s0; - return hs - }); - elem <- element True; - many misc; - eof; - return $ File { fcode = code, topElem = elem }; -}; - - --- 2.2 / 2 -char' = (char '\t' <|> char '\n' <|> char '\r' <|> - satisfy (>= ' ')) "character"; - - --- 2.3 / 3 -s = (try $ many1 (char ' ' <|> char '\t' <|> - char '\r' <|> char '\n')) "whitespace"; -s0 = option "" s; -{- -s0 = (try $ many (char ' ' <|> char '\t' <|> - char '\r' <|> char '\n')) "optional whitespace"; --} - --- 2.3 / 4 -nameChar = letter <|> digit <|> char '.' <|> char '-' <|> - char '_' <|> char ':' <|> combiningChar <|> extender; - - --- 2.3 / 5 -name :: Parser String; -name = do { - c <- letter <|> char '_' <|> char ':'; - cs <- many nameChar; - return $ c:cs; -} "name"; - - --- 2.3 / 6 -names :: Parser [String]; -names = sepBy1 name s; - - --- 2.3 / 7 -nmtoken :: Parser String; -nmtoken = many1 nameChar "nmtoken"; - - --- 2.3 / 8 -nmtokens :: Parser [String]; -nmtokens = sepBy1 name s; - - --- 2.3 / 10 -attValue :: Parser AttrValue; -attValue = (((AText . concat) <$> ( - between (char '\"') (char '\"') (many (p '\"')) - <|> between (char '\'') (char '\'') (many (p '\'')) )) - <|> ACode <$> haskellAttr) "attvalue" -where { - p end = (\x -> [x]) <$> satisfy (f end) <|> reference; - f end = \c -> c /= '<' && c /= '&' && c /= end; -}; - --- 2.3 / 11 -systemLiteral = do{ - char '\''; - sl <- many (satisfy (\c -> c /= '\'')); - char '\''; - return sl; -} <|> do{ - char '\"'; - sl <- many (satisfy (\c -> c /= '\"')); - char '\"'; - return sl; -}; - --- 2.3 / 12 -pubidLiteral = do { - char '\''; - sl <- many (pubidChar False); - char '\''; - return sl; -} <|> do{ - char '\"'; - sl <- many (pubidChar True); - char '\"'; - return sl; -}; - --- 2.3 / 13 -pubidChar w = satisfy (\c -> c >= 'A' && c <= 'Z' - || c >= 'a' && c <= 'z' - || c >= '0' && c <= '9' - || c `elem` " \n\r-()+,./:=?;!*#@$_%" - || w && c == '\''); - --- 2.4 / 14 -charData :: Bool -> Parser Text; -charData toplevel = - do { s <- many1 charData'; return $ Text (setMode toplevel) $ concat s; } - "#PCDATA"; - -charData' :: Parser String; -charData' = do { - c <- satisfy f; - return [c]; -} <|> do { - string "]]"; - c <- satisfy (\c -> f c && c /= '>'); - return $ ']':']':[c]; -} -where { - f c = c /= '<' && c /= '&' && c /= ']'; -}; - - --- 2.5 / 15 -comment :: Parser String; -comment = do { - try $ string "