packages feed

hackport 0.2.18 → 0.2.19

raw patch · 511 files changed

+38996/−35549 lines, 511 filesdep +MissingHdep +deepseqdep +time

Dependencies added: MissingH, deepseq, time

Files

− .gitignore 
@@ -1,1 +0,0 @@-dist/
Merge/Dependencies.hs view
@@ -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"))
Portage/EBuild.hs view
@@ -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
Portage/GHCCore.hs view
@@ -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
− cabal/.darcs-boring 
@@ -1,6 +0,0 @@-^dist(/|$)-^setup(/|$)-^GNUmakefile$-^Makefile.local$-^.depend(.bak)?$-^doc/.depend(.bak)?$
+ cabal/Cabal/Cabal.cabal view
@@ -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 <ijones@syntaxpolice.org>+        Duncan Coutts <duncan@community.haskell.org>+Maintainer: cabal-devel@haskell.org+Homepage: http://www.haskell.org/cabal/+bug-reports: https://github.com/haskell/cabal/issues+Synopsis: A framework for packaging Haskell software+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
+ cabal/Cabal/DefaultSetup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/Cabal/Distribution/Compat/CopyFile.hs view
@@ -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
+ cabal/Cabal/Distribution/Compat/Exception.hs view
@@ -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+
+ cabal/Cabal/Distribution/Compat/ReadP.hs view
@@ -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/+-- (<http://www.cs.chalmers.se/~koen/publications.html>).+--+-- This version of ReadP has been locally hacked to make it H98, by+-- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>+--+-- The unit tests have been moved to UnitTest.Distribution.Compat.ReadP, by+-- Mark Lentczner <mailto:mark@glyphic.com>+-----------------------------------------------------------------------------++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']))+++
+ cabal/Cabal/Distribution/Compat/TempFile.hs view
@@ -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
+ cabal/Cabal/Distribution/Compiler.hs view
@@ -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
+ cabal/Cabal/Distribution/GetOpt.hs view
@@ -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 <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small+changes Dec. 1997)++Two rather obscure features are missing: The Bash 2.0 non-option hack+(if you don't already know it, you probably don't want to hear about+it...) and the recognition of long options with a single dash+(e.g. '-help' is recognised as '--help', as long as there is no short+option 'h').++Other differences between GNU's getopt and this implementation:++* To enforce a coherent description of options and arguments, there+  are explanation fields in the option/argument descriptor.++* Error messages are now more informative, but no longer POSIX+  compliant... :-(++And a final Haskell advertisement: The GNU C implementation uses well+over 1100 lines, we need only 195 here, including a 46 line example!+:-)+-}++-- #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..."++-}
+ cabal/Cabal/Distribution/InstalledPackageInfo.hs view
@@ -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})+ ]
+ cabal/Cabal/Distribution/License.hs view
@@ -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 <http://www.opensource.org/>.+--+-- 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
+ cabal/Cabal/Distribution/Make.hs view
@@ -0,0 +1,213 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Make+-- Copyright   :  Martin Sj&#xF6;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"]
+ cabal/Cabal/Distribution/ModuleName.hs view
@@ -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
+ cabal/Cabal/Distribution/Package.hs view
@@ -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]
+ cabal/Cabal/Distribution/PackageDescription.hs view
@@ -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)
+ cabal/Cabal/Distribution/PackageDescription/Check.hs view
@@ -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) ]
+ cabal/Cabal/Distribution/PackageDescription/Configuration.hs view
@@ -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."
+ cabal/Cabal/Distribution/PackageDescription/Parse.hs view
@@ -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."
+ cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs view
@@ -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+++
+ cabal/Cabal/Distribution/ParseUtils.hs view
@@ -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 @<property>: <value>@ field+    | Section LineNo String String [Field]+      -- ^ A section with a name and possible parameter.  The syntactic+      -- structure is:+      --+      -- @+      --   <sectionname> <arg> {+      --     <field>*+      --   }+      -- @+    | IfBlock LineNo String [Field] [Field]+      -- ^ A conditional block with an optional else branch:+      --+      -- @+      --  if <condition> {+      --    <field>*+      --  } else {+      --    <field>*+      --  }+      -- @+      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''
+ cabal/Cabal/Distribution/ReadE.hs view
@@ -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
+ cabal/Cabal/Distribution/Simple.hs view
@@ -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)
+ cabal/Cabal/Distribution/Simple/Bench.hs view
@@ -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)]
+ cabal/Cabal/Distribution/Simple/Build.hs view
@@ -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_<pkg>.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)
+ cabal/Cabal/Distribution/Simple/Build/Macros.hs view
@@ -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_<package>+-- > MIN_VERSION_<package>(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+
+ cabal/Cabal/Distribution/Simple/Build/PathsModule.hs view
@@ -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_<pkg>.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")
+ cabal/Cabal/Distribution/Simple/BuildPaths.hs view
@@ -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<packagename>-<compilerFlavour><compilerVersion>+-- 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"
+ cabal/Cabal/Distribution/Simple/Command.hs view
@@ -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]
+ cabal/Cabal/Distribution/Simple/Compiler.hs view
@@ -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)
+ cabal/Cabal/Distribution/Simple/Configure.hs view
@@ -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)
+ cabal/Cabal/Distribution/Simple/GHC.hs view
@@ -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)
+ cabal/Cabal/Distribution/Simple/GHC/IPI641.hs view
@@ -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+  }
+ cabal/Cabal/Distribution/Simple/GHC/IPI642.hs view
@@ -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+  }
+ cabal/Cabal/Distribution/Simple/Haddock.hs view
@@ -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
+ cabal/Cabal/Distribution/Simple/Hpc.hs view
@@ -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"
+ cabal/Cabal/Distribution/Simple/Hugs.hs view
@@ -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 \<copy-prefix>\/lib\/hugs\/packages\/\<pkgname>+-- (i.e. \<prefix>\/lib\/hugs\/packages\/\<pkgname> on the target system).+-- Each executable goes in \<copy-prefix>\/lib\/hugs\/programs\/\<exename>+-- (i.e. \<prefix>\/lib\/hugs\/programs\/\<exename> on the target system)+-- with a script \<copy-prefix>\/bin\/\<exename> pointing at+-- \<prefix>\/lib\/hugs\/programs\/\<exename>.+install+    :: Verbosity -- ^verbosity+    -> LocalBuildInfo+    -> FilePath  -- ^Library install location+    -> FilePath  -- ^Program install location+    -> FilePath  -- ^Executable install location+    -> FilePath  -- ^Program location on target system+    -> FilePath  -- ^Build location+    -> (FilePath,FilePath)  -- ^Executable (prefix,suffix)+    -> PackageDescription+    -> IO ()+--FIXME: this script should be generated at build time, just installed at this stage+install verbosity lbi libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do+    removeDirectoryRecursive libDir `catchIO` \_ -> return ()+    withLib pkg_descr $ \ lib ->+      findModuleFiles [buildPref] hugsInstallSuffixes (libModules lib)+        >>= installOrdinaryFiles verbosity libDir+    let buildProgDir = buildPref </> "programs"+    when (any (buildable . buildInfo) (executables pkg_descr)) $+        createDirectoryIfMissingVerbose verbosity True binDir+    withExe pkg_descr $ \ exe -> do+        let bi = buildInfo exe+        let theBuildDir = buildProgDir </> exeName exe+        let installDir = installProgDir </> exeName exe+        let targetDir = targetProgDir </> exeName exe+        removeDirectoryRecursive installDir `catchIO` \_ -> return ()+        findModuleFiles [theBuildDir] hugsInstallSuffixes+                        (ModuleName.main : autogenModuleName pkg_descr+                                         : otherModules (buildInfo exe))+          >>= installOrdinaryFiles verbosity installDir+        let targetName = "\"" ++ (targetDir </> hugsMainFilename exe) ++ "\""+        let hugsOptions = hcOptions Hugs (buildInfo exe)+                       ++ languageToFlags (compiler lbi) (defaultLanguage bi)+                       ++ extensionsToFlags (compiler lbi) (allExtensions bi)+            --TODO: also need to consider options, extensions etc of deps+            --      see ticket #43+        let baseExeFile = progprefix ++ (exeName exe) ++ progsuffix+        let exeFile = case buildOS of+                          Windows -> binDir </> baseExeFile <.> ".bat"+                          _       -> binDir </> baseExeFile+        let script = case buildOS of+                         Windows ->+                             let args = hugsOptions ++ [targetName, "%*"]+                             in unlines ["@echo off",+                                         unwords ("runhugs" : args)]+                         _ ->+                             let args = hugsOptions ++ [targetName, "\"$@\""]+                             in unlines ["#! /bin/sh",+                                         unwords ("runhugs" : args)]+        writeFileAtomic exeFile (BS.Char8.pack script)+        setFileExecutable exeFile++hugsInstallSuffixes :: [String]+hugsInstallSuffixes = [".hs", ".lhs", dllExtension]++-- |Filename used by Hugs for the main module of an executable.+-- This is a simple filename, so that Hugs will look for any auxiliary+-- modules it uses relative to the directory it's in.+hugsMainFilename :: Executable -> FilePath+hugsMainFilename exe = "Main" <.> ext+  where ext = takeExtension (modulePath exe)++-- -----------------------------------------------------------------------------+-- Registering++registerPackage+  :: Verbosity+  -> InstalledPackageInfo+  -> PackageDescription+  -> LocalBuildInfo+  -> Bool+  -> PackageDBStack+  -> IO ()+registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do+  --TODO: prefer to have it based on the packageDbs, but how do we know+  -- the package subdir based on the name? the user can set crazy libsubdir+  let installDirs = absoluteInstallDirs pkg lbi NoCopyDest+      pkgdir  | inplace   = buildDir lbi+              | otherwise = libdir installDirs+  createDirectoryIfMissingVerbose verbosity True pkgdir+  writeUTF8File (pkgdir </> "package.conf")+                (showInstalledPackageInfo installedPkgInfo)
+ cabal/Cabal/Distribution/Simple/Install.hs view
@@ -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?"
+ cabal/Cabal/Distribution/Simple/InstallDirs.hs view
@@ -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
+ cabal/Cabal/Distribution/Simple/JHC.hs view
@@ -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)
+ cabal/Cabal/Distribution/Simple/LHC.hs view
@@ -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 <ldLibName>.tmp, and any existing file+            -- named <ldLibName> is included when linking. The+            -- output is renamed to <libName>.+          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)
+ cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs view
@@ -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))
+ cabal/Cabal/Distribution/Simple/NHC.hs view
@@ -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)
+ cabal/Cabal/Distribution/Simple/PackageIndex.hs view
@@ -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 ]
+ cabal/Cabal/Distribution/Simple/PreProcess.hs view
@@ -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)+  ]
+ cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs view
@@ -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"
+ cabal/Cabal/Distribution/Simple/Program.hs view
@@ -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
+ cabal/Cabal/Distribution/Simple/Program/Ar.hs view
@@ -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"]
+ cabal/Cabal/Distribution/Simple/Program/Builtin.hs view
@@ -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+  }
+ cabal/Cabal/Distribution/Simple/Program/Db.hs view
@@ -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
+ cabal/Cabal/Distribution/Simple/Program/GHC.hs view
@@ -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
+ cabal/Cabal/Distribution/Simple/Program/HcPkg.hs view
@@ -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] [])
+ cabal/Cabal/Distribution/Simple/Program/Hpc.hs view
@@ -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 ]+        ]
+ cabal/Cabal/Distribution/Simple/Program/Ld.hs view
@@ -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
+ cabal/Cabal/Distribution/Simple/Program/Run.hs view
@@ -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
+ cabal/Cabal/Distribution/Simple/Program/Script.hs view
@@ -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
+ cabal/Cabal/Distribution/Simple/Program/Types.hs view
@@ -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+  }
+ cabal/Cabal/Distribution/Simple/Register.hs view
@@ -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"
+ cabal/Cabal/Distribution/Simple/Setup.hs view
@@ -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+-- <http://www.haskell.org/pipermail/cabal-devel/2007-December/001509.html>+-- 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?+-}
+ cabal/Cabal/Distribution/Simple/SrcDist.hs view
@@ -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) }
+ cabal/Cabal/Distribution/Simple/Test.hs view
@@ -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+
+ cabal/Cabal/Distribution/Simple/UHC.hs view
@@ -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)
+ cabal/Cabal/Distribution/Simple/UserHooks.hs view
@@ -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 ()
+ cabal/Cabal/Distribution/Simple/Utils.hs view
@@ -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 -- ^<pkgname>.cabal+findPackageDesc dir+ = do files <- getDirectoryContents dir+      -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal+      -- file we filter to exclude dirs and null base file names:+      cabalFiles <- filterM doesFileExist+                       [ 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 <pkgname>.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
+ cabal/Cabal/Distribution/System.hs view
@@ -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
+ cabal/Cabal/Distribution/TestSuite.hs view
@@ -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 }
+ cabal/Cabal/Distribution/Text.hs view
@@ -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))
+ cabal/Cabal/Distribution/Verbosity.hs view
@@ -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
+ cabal/Cabal/Distribution/Version.hs view
@@ -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) ]
+ cabal/Cabal/LICENSE view
@@ -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.
+ cabal/Cabal/Language/Haskell/Extension.hs view
@@ -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.+  -- <http://haskell.org/onlinereport/>+     Haskell98++  -- | The Haskell 2010 language as defined by the Haskell 2010 report.+  -- <http://www.haskell.org/onlinereport/haskell2010>+  | 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 &#xa7; 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 &#xa7; 7.6.3.4] Allow overlapping class instances,+  -- provided there is a unique most specific instance for each use.+    OverlappingInstances++  -- | [GHC &#xa7; 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 &#xa7; 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 &#xa7; 7.3.8] Allows recursive bindings in @do@ blocks,+  -- using the @rec@ keyword.+  | DoRec++  -- | [GHC &#xa7; 7.3.8.2] Deprecated in GHC.  Allows recursive bindings+  -- using @mdo@, a variant of @do@.  @DoRec@ provides a different,+  -- preferred syntax.+  | RecursiveDo++  -- | [GHC &#xa7; 7.3.9] Provide syntax for writing list+  -- comprehensions which iterate over several lists together, like+  -- the 'zipWith' family of functions.+  | ParallelListComp++  -- | [GHC &#xa7; 7.6.1.1] Allow multiple parameters in a type class.+  | MultiParamTypeClasses++  -- | [GHC &#xa7; 7.17] Enable the dreaded monomorphism restriction.+  | MonomorphismRestriction++  -- | [GHC &#xa7; 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 &#xa7; 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 &#xa7; 7.8.5] Allow a universally-quantified type to occur on+  -- the left of a function arrow.+  | RankNTypes++  -- | [GHC &#xa7; 7.8.5] Allow data constructors to have polymorphic+  -- arguments.  Unlike 'RankNTypes', does not allow this for ordinary+  -- functions.+  | PolymorphicComponents++  -- | [GHC &#xa7; 7.4.4] Allow existentially-quantified data constructors.+  | ExistentialQuantification++  -- | [GHC &#xa7; 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 &#xa7; 7.8.3] Enable implicit function parameters with dynamic+  -- scope.+  | ImplicitParams++  -- | [GHC &#xa7; 7.8.2] Relax some restrictions on the form of the context+  -- of a type signature.+  | FlexibleContexts++  -- | [GHC &#xa7; 7.6.3.2] Relax some restrictions on the form of the+  -- context of an instance declaration.+  | FlexibleInstances++  -- | [GHC &#xa7; 7.4.1] Allow data type declarations with no constructors.+  | EmptyDataDecls++  -- | [GHC &#xa7; 4.10.3] Run the C preprocessor on Haskell source code.+  | CPP++  -- | [GHC &#xa7; 7.8.4] Allow an explicit kind signature giving the kind of+  -- types over which a type variable ranges.+  | KindSignatures++  -- | [GHC &#xa7; 7.11] Enable a form of pattern which forces evaluation+  -- before an attempted match, and a form of strict @let@/@where@+  -- binding.+  | BangPatterns++  -- | [GHC &#xa7; 7.6.3.1] Allow type synonyms in instance heads.+  | TypeSynonymInstances++  -- | [GHC &#xa7; 7.9] Enable Template Haskell, a system for compile-time+  -- metaprogramming.+  | TemplateHaskell++  -- | [GHC &#xa7; 8] Enable the Foreign Function Interface.  In GHC,+  -- implements the standard Haskell 98 Foreign Function Interface+  -- Addendum, plus some GHC-specific extensions.+  | ForeignFunctionInterface++  -- | [GHC &#xa7; 7.10] Enable arrow notation.+  | Arrows++  -- | [GHC &#xa7; 7.16] Enable generic type classes, with default instances+  -- defined in terms of the algebraic structure of a type.+  | Generics++  -- | [GHC &#xa7; 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 &#xa7; 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 &#xa7; 7.3.5] Enable a form of guard which matches a pattern and+  -- binds variables.+  | PatternGuards++  -- | [GHC &#xa7; 7.5.4] Allow a type declared with @newtype@ to use+  -- @deriving@ for any class with an instance for the underlying type.+  | GeneralizedNewtypeDeriving++  -- | [Hugs &#xa7; 7.1] Enable the \"Trex\" extensible records system.+  | ExtensibleRecords++  -- | [Hugs &#xa7; 7.2] Enable type synonyms which are transparent in+  -- some definitions and opaque elsewhere, as a way of implementing +  -- abstract datatypes.+  | RestrictedTypeSynonyms++  -- | [Hugs &#xa7; 7.3] Enable an alternate syntax for string literals,+  -- with string templating.+  | HereDocuments++  -- | [GHC &#xa7; 7.3.2] Allow the character @#@ as a postfix modifier on+  -- identifiers.  Also enables literal syntax for unboxed values.+  | MagicHash++  -- | [GHC &#xa7; 7.7] Allow data types and type synonyms which are+  -- indexed by types, i.e. ad-hoc polymorphism for types.+  | TypeFamilies++  -- | [GHC &#xa7; 7.5.2] Allow a standalone declaration which invokes the+  -- type class @deriving@ mechanism.+  | StandaloneDeriving++  -- | [GHC &#xa7; 7.3.1] Allow certain Unicode characters to stand for+  -- certain ASCII character sequences, e.g. keywords and punctuation.+  | UnicodeSyntax++  -- | [GHC &#xa7; 8.1.1] Allow the use of unboxed types as foreign types,+  -- e.g. in @foreign import@ and @foreign export@.+  | UnliftedFFITypes++  -- | [GHC &#xa7; 7.4.3] Defer validity checking of types until after+  -- expanding type synonyms, relaxing the constraints on how synonyms+  -- may be used.+  | LiberalTypeSynonyms++  -- | [GHC &#xa7; 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 &#xa7; 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 &#xa7; 7.3.14] Allow a record field name to be disambiguated+  -- by the type of the record it's in.+  | DisambiguateRecordFields++  -- | [GHC &#xa7; 7.6.4] Enable overloading of string literals using a+  -- type class, much like integer literals.+  | OverloadedStrings++  -- | [GHC &#xa7; 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 &#xa7; 7.17.2] Make pattern bindings monomorphic.+  | MonoPatBinds++  -- | [GHC &#xa7; 7.8.8] Relax the requirements on mutually-recursive+  -- polymorphic functions.+  | RelaxedPolyRec++  -- | [GHC &#xa7; 2.4.5] Allow default instantiation of polymorphic+  -- types in more situations.+  | ExtendedDefaultRules++  -- | [GHC &#xa7; 7.2.2] Enable unboxed tuples.+  | UnboxedTuples++  -- | [GHC &#xa7; 7.5.3] Enable @deriving@ for classes+  -- @Data.Typeable.Typeable@ and @Data.Generics.Data@.+  | DeriveDataTypeable++  -- | [GHC &#xa7; 7.6.1.3] Allow a class method's type to place+  -- additional constraints on a class type variable.+  | ConstrainedClassMethods++  -- | [GHC &#xa7; 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 &#xa7; 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 &#xa7; 7.3.3] Change the syntax for qualified infix+  -- operators.+  | NewQualifiedOperators++  -- | [GHC &#xa7; 7.3.12] Relax the interpretation of left operator+  -- sections to allow unary postfix operators.+  | PostfixOperators++  -- | [GHC &#xa7; 7.9.5] Enable quasi-quotation, a mechanism for defining+  -- new concrete syntax for expressions and patterns.+  | QuasiQuotes++  -- | [GHC &#xa7; 7.3.10] Enable generalized list comprehensions,+  -- supporting operations such as sorting and grouping.+  | TransformListComp++  -- | [GHC &#xa7; 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:+  -- <http://www.haskell.org/haskellwiki/HSP>. 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 &#xa7; 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 &#xa7; 7.20] Compile a module in the Safe, Safe Haskell+  -- mode -- a restricted form of the Haskell language to ensure+  -- type safety.+  | Safe++  -- | [GHC &#xa7; 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 &#xa7; 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 ]+
+ cabal/Cabal/Makefile view
@@ -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
+ cabal/Cabal/README view
@@ -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
+ cabal/Cabal/Setup.hs view
@@ -0,0 +1,10 @@+import Distribution.Simple+main :: IO ()+main = defaultMain++-- Although this looks like the Simple build type, it is in fact vital that+-- we use this Setup.hs because 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.
+ cabal/Cabal/changelog view
@@ -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 <duncan@community.haskell.org> 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 <duncan@community.haskell.org> 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 <duncan@haskell.org> 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_<package> 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 <duncan@haskell.org> June 2010+	* Fix 'register --global/--user'++1.8.0.4 Duncan Coutts <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> October 2008+	* Export a compat function to help alex and happy++1.6.0.0 Duncan Coutts <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan.coutts@worc.ox.ac.uk> 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 <duncan.coutts@worc.ox.ac.uk> 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 <duncan.coutts@worc.ox.ac.uk> Oct 2006+	* fix unlit code+	* fix escaping in register.sh++1.1.6  Duncan Coutts <duncan.coutts@worc.ox.ac.uk> 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 <duncan.coutts@worc.ox.ac.uk> 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  <ijones@syntaxpolice.org> 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  <ijones@syntaxpolice.org> 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  <ijones@syntaxpolice.org> March 11 2005+	* Released with GHC 6.4, Hugs March 2005, and nhc98 1.18+	* Some sanity checking++0.5  Isaac Jones  <ijones@syntaxpolice.org> 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  <ijones@syntaxpolice.org> 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 <something>.cabal.  In particular, we suggest+	that you name it <packagename>.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  <ijones@syntaxpolice.org> Sun Jan 16 2005+	* Unstable snapshot release+	* From now on, stable releases are even.++0.2  Isaac Jones  <ijones@syntaxpolice.org>++	* Adds more HUGS support and preprocessor support.
+ cabal/Cabal/doc/Cabal.css view
@@ -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 }
+ cabal/Cabal/doc/developing-packages.markdown view
@@ -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 <X11/Xlib.h>],,[no_x=yes])++# Build the package if we found X11 stuff+if test "$no_x" = yes+then BUILD_PACKAGE_BOOL=False+else BUILD_PACKAGE_BOOL=True+fi+AC_SUBST([BUILD_PACKAGE_BOOL])++AC_CONFIG_FILES([X11.buildinfo])+AC_OUTPUT+~~~~~~~~~~~~~~~~++Then the setup script will run the `configure` script, which checks for+the presence of the X11 libraries and substitutes for variables in the+file `X11.buildinfo.in`:++~~~~~~~~~~~~~~~~+buildable: @BUILD_PACKAGE_BOOL@+cc-options: @X_CFLAGS@+ld-options: @X_LIBS@+~~~~~~~~~~~~~~~~++This generates a file `X11.buildinfo` supplying the parameters needed by+later stages:++~~~~~~~~~~~~~~~~+buildable: True+cc-options:  -I/usr/X11R6/include+ld-options:  -L/usr/X11R6/lib+~~~~~~~~~~~~~~~~++The `configure` script also generates a header file+`include/HsX11Config.h` containing C preprocessor defines recording the+results of various tests.  This file may be included by C source files+and preprocessed Haskell source files in the package.++Note: Packages using these features will also need to list+additional files such as `configure`,+templates for `.buildinfo` files, files named+only in `.buildinfo` files, header files and+so on in the `extra-source-files` field,+to ensure that they are included in source distributions.+They should also list files and directories generated by+`configure` in the+`extra-tmp-files` field to ensure that they+are removed by `setup clean`.++## 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/
+ cabal/Cabal/doc/index.markdown view
@@ -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/
+ cabal/Cabal/doc/installing-packages.markdown view
@@ -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/
+ cabal/Cabal/doc/misc.markdown view
@@ -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+<libraries@haskell.org>. There is also a development mailing list+<cabal-devel@haskell.org>.++[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/
+ cabal/Cabal/prologue.txt view
@@ -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:+<http://www.haskell.org/cabal/>.
+ cabal/Cabal/runTests.sh view
@@ -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+
+ cabal/Cabal/tests/PackageTests.hs view
@@ -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)+
+ cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Check.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Foo.hs view
@@ -0,0 +1,4 @@+module Foo where++fooTest :: [String] -> Bool+fooTest _ = True
+ cabal/Cabal/tests/PackageTests/BenchmarkExeV10/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs view
@@ -0,0 +1,8 @@+module Main where++import Foo+import System.Exit++main :: IO ()+main | fooTest [] = exitSuccess+     | otherwise = exitFailure
+ cabal/Cabal/tests/PackageTests/BenchmarkExeV10/my.cabal view
@@ -0,0 +1,15 @@+name:           my+version:        0.1+license:        BSD3+cabal-version:  >= 1.9.2+build-type:     Simple++library+    exposed-modules:    Foo+    build-depends:      base++benchmark bench-Foo+    type:   exitcode-stdio-1.0+    hs-source-dirs: benchmarks+    main-is:    bench-Foo.hs+    build-depends: base, my
+ cabal/Cabal/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal view
@@ -0,0 +1,20 @@+name: BenchmarkOptions+version: 0.1+license: BSD3+author: Johan Tibell+stability: stable+category: PackageTests+build-type: Simple+cabal-version: >= 1.9.2++description:+    Check that Cabal passes the correct test options to test suites.++executable dummy+    main-is: test-BenchmarkOptions.hs+    build-depends: base++benchmark test-BenchmarkOptions+    main-is: test-BenchmarkOptions.hs+    type: exitcode-stdio-1.0+    build-depends: base
+ cabal/Cabal/tests/PackageTests/BenchmarkOptions/Check.hs view
@@ -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'
+ cabal/Cabal/tests/PackageTests/BenchmarkOptions/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs view
@@ -0,0 +1,11 @@+module Main where++import System.Environment ( getArgs )+import System.Exit ( exitFailure, exitSuccess )++main :: IO ()+main = do+    args <- getArgs+    if args == ["1", "2", "3"]+        then exitSuccess+        else putStrLn ("Got: " ++ show args) >> exitFailure
+ cabal/Cabal/tests/PackageTests/BenchmarkStanza/Check.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BenchmarkStanza/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BenchmarkStanza/my.cabal view
@@ -0,0 +1,19 @@+name: BenchmarkStanza+version: 0.1+license: BSD3+author: Johan Tibell+stability: stable+category: PackageTests+build-type: Simple++description:+    Check that Cabal recognizes the benchmark stanza defined below.++Library+    exposed-modules: MyLibrary+    build-depends: base++benchmark dummy+    main-is: dummy.hs+    type: exitcode-stdio-1.0+    build-depends: base
+ cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs view
@@ -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)
+ cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDeps view
@@ -0,0 +1,20 @@+name: GlobalBuildDepsNotAdditive1+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    If you specify 'base' in the global build dependencies, then define+    a library without base, it fails to find 'base' for the library.++---------------------------------------++build-depends: base++Library+    exposed-modules: MyLibrary+    build-depends: bytestring, old-time
+ cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs view
@@ -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)
+ cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDeps view
@@ -0,0 +1,20 @@+name: GlobalBuildDepsNotAdditive1+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    If you specify 'base' in the global build dependencies, then define+    an executable without base, it fails to find 'base' for the executable++---------------------------------------++build-depends: base++Executable lemon+    main-is: lemon.hs+    build-depends: bytestring, old-time
+ cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs view
@@ -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)
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal view
@@ -0,0 +1,24 @@+name: InternalLibrary0+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    Check that with 'cabal-version:' containing versions less than 1.7, we do *not*+    have the new behaviour to allow executables to refer to the library defined+    in the same module.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time++Executable lemon+    main-is: lemon.hs+    hs-source-dirs: programs+    build-depends: base, bytestring, old-time, InternalLibrary0
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs view
@@ -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)
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal view
@@ -0,0 +1,23 @@+name: InternalLibrary1+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    Check for the new (in >= 1.7.1) ability to allow executables to refer to+    the library defined in the same module.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time++Executable lemon+    main-is: lemon.hs+    hs-source-dirs: programs+    build-depends: base, bytestring, old-time, InternalLibrary1
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs view
@@ -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)+
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal view
@@ -0,0 +1,23 @@+name: InternalLibrary2+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that the internal library is preferred by ghc to+    an installed one of the same name and version.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time++Executable lemon+    main-is: lemon.hs+    hs-source-dirs: programs+    build-depends: base, bytestring, old-time, InternalLibrary2
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal view
@@ -0,0 +1,18 @@+name: InternalLibrary2+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that the internal library is preferred by ghc to+    an installed one of the same name and version.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs view
@@ -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)+
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal view
@@ -0,0 +1,23 @@+name: InternalLibrary3+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that the internal library is preferred by ghc to+    an installed one of the same name, but a *newer* version.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time++Executable lemon+    main-is: lemon.hs+    hs-source-dirs: programs+    build-depends: base, bytestring, old-time, InternalLibrary3
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal view
@@ -0,0 +1,18 @@+name: InternalLibrary3+version: 0.2+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that the internal library is preferred by ghc to+    an installed one of the same name but a *newer* version.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs view
@@ -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)+
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal view
@@ -0,0 +1,23 @@+name: InternalLibrary4+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that we can explicitly say we want InternalLibrary4-0.2+    and it will give us the *installed* version 0.2 instead of the internal 0.1.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time++Executable lemon+    main-is: lemon.hs+    hs-source-dirs: programs+    build-depends: base, bytestring, old-time, InternalLibrary4 >= 0.2
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal view
@@ -0,0 +1,18 @@+name: InternalLibrary4+version: 0.2+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that the internal library is preferred by ghc to+    an installed one of the same name but a *newer* version.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time
+ cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs view
@@ -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)
+ cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal view
@@ -0,0 +1,31 @@+name: SameDepsAllRound+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+synopsis: Same dependencies all round+category: PackageTests+build-type: Simple++description:+    Check for the "old build-dep behaviour" namely that we get the same+    package dependencies on all build targets, even if different ones+    were specified for different targets+    .+    Here all .hs files use the three packages mentioned, so this shows+    that build-depends is not target-specific.  This is the behaviour+    we want when cabal-version contains versions less than 1.7.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring++Executable lemon+    main-is: lemon.hs+    build-depends: old-time++Executable pineapple+    main-is: pineapple.hs
+ cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs view
@@ -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)
+ cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal view
@@ -0,0 +1,22 @@+name: TargetSpecificDeps1+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    Check for the new build-dep behaviour, where build-depends are+    handled specifically for each target++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring++Executable lemon+    main-is: lemon.hs+    build-depends: base, bytestring, old-time
+ cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs view
@@ -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)
+ cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs view
@@ -0,0 +1,5 @@+import qualified Data.ByteString.Char8 as C++main = do+    let text = "lemon"+    C.putStrLn $ C.pack text
+ cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal view
@@ -0,0 +1,24 @@+name: TargetSpecificDeps1+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    Check for the new build-dep behaviour, where build-depends are+    handled specifically for each target+    This one is a control against TargetSpecificDeps1 - it is correct and should+    succeed.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time++Executable lemon+    main-is: lemon.hs+    build-depends: base, bytestring
+ cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs view
@@ -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)
+ cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal view
@@ -0,0 +1,22 @@+name: test+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    Check for the new build-dep behaviour, where build-depends are+    handled specifically for each target++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time++Executable lemon+    main-is: lemon.hs+    build-depends: base, bytestring
+ cabal/Cabal/tests/PackageTests/PackageTester.hs view
@@ -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)+
+ cabal/Cabal/tests/PackageTests/TemplateHaskell/Check.hs view
@@ -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)+
+ cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Exe.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import TH++main = print $(splice)
+ cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Lib where++import TH++val = $(splice)
+ cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/TH.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}+module TH where++splice = [| () |]
+ cabal/Cabal/tests/PackageTests/TemplateHaskell/dynamic/my.cabal view
@@ -0,0 +1,15 @@+Name: templateHaskell+Version: 0.1+Build-Type: Simple+Cabal-Version: >= 1.2++Library+    Exposed-Modules: Lib+    Other-Modules: TH+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell++Executable main+    Main-is: Exe.hs+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell
+ cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Exe.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import TH++main = print $(splice)
+ cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Lib.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Lib where++import TH++val = $(splice)
+ cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/TH.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}+module TH where++splice = [| () |]
+ cabal/Cabal/tests/PackageTests/TemplateHaskell/profiling/my.cabal view
@@ -0,0 +1,15 @@+Name: templateHaskell+Version: 0.1+Build-Type: Simple+Cabal-Version: >= 1.2++Library+    Exposed-Modules: Lib+    Other-Modules: TH+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell++Executable main+    Main-is: Exe.hs+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell
+ cabal/Cabal/tests/PackageTests/TestOptions/Check.hs view
@@ -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'
+ cabal/Cabal/tests/PackageTests/TestOptions/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/TestOptions/TestOptions.cabal view
@@ -0,0 +1,20 @@+name: TestOptions+version: 0.1+license: BSD3+author: Thomas Tuegel+stability: stable+category: PackageTests+build-type: Simple+cabal-version: >= 1.9.2++description:+    Check that Cabal passes the correct test options to test suites.++executable dummy+    main-is: test-TestOptions.hs+    build-depends: base++test-suite test-TestOptions+    main-is: test-TestOptions.hs+    type: exitcode-stdio-1.0+    build-depends: base
+ cabal/Cabal/tests/PackageTests/TestOptions/test-TestOptions.hs view
@@ -0,0 +1,11 @@+module Main where++import System.Environment ( getArgs )+import System.Exit ( exitFailure, exitSuccess )++main :: IO ()+main = do+    args <- getArgs+    if args == ["1", "2", "3"]+        then exitSuccess+        else putStrLn ("Got: " ++ show args) >> exitFailure
+ cabal/Cabal/tests/PackageTests/TestStanza/Check.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/TestStanza/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/TestStanza/my.cabal view
@@ -0,0 +1,19 @@+name: TestStanza+version: 0.1+license: BSD3+author: Thomas Tuegel+stability: stable+category: PackageTests+build-type: Simple++description:+    Check that Cabal recognizes the Test stanza defined below.++Library+    exposed-modules: MyLibrary+    build-depends: base++test-suite dummy+    main-is: dummy.hs+    type: exitcode-stdio-1.0+    build-depends: base
+ cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Check.hs view
@@ -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
+ cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs view
@@ -0,0 +1,4 @@+module Foo where++fooTest :: [String] -> Bool+fooTest _ = True
+ cabal/Cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/Cabal/tests/PackageTests/TestSuiteExeV10/my.cabal view
@@ -0,0 +1,15 @@+name:           my+version:        0.1+license:        BSD3+cabal-version:  >= 1.9.2+build-type:     Simple++library+    exposed-modules:    Foo+    build-depends:      base++test-suite test-Foo+    type:   exitcode-stdio-1.0+    hs-source-dirs: tests+    main-is:    test-Foo.hs+    build-depends: base, my
+ cabal/Cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs view
@@ -0,0 +1,8 @@+module Main where++import Foo+import System.Exit++main :: IO ()+main | fooTest [] = exitSuccess+     | otherwise = exitFailure
+ cabal/Cabal/tests/UnitTests.hs view
@@ -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
+ cabal/Cabal/tests/UnitTests/Distribution/Compat/ReadP.hs view
@@ -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+
+ cabal/Cabal/tests/hackage/check.sh view
@@ -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
+ cabal/Cabal/tests/hackage/download.sh view
@@ -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
+ cabal/Cabal/tests/hackage/unpack.sh view
@@ -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
+ cabal/Cabal/tests/misc/ghc-supported-languages.hs view
@@ -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)
− cabal/IMPORTED-FROM 
@@ -1,7 +0,0 @@-http://darcs.haskell.org/cabal-branches/cabal-1.12--Fri Jul 15 15:04:46 EEST 2011  Ian Lynagh <igloo@earth.li>-  * Bump version number-    hunk ./cabal/Cabal.cabal 2-    -Version: 1.11.2-    +Version: 1.12.0
+ cabal/Paths_Cabal.hs view
@@ -0,0 +1,8 @@+module Paths_Cabal (+    version,+  ) where++import Data.Version (Version(..))++version :: Version+version = Version {versionBranch = [1,17,0], versionTags = []}
+ cabal/Paths_cabal_install.hs view
@@ -0,0 +1,8 @@+module Paths_cabal_install (+    version,+  ) where++import Data.Version (Version(..))++version :: Version+version = Version {versionBranch = [0,17,0], versionTags = []}
cabal/README view
@@ -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
cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs view
@@ -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
cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs view
@@ -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
cabal/cabal-install/Distribution/Client/BuildReports/Types.hs view
@@ -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
cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs view
@@ -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"),
cabal/cabal-install/Distribution/Client/Config.hs view
@@ -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-
cabal/cabal-install/Distribution/Client/Configure.hs view
@@ -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
cabal/cabal-install/Distribution/Client/Dependency.hs view
@@ -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
+ cabal/cabal-install/Distribution/Client/Dependency/Modular.hs view
@@ -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
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs view
@@ -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))
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs view
@@ -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
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs view
@@ -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]
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs view
@@ -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
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs view
@@ -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)
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs view
@@ -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)
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Flag.hs view
@@ -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
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Index.hs view
@@ -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)
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs view
@@ -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') [])])
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs view
@@ -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
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs view
@@ -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)"
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs view
@@ -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
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Package.hs view
@@ -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
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs view
@@ -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+
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs view
@@ -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
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs view
@@ -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
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs view
@@ -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))
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Version.hs view
@@ -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 []+
cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs view
@@ -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
cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs view
@@ -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])
cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs view
@@ -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
cabal/cabal-install/Distribution/Client/Dependency/Types.hs view
@@ -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
cabal/cabal-install/Distribution/Client/Fetch.hs view
@@ -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 ()
cabal/cabal-install/Distribution/Client/Haddock.hs view
@@ -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)
cabal/cabal-install/Distribution/Client/HttpUtils.hs view
@@ -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.
+ cabal/cabal-install/Distribution/Client/Index.hs view
@@ -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 ++ "'"
cabal/cabal-install/Distribution/Client/IndexUtils.hs view
@@ -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
cabal/cabal-install/Distribution/Client/Init.hs view
@@ -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 ()
cabal/cabal-install/Distribution/Client/Init/Heuristics.hs view
@@ -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)]
cabal/cabal-install/Distribution/Client/Init/Licenses.hs view
@@ -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."+    ]
cabal/cabal-install/Distribution/Client/Init/Types.hs view
@@ -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
cabal/cabal-install/Distribution/Client/Install.hs view
@@ -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:
cabal/cabal-install/Distribution/Client/InstallPlan.hs view
@@ -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"
cabal/cabal-install/Distribution/Client/InstallSymlink.hs view
@@ -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
+ cabal/cabal-install/Distribution/Client/JobControl.hs view
@@ -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
cabal/cabal-install/Distribution/Client/List.hs view
@@ -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
+ cabal/cabal-install/Distribution/Client/PackageEnvironment.hs view
@@ -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
cabal/cabal-install/Distribution/Client/PackageIndex.hs view
@@ -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.   --
+ cabal/cabal-install/Distribution/Client/ParseUtils.hs view
@@ -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)
+ cabal/cabal-install/Distribution/Client/Sandbox.hs view
@@ -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) }
cabal/cabal-install/Distribution/Client/Setup.hs view
@@ -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?
cabal/cabal-install/Distribution/Client/SetupWrapper.hs view
@@ -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
cabal/cabal-install/Distribution/Client/SrcDist.hs view
@@ -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"
cabal/cabal-install/Distribution/Client/Tar.hs view
@@ -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
cabal/cabal-install/Distribution/Client/Targets.hs view
@@ -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
cabal/cabal-install/Distribution/Client/Types.hs view
@@ -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
cabal/cabal-install/Distribution/Client/Update.hs view
@@ -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"-
cabal/cabal-install/Distribution/Client/Upload.hs view
@@ -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"
cabal/cabal-install/Distribution/Client/Utils.hs view
@@ -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)
cabal/cabal-install/Distribution/Client/World.hs view
@@ -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
+ cabal/cabal-install/Distribution/Compat/Time.hs view
@@ -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
cabal/cabal-install/Main.hs view
@@ -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)
− cabal/cabal-install/Paths_cabal_install.hs 
@@ -1,8 +0,0 @@-module Paths_cabal_install (-    version,-  ) where--import Data.Version (Version(..))--version :: Version-version = Version {versionBranch = [0,12,0], versionTags = []}
cabal/cabal-install/README view
@@ -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
cabal/cabal-install/bootstrap.sh view
@@ -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"
cabal/cabal-install/cabal-install.cabal view
@@ -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 <lemmih@gmail.com>@@ -19,15 +19,16 @@                     2006 Paolo Martini <paolo@nemail.it>                     2007 Bjorn Bringert <bjorn@bringert.net>                     2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>-                    2007-2011 Duncan Coutts <duncan@community.haskell.org>+                    2007-2012 Duncan Coutts <duncan@community.haskell.org> Category:           Distribution Build-type:         Simple Extra-Source-Files: README bash-completion/cabal bootstrap.sh Cabal-Version:      >= 1.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
+ cabal/cabal-install/cbits/getnumcores.c view
@@ -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 <windows.h>+#elif MACOS+#include <sys/param.h>+#include <sys/sysctl.h>+#elif __linux__+#include <unistd.h>+#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 */
cabal/cabal-install/changelog view
@@ -1,5 +1,19 @@ -*-change-log-*- +0.14.0 Andres Loeh <andres@well-typed.com> April 2012+	* Works with ghc-7.4+	* Completely new modular dependency solver (default in most cases)+	* 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 <duncan@community.haskell.org> February 2011 	* New package targets: local dirs, local and remote tarballs 	* Initial support for a "world" package target
− cabal/cabal/Cabal.cabal 
@@ -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 <ijones@syntaxpolice.org>-        Duncan Coutts <duncan@community.haskell.org>-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
− cabal/cabal/DefaultSetup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− cabal/cabal/Distribution/Compat/CopyFile.hs 
@@ -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
− cabal/cabal/Distribution/Compat/Exception.hs 
@@ -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-
− cabal/cabal/Distribution/Compat/ReadP.hs 
@@ -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/--- (<http://www.cs.chalmers.se/~koen/publications.html>).------ This version of ReadP has been locally hacked to make it H98, by--- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>-----------------------------------------------------------------------------------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--}-
− cabal/cabal/Distribution/Compat/TempFile.hs 
@@ -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
− cabal/cabal/Distribution/Compiler.hs 
@@ -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
− cabal/cabal/Distribution/GetOpt.hs 
@@ -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 <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small-changes Dec. 1997)--Two rather obscure features are missing: The Bash 2.0 non-option hack-(if you don't already know it, you probably don't want to hear about-it...) and the recognition of long options with a single dash-(e.g. '-help' is recognised as '--help', as long as there is no short-option 'h').--Other differences between GNU's getopt and this implementation:--* To enforce a coherent description of options and arguments, there-  are explanation fields in the option/argument descriptor.--* Error messages are now more informative, but no longer POSIX-  compliant... :-(--And a final Haskell advertisement: The GNU C implementation uses well-over 1100 lines, we need only 195 here, including a 46 line example!-:-)--}---- #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..."---}
− cabal/cabal/Distribution/InstalledPackageInfo.hs 
@@ -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})- ]
− cabal/cabal/Distribution/License.hs 
@@ -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 <http://www.opensource.org/>.------ 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
− cabal/cabal/Distribution/Make.hs 
@@ -1,213 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Make--- Copyright   :  Martin Sj&#xF6;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"]
− cabal/cabal/Distribution/ModuleName.hs 
@@ -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
− cabal/cabal/Distribution/Package.hs 
@@ -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]
− cabal/cabal/Distribution/PackageDescription.hs 
@@ -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)
− cabal/cabal/Distribution/PackageDescription/Check.hs 
@@ -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) ]
− cabal/cabal/Distribution/PackageDescription/Configuration.hs 
@@ -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."
− cabal/cabal/Distribution/PackageDescription/Parse.hs 
@@ -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."
− cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs 
@@ -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---
− cabal/cabal/Distribution/ParseUtils.hs 
@@ -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 @<property>: <value>@ field-    | Section LineNo String String [Field]-      -- ^ A section with a name and possible parameter.  The syntactic-      -- structure is:-      ---      -- @-      --   <sectionname> <arg> {-      --     <field>*-      --   }-      -- @-    | IfBlock LineNo String [Field] [Field]-      -- ^ A conditional block with an optional else branch:-      ---      -- @-      --  if <condition> {-      --    <field>*-      --  } else {-      --    <field>*-      --  }-      -- @-      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''
− cabal/cabal/Distribution/ReadE.hs 
@@ -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
− cabal/cabal/Distribution/Simple.hs 
@@ -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)
− cabal/cabal/Distribution/Simple/Build.hs 
@@ -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_<pkg>.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)
− cabal/cabal/Distribution/Simple/Build/Macros.hs 
@@ -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_<package>--- > MIN_VERSION_<package>(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-
− cabal/cabal/Distribution/Simple/Build/PathsModule.hs 
@@ -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_<pkg>.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")
− cabal/cabal/Distribution/Simple/BuildPaths.hs 
@@ -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<packagename>-<compilerFlavour><compilerVersion>--- 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"
− cabal/cabal/Distribution/Simple/Command.hs 
@@ -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]
− cabal/cabal/Distribution/Simple/Compiler.hs 
@@ -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)
− cabal/cabal/Distribution/Simple/Configure.hs 
@@ -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)
− cabal/cabal/Distribution/Simple/GHC.hs 
@@ -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)
− cabal/cabal/Distribution/Simple/GHC/IPI641.hs 
@@ -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-  }
− cabal/cabal/Distribution/Simple/GHC/IPI642.hs 
@@ -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-  }
− cabal/cabal/Distribution/Simple/Haddock.hs 
@@ -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
− cabal/cabal/Distribution/Simple/Hpc.hs 
@@ -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
− cabal/cabal/Distribution/Simple/Hugs.hs 
@@ -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 \<copy-prefix>\/lib\/hugs\/packages\/\<pkgname>--- (i.e. \<prefix>\/lib\/hugs\/packages\/\<pkgname> on the target system).--- Each executable goes in \<copy-prefix>\/lib\/hugs\/programs\/\<exename>--- (i.e. \<prefix>\/lib\/hugs\/programs\/\<exename> on the target system)--- with a script \<copy-prefix>\/bin\/\<exename> pointing at--- \<prefix>\/lib\/hugs\/programs\/\<exename>.-install-    :: Verbosity -- ^verbosity-    -> LocalBuildInfo-    -> FilePath  -- ^Library install location-    -> FilePath  -- ^Program install location-    -> FilePath  -- ^Executable install location-    -> FilePath  -- ^Program location on target system-    -> FilePath  -- ^Build location-    -> (FilePath,FilePath)  -- ^Executable (prefix,suffix)-    -> PackageDescription-    -> IO ()---FIXME: this script should be generated at build time, just installed at this stage-install verbosity lbi libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do-    removeDirectoryRecursive libDir `catchIO` \_ -> return ()-    withLib pkg_descr $ \ lib ->-      findModuleFiles [buildPref] hugsInstallSuffixes (libModules lib)-        >>= installOrdinaryFiles verbosity libDir-    let buildProgDir = buildPref </> "programs"-    when (any (buildable . buildInfo) (executables pkg_descr)) $-        createDirectoryIfMissingVerbose verbosity True binDir-    withExe pkg_descr $ \ exe -> do-        let bi = buildInfo exe-        let theBuildDir = buildProgDir </> exeName exe-        let installDir = installProgDir </> exeName exe-        let targetDir = targetProgDir </> exeName exe-        removeDirectoryRecursive installDir `catchIO` \_ -> return ()-        findModuleFiles [theBuildDir] hugsInstallSuffixes-                        (ModuleName.main : autogenModuleName pkg_descr-                                         : otherModules (buildInfo exe))-          >>= installOrdinaryFiles verbosity installDir-        let targetName = "\"" ++ (targetDir </> hugsMainFilename exe) ++ "\""-        let hugsOptions = hcOptions Hugs (buildInfo exe)-                       ++ languageToFlags (compiler lbi) (defaultLanguage bi)-                       ++ extensionsToFlags (compiler lbi) (allExtensions bi)-            --TODO: also need to consider options, extensions etc of deps-            --      see ticket #43-        let baseExeFile = progprefix ++ (exeName exe) ++ progsuffix-        let exeFile = case buildOS of-                          Windows -> binDir </> baseExeFile <.> ".bat"-                          _       -> binDir </> baseExeFile-        let script = case buildOS of-                         Windows ->-                             let args = hugsOptions ++ [targetName, "%*"]-                             in unlines ["@echo off",-                                         unwords ("runhugs" : args)]-                         _ ->-                             let args = hugsOptions ++ [targetName, "\"$@\""]-                             in unlines ["#! /bin/sh",-                                         unwords ("runhugs" : args)]-        writeFileAtomic exeFile script-        setFileExecutable exeFile--hugsInstallSuffixes :: [String]-hugsInstallSuffixes = [".hs", ".lhs", dllExtension]---- |Filename used by Hugs for the main module of an executable.--- This is a simple filename, so that Hugs will look for any auxiliary--- modules it uses relative to the directory it's in.-hugsMainFilename :: Executable -> FilePath-hugsMainFilename exe = "Main" <.> ext-  where ext = takeExtension (modulePath exe)---- -------------------------------------------------------------------------------- Registering--registerPackage-  :: Verbosity-  -> InstalledPackageInfo-  -> PackageDescription-  -> LocalBuildInfo-  -> Bool-  -> PackageDBStack-  -> IO ()-registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do-  --TODO: prefer to have it based on the packageDbs, but how do we know-  -- the package subdir based on the name? the user can set crazy libsubdir-  let installDirs = absoluteInstallDirs pkg lbi NoCopyDest-      pkgdir  | inplace   = buildDir lbi-              | otherwise = libdir installDirs-  createDirectoryIfMissingVerbose verbosity True pkgdir-  writeUTF8File (pkgdir </> "package.conf")-                (showInstalledPackageInfo installedPkgInfo)
− cabal/cabal/Distribution/Simple/Install.hs 
@@ -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?"
− cabal/cabal/Distribution/Simple/InstallDirs.hs 
@@ -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
− cabal/cabal/Distribution/Simple/JHC.hs 
@@ -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)-
− cabal/cabal/Distribution/Simple/LHC.hs 
@@ -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 <ldLibName>.tmp, and any existing file-            -- named <ldLibName> is included when linking. The-            -- output is renamed to <libName>.-          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)
− cabal/cabal/Distribution/Simple/LocalBuildInfo.hs 
@@ -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))
− cabal/cabal/Distribution/Simple/NHC.hs 
@@ -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)
− cabal/cabal/Distribution/Simple/PackageIndex.hs 
@@ -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 ]
− cabal/cabal/Distribution/Simple/PreProcess.hs 
@@ -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)-  ]
− cabal/cabal/Distribution/Simple/PreProcess/Unlit.hs 
@@ -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"
− cabal/cabal/Distribution/Simple/Program.hs 
@@ -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
− cabal/cabal/Distribution/Simple/Program/Ar.hs 
@@ -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"]
− cabal/cabal/Distribution/Simple/Program/Builtin.hs 
@@ -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-  }
− cabal/cabal/Distribution/Simple/Program/Db.hs 
@@ -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
− cabal/cabal/Distribution/Simple/Program/HcPkg.hs 
@@ -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] [])
− cabal/cabal/Distribution/Simple/Program/Ld.hs 
@@ -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
− cabal/cabal/Distribution/Simple/Program/Run.hs 
@@ -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
− cabal/cabal/Distribution/Simple/Program/Script.hs 
@@ -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
− cabal/cabal/Distribution/Simple/Program/Types.hs 
@@ -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 []-  }-
− cabal/cabal/Distribution/Simple/Register.hs 
@@ -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"
− cabal/cabal/Distribution/Simple/Setup.hs 
@@ -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--- <http://www.haskell.org/pipermail/cabal-devel/2007-December/001509.html>--- 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?--}
− cabal/cabal/Distribution/Simple/SrcDist.hs 
@@ -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) }
− cabal/cabal/Distribution/Simple/Test.hs 
@@ -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
− cabal/cabal/Distribution/Simple/UHC.hs 
@@ -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)
− cabal/cabal/Distribution/Simple/UserHooks.hs 
@@ -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 ()
− cabal/cabal/Distribution/Simple/Utils.hs 
@@ -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 -- ^<pkgname>.cabal-findPackageDesc dir- = do files <- getDirectoryContents dir-      -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal-      -- file we filter to exclude dirs and null base file names:-      cabalFiles <- filterM doesFileExist-                       [ 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 <pkgname>.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
− cabal/cabal/Distribution/System.hs 
@@ -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
− cabal/cabal/Distribution/TestSuite.hs 
@@ -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--- >                 }
− cabal/cabal/Distribution/Text.hs 
@@ -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))
− cabal/cabal/Distribution/Verbosity.hs 
@@ -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
− cabal/cabal/Distribution/Version.hs 
@@ -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) ]
− cabal/cabal/LICENSE 
@@ -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.
− cabal/cabal/Language/Haskell/Extension.hs 
@@ -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.-  -- <http://haskell.org/onlinereport/>-     Haskell98--  -- | The Haskell 2010 language as defined by the Haskell 2010 report.-  -- <http://www.haskell.org/onlinereport/haskell2010>-  | 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 &#xa7; 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 &#xa7; 7.6.3.4] Allow overlapping class instances,-  -- provided there is a unique most specific instance for each use.-    OverlappingInstances--  -- | [GHC &#xa7; 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 &#xa7; 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 &#xa7; 7.3.8] Allows recursive bindings in @do@ blocks,-  -- using the @rec@ keyword.-  | DoRec--  -- | [GHC &#xa7; 7.3.8.2] Deprecated in GHC.  Allows recursive bindings-  -- using @mdo@, a variant of @do@.  @DoRec@ provides a different,-  -- preferred syntax.-  | RecursiveDo--  -- | [GHC &#xa7; 7.3.9] Provide syntax for writing list-  -- comprehensions which iterate over several lists together, like-  -- the 'zipWith' family of functions.-  | ParallelListComp--  -- | [GHC &#xa7; 7.6.1.1] Allow multiple parameters in a type class.-  | MultiParamTypeClasses--  -- | [GHC &#xa7; 7.17] Enable the dreaded monomorphism restriction.-  | MonomorphismRestriction--  -- | [GHC &#xa7; 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 &#xa7; 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 &#xa7; 7.8.5] Allow a universally-quantified type to occur on-  -- the left of a function arrow.-  | RankNTypes--  -- | [GHC &#xa7; 7.8.5] Allow data constructors to have polymorphic-  -- arguments.  Unlike 'RankNTypes', does not allow this for ordinary-  -- functions.-  | PolymorphicComponents--  -- | [GHC &#xa7; 7.4.4] Allow existentially-quantified data constructors.-  | ExistentialQuantification--  -- | [GHC &#xa7; 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 &#xa7; 7.8.3] Enable implicit function parameters with dynamic-  -- scope.-  | ImplicitParams--  -- | [GHC &#xa7; 7.8.2] Relax some restrictions on the form of the context-  -- of a type signature.-  | FlexibleContexts--  -- | [GHC &#xa7; 7.6.3.2] Relax some restrictions on the form of the-  -- context of an instance declaration.-  | FlexibleInstances--  -- | [GHC &#xa7; 7.4.1] Allow data type declarations with no constructors.-  | EmptyDataDecls--  -- | [GHC &#xa7; 4.10.3] Run the C preprocessor on Haskell source code.-  | CPP--  -- | [GHC &#xa7; 7.8.4] Allow an explicit kind signature giving the kind of-  -- types over which a type variable ranges.-  | KindSignatures--  -- | [GHC &#xa7; 7.11] Enable a form of pattern which forces evaluation-  -- before an attempted match, and a form of strict @let@/@where@-  -- binding.-  | BangPatterns--  -- | [GHC &#xa7; 7.6.3.1] Allow type synonyms in instance heads.-  | TypeSynonymInstances--  -- | [GHC &#xa7; 7.9] Enable Template Haskell, a system for compile-time-  -- metaprogramming.-  | TemplateHaskell--  -- | [GHC &#xa7; 8] Enable the Foreign Function Interface.  In GHC,-  -- implements the standard Haskell 98 Foreign Function Interface-  -- Addendum, plus some GHC-specific extensions.-  | ForeignFunctionInterface--  -- | [GHC &#xa7; 7.10] Enable arrow notation.-  | Arrows--  -- | [GHC &#xa7; 7.16] Enable generic type classes, with default instances-  -- defined in terms of the algebraic structure of a type.-  | Generics--  -- | [GHC &#xa7; 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 &#xa7; 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 &#xa7; 7.3.5] Enable a form of guard which matches a pattern and-  -- binds variables.-  | PatternGuards--  -- | [GHC &#xa7; 7.5.4] Allow a type declared with @newtype@ to use-  -- @deriving@ for any class with an instance for the underlying type.-  | GeneralizedNewtypeDeriving--  -- | [Hugs &#xa7; 7.1] Enable the \"Trex\" extensible records system.-  | ExtensibleRecords--  -- | [Hugs &#xa7; 7.2] Enable type synonyms which are transparent in-  -- some definitions and opaque elsewhere, as a way of implementing -  -- abstract datatypes.-  | RestrictedTypeSynonyms--  -- | [Hugs &#xa7; 7.3] Enable an alternate syntax for string literals,-  -- with string templating.-  | HereDocuments--  -- | [GHC &#xa7; 7.3.2] Allow the character @#@ as a postfix modifier on-  -- identifiers.  Also enables literal syntax for unboxed values.-  | MagicHash--  -- | [GHC &#xa7; 7.7] Allow data types and type synonyms which are-  -- indexed by types, i.e. ad-hoc polymorphism for types.-  | TypeFamilies--  -- | [GHC &#xa7; 7.5.2] Allow a standalone declaration which invokes the-  -- type class @deriving@ mechanism.-  | StandaloneDeriving--  -- | [GHC &#xa7; 7.3.1] Allow certain Unicode characters to stand for-  -- certain ASCII character sequences, e.g. keywords and punctuation.-  | UnicodeSyntax--  -- | [GHC &#xa7; 8.1.1] Allow the use of unboxed types as foreign types,-  -- e.g. in @foreign import@ and @foreign export@.-  | UnliftedFFITypes--  -- | [GHC &#xa7; 7.4.3] Defer validity checking of types until after-  -- expanding type synonyms, relaxing the constraints on how synonyms-  -- may be used.-  | LiberalTypeSynonyms--  -- | [GHC &#xa7; 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 &#xa7; 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 &#xa7; 7.3.14] Allow a record field name to be disambiguated-  -- by the type of the record it's in.-  | DisambiguateRecordFields--  -- | [GHC &#xa7; 7.6.4] Enable overloading of string literals using a-  -- type class, much like integer literals.-  | OverloadedStrings--  -- | [GHC &#xa7; 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 &#xa7; 7.17.2] Make pattern bindings monomorphic.-  | MonoPatBinds--  -- | [GHC &#xa7; 7.8.8] Relax the requirements on mutually-recursive-  -- polymorphic functions.-  | RelaxedPolyRec--  -- | [GHC &#xa7; 2.4.5] Allow default instantiation of polymorphic-  -- types in more situations.-  | ExtendedDefaultRules--  -- | [GHC &#xa7; 7.2.2] Enable unboxed tuples.-  | UnboxedTuples--  -- | [GHC &#xa7; 7.5.3] Enable @deriving@ for classes-  -- @Data.Typeable.Typeable@ and @Data.Generics.Data@.-  | DeriveDataTypeable--  -- | [GHC &#xa7; 7.6.1.3] Allow a class method's type to place-  -- additional constraints on a class type variable.-  | ConstrainedClassMethods--  -- | [GHC &#xa7; 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 &#xa7; 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 &#xa7; 7.3.3] Change the syntax for qualified infix-  -- operators.-  | NewQualifiedOperators--  -- | [GHC &#xa7; 7.3.12] Relax the interpretation of left operator-  -- sections to allow unary postfix operators.-  | PostfixOperators--  -- | [GHC &#xa7; 7.9.5] Enable quasi-quotation, a mechanism for defining-  -- new concrete syntax for expressions and patterns.-  | QuasiQuotes--  -- | [GHC &#xa7; 7.3.10] Enable generalized list comprehensions,-  -- supporting operations such as sorting and grouping.-  | TransformListComp--  -- | [GHC &#xa7; 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:-  -- <http://www.haskell.org/haskellwiki/HSP>. 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 ]-
− cabal/cabal/Makefile 
@@ -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
− cabal/cabal/Paths_Cabal.hs 
@@ -1,8 +0,0 @@-module Paths_Cabal (-    version,-  ) where--import Data.Version (Version(..))--version :: Version-version = Version {versionBranch = [1,12,0], versionTags = []}
− cabal/cabal/README 
@@ -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
− cabal/cabal/Setup.hs 
@@ -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.
− cabal/cabal/changelog 
@@ -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 <duncan@community.haskell.org> 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 <duncan@community.haskell.org> 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 <duncan@haskell.org> 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_<package> 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 <duncan@haskell.org> June 2010-	* Fix 'register --global/--user'--1.8.0.4 Duncan Coutts <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> October 2008-	* Export a compat function to help alex and happy--1.6.0.0 Duncan Coutts <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan.coutts@worc.ox.ac.uk> 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 <duncan.coutts@worc.ox.ac.uk> 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 <duncan.coutts@worc.ox.ac.uk> Oct 2006-	* fix unlit code-	* fix escaping in register.sh--1.1.6  Duncan Coutts <duncan.coutts@worc.ox.ac.uk> 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 <duncan.coutts@worc.ox.ac.uk> 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  <ijones@syntaxpolice.org> 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  <ijones@syntaxpolice.org> 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  <ijones@syntaxpolice.org> March 11 2005-	* Released with GHC 6.4, Hugs March 2005, and nhc98 1.18-	* Some sanity checking--0.5  Isaac Jones  <ijones@syntaxpolice.org> 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  <ijones@syntaxpolice.org> 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 <something>.cabal.  In particular, we suggest-	that you name it <packagename>.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  <ijones@syntaxpolice.org> Sun Jan 16 2005-	* Unstable snapshot release-	* From now on, stable releases are even.--0.2  Isaac Jones  <ijones@syntaxpolice.org>--	* Adds more HUGS support and preprocessor support.
− cabal/cabal/doc/Cabal.css 
@@ -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 }
− cabal/cabal/doc/developing-packages.markdown 
@@ -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 <X11/Xlib.h>],,[no_x=yes])--# Build the package if we found X11 stuff-if test "$no_x" = yes-then BUILD_PACKAGE_BOOL=False-else BUILD_PACKAGE_BOOL=True-fi-AC_SUBST([BUILD_PACKAGE_BOOL])--AC_CONFIG_FILES([X11.buildinfo])-AC_OUTPUT-~~~~~~~~~~~~~~~~--Then the setup script will run the `configure` script, which checks for-the presence of the X11 libraries and substitutes for variables in the-file `X11.buildinfo.in`:--~~~~~~~~~~~~~~~~-buildable: @BUILD_PACKAGE_BOOL@-cc-options: @X_CFLAGS@-ld-options: @X_LIBS@-~~~~~~~~~~~~~~~~--This generates a file `X11.buildinfo` supplying the parameters needed by-later stages:--~~~~~~~~~~~~~~~~-buildable: True-cc-options:  -I/usr/X11R6/include-ld-options:  -L/usr/X11R6/lib-~~~~~~~~~~~~~~~~--The `configure` script also generates a header file-`include/HsX11Config.h` containing C preprocessor defines recording the-results of various tests.  This file may be included by C source files-and preprocessed Haskell source files in the package.--Note: Packages using these features will also need to list-additional files such as `configure`,-templates for `.buildinfo` files, files named-only in `.buildinfo` files, header files and-so on in the `extra-source-files` field,-to ensure that they are included in source distributions.-They should also list files and directories generated by-`configure` in the-`extra-tmp-files` field to ensure that they-are removed by `setup clean`.--## 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/
− cabal/cabal/doc/index.markdown 
@@ -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/
− cabal/cabal/doc/installing-packages.markdown 
@@ -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/
− cabal/cabal/doc/misc.markdown 
@@ -1,109 +0,0 @@-% Cabal User Guide--# Reporting bugs and deficiencies #--Please report any flaws or feature requests in the [bug tracker][].--For general discussion or queries email the libraries mailing list-<libraries@haskell.org>. There is also a development mailing list-<cabal-devel@haskell.org>.--[bug tracker]: 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/
− cabal/cabal/prologue.txt 
@@ -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:-<http://www.haskell.org/cabal/>.
− cabal/cabal/runTests.sh 
@@ -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-
− cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs 
@@ -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)-
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs 
@@ -1,6 +0,0 @@-import System.Time-import MyLibrary--main = do-    getClockTime-    myLibFunc
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs 
@@ -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)
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs 
@@ -1,6 +0,0 @@-import System.Time-import MyLibrary--main = do-    getClockTime-    myLibFunc
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs 
@@ -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)-
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs 
@@ -1,6 +0,0 @@-import System.Time-import MyLibrary--main = do-    getClockTime-    myLibFunc
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs 
@@ -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)-
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs 
@@ -1,6 +0,0 @@-import System.Time-import MyLibrary--main = do-    getClockTime-    myLibFunc
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs 
@@ -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)-
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs 
@@ -1,6 +0,0 @@-import System.Time-import MyLibrary--main = do-    getClockTime-    myLibFunc
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs 
@@ -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)
− cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs 
@@ -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)
− cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs 
@@ -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)
− cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs 
@@ -1,5 +0,0 @@-import qualified Data.ByteString.Char8 as C--main = do-    let text = "lemon"-    C.putStrLn $ C.pack text
− cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs 
@@ -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)
− cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs 
@@ -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
− cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/PackageTester.hs 
@@ -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)-
− cabal/cabal/tests/PackageTests/TestStanza/Check.hs 
@@ -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
− cabal/cabal/tests/PackageTests/TestStanza/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/TestStanza/my.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs 
@@ -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
− cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs 
@@ -1,4 +0,0 @@-module Foo where--fooTest :: [String] -> Bool-fooTest _ = True
− cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal 
@@ -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
− cabal/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs 
@@ -1,8 +0,0 @@-module Main where--import Foo-import System.Exit--main :: IO ()-main | fooTest [] = exitSuccess-     | otherwise = exitFailure
− cabal/cabal/tests/README 
@@ -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.
− cabal/cabal/tests/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− cabal/cabal/tests/Test/Distribution/Version.hs 
@@ -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 ".*"
− cabal/cabal/tests/Test/Laws.hs 
@@ -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
− cabal/cabal/tests/Test/QuickCheck/Utils.hs 
@@ -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)
− cabal/cabal/tests/UnitTest.hs 
@@ -1,474 +0,0 @@---------------------------------------------------------------------------------- |--- Module      :  UnitTest--- Copyright   :  Isaac Jones 2003-2004------ Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>--- 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:
− cabal/cabal/tests/UnitTest/Distribution/PackageDescription.hs 
@@ -1,416 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  PackageDescriptionTests--- Copyright   :  Isaac Jones 2003-2005--- --- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>--- 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] [])
− cabal/cabal/tests/UnitTest/Distribution/PackageDescription/Configuration.hs 
@@ -1,135 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Configuration--- Copyright   :  Thomas Schilling, 2007--- --- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>--- 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
− cabal/cabal/tests/UnitTest/Distribution/ParseUtils.hs 
@@ -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
− cabal/cabal/tests/UnitTest/Distribution/Simple/PreProcess/UnlitTest.hs 
@@ -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)
− cabal/cabal/tests/UnitTest/Distribution/Version.hs 
@@ -1,118 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Version--- Copyright   :  Isaac Jones, Simon Marlow 2003-2004--- --- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>--- 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)-      ]
− cabal/cabal/tests/hackage/check.sh 
@@ -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
− cabal/cabal/tests/hackage/download.sh 
@@ -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
− cabal/cabal/tests/hackage/unpack.sh 
@@ -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
− cabal/cabal/tests/misc/ghc-supported-languages.hs 
@@ -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)
− cabal/cabal/tests/suite.cabal 
@@ -1,30 +0,0 @@-name: suite-version: 0.1-license: BSD3-author: Stephen Blackheath <http://blacksapphire.com/antispam>-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-
− cabal/cabal/tests/suite.hs 
@@ -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)-
− cabal/cabal/tests/systemTests/A/A.cabal 
@@ -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
− cabal/cabal/tests/systemTests/A/A.hs 
@@ -1,4 +0,0 @@-module A where-a = 42 :: Int--main2 = print a
− cabal/cabal/tests/systemTests/A/B/A.lhs 
@@ -1,4 +0,0 @@-> module B.A where-> a = 42 :: Int--> main = print a
− cabal/cabal/tests/systemTests/A/B/MainB.hs 
@@ -1,5 +0,0 @@-module Main where--import A--main = print a
− cabal/cabal/tests/systemTests/A/MainA.hs 
@@ -1,5 +0,0 @@-module Main where--import A--main = print a
− cabal/cabal/tests/systemTests/A/Makefile 
@@ -1,1 +0,0 @@-include ../Tests.mk
− cabal/cabal/tests/systemTests/A/Setup.lhs 
@@ -1,8 +0,0 @@-#!/usr/bin/env runhaskell--> module Main where--> import Distribution.Simple--> main :: IO ()-> main = defaultMain
− cabal/cabal/tests/systemTests/A/c_src/hello.c 
@@ -1,1 +0,0 @@-int foo () {return 9;}
− cabal/cabal/tests/systemTests/A/hello.c 
@@ -1,1 +0,0 @@-int main () {return 9;}
− cabal/cabal/tests/systemTests/buildInfo/Makefile 
@@ -1,1 +0,0 @@-include ../Tests.mk
− cabal/cabal/tests/systemTests/buildInfo/Setup.lhs 
@@ -1,5 +0,0 @@-#!/usr/bin/runhaskell--> import Distribution.Simple-> main = defaultMainWithHooks defaultUserHooks-
− cabal/cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo 
@@ -1,5 +0,0 @@-Executable: exe1-Buildable: True--Executable: exe2-Buildable: True
− cabal/cabal/tests/systemTests/buildInfo/buildinfo2.cabal 
@@ -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 <public@toril.ru>-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
− cabal/cabal/tests/systemTests/buildInfo/src/exe1.hs 
@@ -1,4 +0,0 @@-module Main () where--main :: IO ()-main = return ()
− cabal/cabal/tests/systemTests/buildInfo/src/exe2.hs 
@@ -1,4 +0,0 @@-module Main () where--main :: IO ()-main = return ()
− cabal/cabal/tests/systemTests/dataDir/Exe.hs 
@@ -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
− cabal/cabal/tests/systemTests/dataDir/data-file 
− cabal/cabal/tests/systemTests/dataDir/dataDir.cabal 
@@ -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
− cabal/cabal/tests/systemTests/depOnLib/Makefile 
@@ -1,1 +0,0 @@-include ../Tests.mk
− cabal/cabal/tests/systemTests/depOnLib/Setup.lhs 
@@ -1,8 +0,0 @@-#!/usr/bin/runhugs--> module Main where--> import Distribution.Simple--> main :: IO ()-> main = defaultMain
− cabal/cabal/tests/systemTests/depOnLib/libs/A.hs 
@@ -1,4 +0,0 @@-module A where--a :: Char-a = 'a'
− cabal/cabal/tests/systemTests/depOnLib/mains/Main.hs 
@@ -1,4 +0,0 @@-module Main where-import A--main = putStrLn "Hello, cabal."
− cabal/cabal/tests/systemTests/depOnLib/test.cabal 
@@ -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
− cabal/cabal/tests/systemTests/exeWithC/Makefile 
@@ -1,1 +0,0 @@-include ../Tests.mk
− cabal/cabal/tests/systemTests/exeWithC/Setup.lhs 
@@ -1,2 +0,0 @@-> import Distribution.Simple-> main = defaultMainWithHooks defaultUserHooks
− cabal/cabal/tests/systemTests/exeWithC/a.c 
@@ -1,1 +0,0 @@-int foo(int v) { return 2*v; }
− cabal/cabal/tests/systemTests/exeWithC/test.hs 
@@ -1,4 +0,0 @@-{-# CFILES a.c #-}-foreign import ccall unsafe "foo" foo :: Int -> Int--main = print $ foo 6
− cabal/cabal/tests/systemTests/exeWithC/tt.cabal 
@@ -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
− cabal/cabal/tests/systemTests/ffi-bin/Main.hs 
@@ -1,7 +0,0 @@-module Main where--import TestFFI--main :: IO ()-main = putStrLn "test"-
− cabal/cabal/tests/systemTests/ffi-bin/Makefile 
@@ -1,1 +0,0 @@-include ../Tests.mk
− cabal/cabal/tests/systemTests/ffi-bin/Setup.lhs 
@@ -1,4 +0,0 @@-#! /usr/bin/env runhaskell--> import Distribution.Simple-> main = defaultMain
− cabal/cabal/tests/systemTests/ffi-bin/main.cabal 
@@ -1,6 +0,0 @@-Name:           test-bin-Build-Depends:  base, testffi-Version:        0.0--Executable:     test-Main-Is:        Main.hs
− cabal/cabal/tests/systemTests/ffi-package/Makefile 
@@ -1,1 +0,0 @@-include ../Tests.mk
− cabal/cabal/tests/systemTests/ffi-package/Setup.lhs 
@@ -1,4 +0,0 @@-#! /usr/bin/env runhugs--> import Distribution.Simple-> main = defaultMain
− cabal/cabal/tests/systemTests/ffi-package/TestFFIExe.hs 
@@ -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 ()
− cabal/cabal/tests/systemTests/ffi-package/src/TestFFI.hs 
@@ -1,8 +0,0 @@-module TestFFI where--import Foreign--type Action = IO ()--foreign import ccall "wrapper"-    mkAction :: Action -> IO (FunPtr Action)
− cabal/cabal/tests/systemTests/ffi-package/testffi.cabal 
@@ -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
− cabal/cabal/tests/systemTests/preprocess/preprocess.cabal 
@@ -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
− cabal/cabal/tests/systemTests/preprocess/src/C2HsExample.chs 
@@ -1,3 +0,0 @@-module C2HsExample where---- we don't actually need anything
− cabal/cabal/tests/systemTests/preprocess/src/HappyExample.y 
@@ -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--}
− cabal/cabal/tests/systemTests/recursive/A.hi-boot 
@@ -1,2 +0,0 @@-module A where-newtype TA = MkTA GHC.Base.Int
− cabal/cabal/tests/systemTests/recursive/A.hs 
@@ -1,8 +0,0 @@-module A where--import B( TB(..) )--newtype TA = MkTA Int-    -f :: TB -> TA-f (MkTB x) = MkTA x
− cabal/cabal/tests/systemTests/recursive/A.hs-boot 
@@ -1,2 +0,0 @@-module A where-newtype TA = MkTA Int
− cabal/cabal/tests/systemTests/recursive/B.hs 
@@ -1,8 +0,0 @@-module B where-import {-# SOURCE #-} A( TA(..) )-    -data TB = MkTB !Int--g :: TA -> TB-g (MkTA x) = MkTB x-
− cabal/cabal/tests/systemTests/recursive/C.hs 
@@ -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"
− cabal/cabal/tests/systemTests/recursive/Makefile 
@@ -1,1 +0,0 @@-include ../Tests.mk
− cabal/cabal/tests/systemTests/recursive/Setup.lhs 
@@ -1,8 +0,0 @@-#!/usr/bin/env runhaskell--> module Main where--> import Distribution.Simple--> main :: IO ()-> main = defaultMain
− cabal/cabal/tests/systemTests/recursive/recursive.cabal 
@@ -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
− cabal/cabal/tests/systemTests/sdist/Exe1.hs 
@@ -1,1 +0,0 @@-main = print "exe1"
− cabal/cabal/tests/systemTests/sdist/Exe2.hs 
@@ -1,1 +0,0 @@-main = print "exe2"
− cabal/cabal/tests/systemTests/sdist/sdist.cabal 
@@ -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
− cabal/cabal/tests/systemTests/twoMains/MainA.hs 
@@ -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!")
− cabal/cabal/tests/systemTests/twoMains/MainB.hs 
@@ -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!")
− cabal/cabal/tests/systemTests/twoMains/Makefile 
@@ -1,1 +0,0 @@-include ../Tests.mk
− cabal/cabal/tests/systemTests/twoMains/Setup.lhs 
@@ -1,8 +0,0 @@-#!/usr/bin/runhugs--> module Main where--> import Distribution.Simple--> main :: IO ()-> main = defaultMain
− cabal/cabal/tests/systemTests/twoMains/test.cabal 
@@ -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
− cabal/cabal/tests/systemTests/wash2hs/CHANGES 
@@ -1,5 +0,0 @@-* 20031112-  added JSP-style string escape:-   <%= my nice haskell code %>-  is mapped to-   text (my nice haskell code)
− cabal/cabal/tests/systemTests/wash2hs/LICENSE 
@@ -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. 
− cabal/cabal/tests/systemTests/wash2hs/Makefile 
@@ -1,1 +0,0 @@-include ../Tests.mk
− cabal/cabal/tests/systemTests/wash2hs/Setup.lhs 
@@ -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
− cabal/cabal/tests/systemTests/wash2hs/hs/WASHClean.hs 
@@ -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) }
− cabal/cabal/tests/systemTests/wash2hs/hs/WASHData.hs 
@@ -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;-    ---}
− cabal/cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs 
@@ -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)
− cabal/cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs 
@@ -1,7 +0,0 @@-module WASHFlags where--- -flags0 = FLAGS { generateBT = False }--data FLAGS = FLAGS { generateBT :: Bool }--
− cabal/cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs 
@@ -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 ;--}
− cabal/cabal/tests/systemTests/wash2hs/hs/WASHMain.hs 
@@ -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>" 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)
− cabal/cabal/tests/systemTests/wash2hs/hs/WASHOut.hs 
@@ -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 ()
− cabal/cabal/tests/systemTests/wash2hs/hs/WASHParser.hs 
@@ -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 "<!--";-    comment';-} <?> "comment";--comment' = -    (do {-        c <- charInComment;-        cs <- comment';-        return $ c:cs; -    }) <|>-    (do { -        char '-';-        (do {-            try $ string "->";-            return "";-        }) <|>-        (do {-            c <- charInComment;-            cs <- comment';-            return $ c:cs;-        });-    });--charInComment = -   (char '\t' <|> char '\n' <|> char '\r' <|> -   satisfy (\c -> c >= ' ' && c /= '-')) <?> "character";----- 2.6 / 16-pI = notImplemented >> return "";----- 2.7 / 18-cdSect = notImplemented >> return "";----- 2.8 / 22-prolog = do {-    option ("UTF-8", False) xmlDecl;-    many misc;-    option [[]] (docTypeDecl >> many misc);-    return ();-};----- 2.8 / 23-xmlDecl = do {-  try $ string "<?xml" ;-  versionInfo ;-  enc <- option [] encodingDecl ;-  sdd <- option False sDDecl ;-  s0;-  string "?>" ;-  return (enc, sdd)-};---- 2.7 / 24-versionInfo = do {-  s ;-  string "version";-  eq ;-  ( do {char '\"'; versionNum; char '\"' } <|>-    do {char '\''; versionNum; char '\'' } );-};---- 2.8 / 25-eq = do { s0; char '='; s0; };---- 2.8 / 26-versionNum = string "1.0" ;---- 2.8 / 27-misc = comment <|> pI <|> s;----- 2.8 / 28--- [28] doctypedecl ::=---        '<!DOCTYPE' S Name (S ExternalID)? S? ('[' intSubset ']' S?)? '>'-docTypeDecl = do{-  try $ string "<!DOCTYPE";-  s;-  name;-  option [] (do {s; externalID;});-  s0;-  option [] (do {char '[';intSubset; char ']'; s0; });-  char '>';-};---- 2.8 / 28b--- [28b]    intSubset    ::=    (markupdecl | DeclSep)*-intSubset = notImplemented;---- 2.9 / 32-sDDecl = do {-  s;-  string "standalone";-  eq;-  ( do {char '\"'; x <- yesNo; char '\"'; return x; } <|>-    do {char '\''; x <- yesNo; char '\''; return x; } ) ;-};--yesNo = do {string "yes"; return True;} <|> do {string "no" ; return False;};---- 3 / 39, 3.1 / 40, 3.1 / 42, 3.1 / 44-element :: Bool -> Parser Element;-element toplevel = do {-    name <- try $ do { char '<'; name };-    attrs <- attributes False;-    (do {-        char '>';-        content <- content False;-        try $ do { string "</"; string name; s0; char '>'; };-        return $ Element (setMode toplevel) name attrs content False;-    }) <|>-    (do {-        try $ string "/>";-        return $ Element (setMode toplevel) name attrs [] True;-    })-} <|> do {-    try $ do { string "<%@" };-    s;-    string "include";-    s;-    AText filename <- attValue;-    s;-    subs <- substitutions;-    string "%>";-    let { str = openFile filename; } ;-    return $ -      case parse xmlfile filename str of {-	Left err ->-	  Element (setMode toplevel) "include-failed" -		  [Attribute (setMode toplevel) "file" (AText filename)]-		  [CText (Text (setMode toplevel) (show err))]-		  True;-	Right file ->-	  topElem file;-	}-} <?> "element";--attributes :: Bool -> Parser [Attribute];-attributes toplevel = do { s; attributes' toplevel; } <|> return [];--attributes' :: Bool -> Parser [Attribute];-attributes' toplevel = do { a <- attribute toplevel;-			    as <- attributes toplevel;-			    return (a:as);-			  }-		       <|> return [];---- 3.1 / 41-attribute :: Bool -> Parser Attribute;-attribute toplevel = try (-  do { string "<%" ;-       pat <- hCode ;-       string "%>" ;-       return $ AttrPattern pat ;-    }-<|> -  do {-    name <- name;-    eq;-    value <- attValue;-    return $ Attribute (setMode toplevel) name value;-  }-) <?> "attribute";----- 3.1 / 43-content :: Bool -> Parser [Content];-content toplevel = many (-        (element toplevel  >>= (return . CElement))-    <|> (charData toplevel  >>= (return . CText))-    <|> (haskellText>>= (return . CCode))-    <|> (haskell   >>= (return . CCode))-    <|> (reference >>= (return . CReference . Text (setMode toplevel)))-    <|> (cdSect    >>  (return undefined))-    <|> (pI        >>= (return . CPI))-    <|> (comment   >>= (return . CComment))-);----- 4.1 / 66, 4.1 / 68-reference = do {-    char '&';-    r <- (do { -        char '#';-        r <- many1 digit <|> -            do { char 'x'; r <- many1 hexDigit; return $ 'x':r; };-        return $ '#':r;-    }) <|> name;-    char ';';-    return $ "&" ++ r ++ ";";-} <?> "reference";---- 4.2.2 / 75--- [75]    ExternalID    ::=    'SYSTEM' S SystemLiteral---                            | 'PUBLIC' S PubidLiteral S SystemLiteral-externalID = do{-  string "SYSTEM";-  s;-  systemLiteral;-} <|>-do {-  string "PUBLIC";-  s;-  pubidLiteral;-  s;-  systemLiteral;-};---- 4.3 / 80-encodingDecl = do {-  s;-  string "encoding";-  eq;-  ( do {char '\"'; x <- encName; char '\"'; return x;} <|>-    do {char '\''; x <- encName; char '\''; return x;});-};---- 4.3 / 81--- [81]    EncName    ::=    [A-Za-z] ([A-Za-z0-9._] | '-')*-encName = do {-  c <- satisfy (\c -> c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z') ;-  cs <- many (satisfy (\c -> c >= 'A' && c <= 'Z' -		          || c >= 'a' && c <= 'z'-			  || c >= '0' && c <= '9'-			  || c `elem` "._-"));-  return (c:cs)-};---- B / 84-letter = baseChar <|> ideographic;---- B / 85-baseChar = -    satisfy (\c -> -        (c >= '\x41' && c <= '\x5a') || -        (c >= '\x61' && c <= '\x7a') || -        (c >= '\xc0' && c <= '\xd6') || -        (c >= '\xd8' && c <= '\xf6') || -        (c >= '\xf8' && c <= '\xff')); -- and some Unicode characters---- B / 86-ideographic = notImplemented;---- B / 87-combiningChar = notImplemented;---- B / 88---digit = digit; -- and some Unicode characters---- B / 89-extender = char '\xb7'; -- and some Unicode characters---haskell :: Parser [CodeFrag];-haskell = do {-    try $ string "<%";-    frags <- hStmt <|> hBody;-    try $ string "%>";-    return frags;-};--hIdentChar = letter <|> digit <|> char '\'' <|> char '_';--hStmt :: Parser [CodeFrag];-hStmt = do {-    var <- try $ do { s0 ;-		      v0 <- letter ;-		      vr <- many hIdentChar ;-		      s0 ;-		      string "<-" ;-		      return (v0:vr)-		    };-    body <- hBody ;-    return (VFrag var : body)-};--hBody :: Parser [CodeFrag];-hBody = many (-            (hCode >>= (return . HFrag))-        <|> (element True >>= (return . EFrag))-        <|> (nakedAttributes >>= (return . AFrag))-        <|> (nakedContent >>= (return . CFrag))-    );--nakedAttributes = do {-    s0 ;-    try $ string "<[" ;-    s0 ;-    attrs <- attributes' True ;-    try $ string "]>" ;-    return attrs;-};--nakedContent = do {-    try $ string "<#>" ;-    cnts <- content True ;-    try $ string "</#>";-    return cnts;-};--haskellAttr :: Parser String;-haskellAttr = haskellUnnested "<%";--haskellText :: Parser [CodeFrag];-haskellText = do {-  str <- haskellUnnested "<%=";-  return [HFrag "text(", HFrag str, HFrag ")"]-};--haskellUnnested :: String -> Parser String;-haskellUnnested start = do {-    try $ string start;-    code <- hCode;-    try $ string "%>";-    return code;-} <?> "haskell code";--hCode = try $ do { sp <- getPosition;-		   str <- hcode' '%' (not . (`elem` "#[%"));-		   return (reindent (sourceColumn sp - 1) str);-		 };-hPatt = try $ hcode' '#' (const True);--reindent :: Int -> String -> String;-reindent 0 str = '\n':str;-reindent n str = reindent (n-1) (' ':str);--hSinglePatt = try $ do {-    s0 ;-    char '[' ;-    id <- name ;-    char ']' ;-    s0 ;-    return id ;-} ;-    --hcode' escChar patC = -  let stopChars = escChar : "<\"" in-  do { -    t <- many1 $ (  hcNorm stopChars-                <|> hcString-                <|> hcIsTag patC-                <|> hcIsEnd escChar ) ;-    return $ concat t-};--hcNorm stopChars = try . many1 $ noneOf stopChars;--hcString = try $ do {-    char '\"' ;-    strs <- many ((many1 $ noneOf "\"\\")-              <|> (char '\\' >> (-		   (do x <- satisfy (not . isSpace)-		       return ['\\',x])- 	       <|> (do xs <- many1 $ satisfy isSpace-		       char '\\'-		       return ('\\' : xs ++ "\\"))))) ;-    char '\"' ;-    return ('\"' : concat strs ++ "\"")-};--hcIsTag patC = try $ do { -    char '<' ;-    t <- satisfy (\c -> (not.isAlpha $ c) && patC c) ;-    return ('<':t:[]) ;-};--hcIsEnd escChar = try $ do { -    char escChar ;-    t <- satisfy (/='>') ;-    return (escChar:t:[]) ;-};---- experimental-substitutions = return [];--}
− cabal/cabal/tests/systemTests/wash2hs/hs/WASHUtil.hs 
@@ -1,82 +0,0 @@-module WASHUtil 
-    ( normalize
-    , outList
-    , itemList
-    , openFile
-    ) where {
-
-import System.IOExts ;
-import WASHData ;
-
-itemList :: (item -> ShowS) -> String -> String -> [item] -> ShowS ;
-itemList showsItem empty glue items =
-  f items 
-  where { f []     = showString empty ;
-	  f [item] = showsItem item ;
-	  f (item:items) = showsItem item . showString glue . f items ;
-	};
-
-
-normalize :: [Content] -> [Content] ;
-normalize xs = shortContent.dropEmpty $ xs ;
-
-dropEmpty :: [Content] -> [Content] ;
-dropEmpty [] = [] ;
-dropEmpty (c:cs) = if isWhite c 
-                   then dropEmpty cs 
-                   else c:(dropEmpty cs);
-
-isWhite :: Content -> Bool ;
-isWhite (CText txt) = and $ map isWhite' (textString txt)
-    where { isWhite' c =  c == ' '
-                       || c == '\n'
-                       || c == '\t'
-                       || c == '\r' ;
-    } ;
-isWhite _ = False;
-
-hasText :: Content -> Bool;
-hasText (CText {}) = True ;
-hasText (CReference {}) = True ;
-hasText _ = False ;
-
-textOf :: Content -> Text;
-textOf (CText t) = t;
-textOf (CReference t) = t;
-textOf c = error ("textOf " ++ show c);
-
-joinable :: Text -> Text -> Bool;
-joinable t1 t2 = g (textMode t1) (textMode t2)
-  where { g S F = True;
-	  g S S = False;
-	  g F F = True;
-	  g V V = True;
-	  g _ _ = False;
-	};
-
-joinText :: Text -> Text -> Text;
-joinText t1 t2 = Text (textMode t1) (textString t1 ++ textString t2);
-
-shortContent :: [Content] -> [Content] ;
-shortContent [] = [] ;
-shortContent (CPI pi:cs) = shortContent cs ;
-shortContent (CComment c:cs) = shortContent cs ;
-shortContent (c1:c2:cs) | hasText c1 && hasText c2 =
-	     let { t1 = textOf c1 ; t2 = textOf c2 } in
-	     if joinable t1 t2 then shortContent (CText (joinText t1 t2):cs)
-			       else c1:shortContent (c2:cs);
-shortContent (c:cs) = c:shortContent cs ;
-
-outList :: [String] -> String ;
-outList xs = "[" ++ (outList' $ filter (/= []) xs) ++ "]" ;
-
-outList' ([])     = "" ;
-outList' (x:y:[]) = x ++ ", " ++ y ;
-outList' (x:y:xs) = x ++ ", " ++ outList' (y:xs) ;
-outList' (x:[])   = x ;
-outList' _        = error "ERROR: in processing showList" ;
-
-openFile :: String -> String ;
-openFile fname = unsafePerformIO (readFile fname) ;
-
-}

− cabal/cabal/tests/systemTests/wash2hs/test/Counter.wash 
@@ -1,19 +0,0 @@--- © 2001, 2002 Peter Thiemann-module Main where--import Prelude hiding (map, span, head, div)-import CGI--main = -  run $ counter 0--dialog = "dialog"--counter n =-  standardQuery "Counter" $-  <p class=<% dialog %> >Current counter value <% text (show n) %>-     <br />-     <% submit0 (counter (n + 1)) <[value="Increment"]> %>-     <% submit0 (counter (n - 1)) <[value="Decrement"]> %>-  </p>-
− cabal/cabal/tests/systemTests/wash2hs/test/ManuelsTable.wash 
@@ -1,45 +0,0 @@-module Main where--import Prelude hiding (map, span, head, div)-import CGI--{-- -    ms> -----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|------    ms> (define (fact n)-    ms>    (if (= n 0)-    ms>        1-    ms>        (* n (fact (- n 1)))))--    ms> (define (make-fact-row n)-    ms>    (tr (td :align 'center (bold n))-    ms>        (td :align 'right (it (fact n)))))--    ms> (define (make-fact-table n)-    ms>    (apply table :border 1-    ms> 	  (tr (th "n=") (th "fact"))-    ms> 	  (map make-fact-row (upto 3 n))))--    ms> (font :size -1 (make-fact-table 11))-    ms> -----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-------}--fact n =-  if n == 0-     then 1-     else n * fact (n - 1)--makeFactRow n =-  <tr>-    <td align="center"><b> <%= show n %> </b></td>-    <td align="right"><i> <%= show (fact n) %> </i></td>-  </tr>--makeFactTable n =-  <table border="1">-    <tr><th>n=</th> <th>fact</th></tr>-    <% mapM makeFactRow [3..n] %>-  </table>--main = -  run $ standardQuery "FactTable" $-  <font size="-1"><% makeFactTable 11 %></font>
− cabal/cabal/tests/systemTests/wash2hs/test/Tutorial.wash 
@@ -1,241 +0,0 @@--- © 2002 Peter Thiemann-module Main where--import CGI hiding (head, div, span, map)-import qualified CGI-import Random-import qualified Persistent2 as P-import qualified Cookie as C-import Types -- for nhc98 --main = -  run helo0----- -helo0 =-  standardQuery "Select an Example" $-  activate exAction (selectSingle exName Nothing examples) <#> </#>---  do exampleF <- selectSingle exName Nothing examples <#> </#>---     submit exampleF dispatch (attr "value" "GO")--data Example = Example {exName :: String, exAction :: CGI ()}-instance Eq Example where-  e1 == e2 = exName e1 == exName e2-examples = -	[Example "Simple Hello World" helo1-	,Example "Hello World with a little HTML" helo2-	,Example "Hello World with a little Color" helo4-	,Example "Hello World Personalized" helo5-	,Example "Multiplication Table" helo6-	,Example "Multiplication Drill" helo7-	,Example "Multiplication Drill with Selection Box" helo8-	,Example "Multiplication Drill with Radio Buttons" helo9-	,Example "Multiplication Drill with Email Address" helo10-	,Example "Multiplication Drill with Cookies" helo11-	]---- --helo1 = ask $-	standardPage "Hello" $-	<#>This is my first CGI program!</#>---- -helo2 = ask $-	standardPage "Hello" $-	do <p>This is my second CGI program!</p>-	   <p>My hobbies are-		 <ul> <li>swimming</li>-		      <li>music</li>-		      <li>skiing</li>-                 </ul>-	   </p>--- --fgRed = "color" :=: "red"-bgGreen = "background" :=: "green"-styleImportant = fgRed :^: bgGreen--important x = using styleImportant x--helo4 = ask $-	standardPage "Hello" $-	important <p>This is important!</p>---- --helo5 = standardQuery "What's your name?" $-  <#>Hi there! What's your name? <%-     activate greeting textInputField empty %>-  </#>--greeting :: String -> CGI ()-greeting name =-  standardQuery "Hello" $-  <p>Hello <%= name %>. This is my first interactive CGI program!</p>---- --helo6 = standardQuery "What's your name?" $-  <p>Hi there! What's your name?-	<% activate mtable textInputField empty %>-  </p>--mtable name =-  standardQuery "Multiplication Table" $-  do <p>Hello <%= name %> ! </p>-     <p>Let's see a multiplication table! </p>-     <p>Give me a multiplier <% activate ptable inputField empty %> </p>--ptable :: Int -> CGI ()-ptable mpy =-  standardQuery "Multiplication Table" $-  <table> <% mapM_ pLine [1..12] %> </table>-  where-    align = <[ align="right" ]>-    pLine i = <tr><td> <%= (show i) %> <% align %> </td>-		  <td>*</td>-		  <td> <%= (show mpy) %> </td>-		  <td>=</td>-		  <td> <%= (show (i * mpy)) %> <% align %> </td>-              </tr>---- --helo7 = standardQuery "What's your name?" $-  p (do text "Hi there! What's your name?"-	activate mdrill textInputField empty)--mdrill name =-  standardQuery "Multiplication" $-  <#>-     <p>Hello <%= name %>!</p>-     <p>Let's exercise some multiplication!</p>-     <p>Give me a multiplier <% mpyF <- inputField <[value="2"]> %> </p>-     <p>Number of exercises  <% rptF <- inputField <[value="10"]> %> </p>-     <% submit (F2 mpyF rptF) (firstExercise name) empty %>-  </#>--firstExercise name (F2 mpyF rptF) = -  runExercises 1 [] []-  where-    mpy, rpt :: Int-    mpy = CGI.value mpyF-    rpt = CGI.value rptF--- -    runExercises nr successes failures =-      if nr > rpt then -        finalReport-      else-        do factor <- io (randomRIO (0,12))-	   standardQuery ("Question " ++ show nr ++ " of " ++ show rpt) $-	     do text (show factor ++ " * " ++ show mpy ++ " = ")-		activate (checkAnswer factor) inputField empty-      where-	checkAnswer factor answer =-          let correct = answer == factor * mpy -	      message = if correct then "correct! " else "wrong! "-	      continue = if correct then -	      		      runExercises (nr+1) (factor:successes) failures-			 else-			      runExercises (nr+1) successes (factor:failures)-	  in standardQuery ("Answer " ++ show nr ++ " of " ++ show rpt) $-	  do p (text (show factor ++ " * " ++ show mpy ++ " = " ++ show (factor * mpy)))-	     text ("Your answer " ++ show answer ++ " was " ++ message)-	     submit0 continue <[value="CONTINUE"]>--- -	finalReport =-	  let lenSucc = length successes -	      pItem (m, l, r) = li (text ("Multiplier " ++ show m ++-	                              " : " ++ show l ++-				      " correct out of " ++ show r))-	  in-	  do initialHandle <- P.init ("multi-" ++ name) []-	     currentHandle <- P.add initialHandle (mpy, lenSucc, rpt)-	     hiScores <- P.get currentHandle-	     standardQuery "Final Report" $ -	       <p>Here are your recent scores.-		  <ul> <% mapM_ pItem hiScores %> </ul>-               </p>--- --helo8 = standardQuery "What's your name?" $-  p (do text "Hi there! What's your name?"-	activate mdrillSelect textInputField empty)--mdrillSelect name =-  standardQuery "Multiplication" $-  <#><p>Hello <%= name %>!</p>-     <p>Let's exercise some multiplication!</p>-     <p>Give me a multiplier-	<% mpyF <- selectSingle show Nothing [2..12] empty %></p>-     <p>Number of exercises-        <% rptF <- inputField <[value="10"]> %> </p>-     <% submit (F2 mpyF rptF) (firstExercise name) empty %>-  </#>--- --helo9 = standardQuery "What's your name?" $-  p (do text "Hi there! What's your name?"-	activate mdrillRadio textInputField empty)--mdrillRadio name =-  standardQuery "Multiplication" $-  <#>-    <p>Hello <%= name %>!</p>-    <p>Let's exercise some multiplication!</p>-    <p>Give me a multiplier-       <% mpyF <- selectSingle show Nothing [2..12] empty %></p>-    <% rptF <- radioGroup %>-    <p>Number of exercises-         5 <% radioButton rptF 5 empty %>-	10 <% radioButton rptF 10 empty %>-	20 <% radioButton rptF 20 empty %>-	<% radioError rptF %>-    </p>-    <% submit (F2 mpyF rptF) (firstExercise name) empty %>-  </#>---- --helo10 = standardQuery "What's your name?" $-  p (do text "Hi there! What's your email address?"-	activate mdrillEmail inputField empty-	-- inf <- inputField empty-	-- submit inf mdrillEmailHandle empty-	)--mdrillEmailHandle emailH =-  mdrillEmail (value emailH)-mdrillEmail email =-  let name = unEmailAddress email in-  standardQuery "Multiplication" $-  do p (text ("Hello " ++ name ++ "!"))-     p (text "Let's exercise some multiplication!")-     mpyF <- p (text "Give me a multiplier " >>-                selectSingle show Nothing [2..12] empty)-     rptF <- p (text "Number of exercises " >>-                inputField (attr "value" "10"))-     submit (F2 mpyF rptF) (firstExercise name) empty---- --helo11 = -  C.check "name" >>= \mNameH ->-  case mNameH of-    Nothing ->-      standardQuery "What's your name?" $-        p (do text "Hi there! What's your name?"-	      activate mdrillCookie textInputField empty)-    Just nameC ->-      do mname <- C.get nameC-	 case mname of-	   Nothing ->-	     helo11					    -- retry if outdated-	   Just name ->-	     mdrill name--mdrillCookie name =-  do C.create "name" name-     mdrill name
− cabal/cabal/tests/systemTests/wash2hs/wash2hs.cabal 
@@ -1,14 +0,0 @@-Name: Wash-2hs-Version: 1.4.34-License: BSD3-Build-Depends: base, text, lang-copyright: filler for test suite-maintainer: filler for test suite-synopsis: filler for test suite--executable: wash2hs-hs-source-dir: hs-Other-Modules: WASHClean,  WASHExpression,  WASHGenerator,  WASHOut,-                WASHData,   WASHFlags,       WASHMain,       WASHParser,-                WASHUtil-main-is: WASHMain.hs
− cabal/cabal/tests/systemTests/withHooks/C.testSuffix 
@@ -1,4 +0,0 @@-module C where-a = 42 :: Int--main2 = print a
− cabal/cabal/tests/systemTests/withHooks/D.gc 
@@ -1,4 +0,0 @@-module D where-a = 42 :: Int--main2 = print a
− cabal/cabal/tests/systemTests/withHooks/Main.hs 
@@ -1,3 +0,0 @@-module Main where--main = putStrLn "Happy New Year!"
− cabal/cabal/tests/systemTests/withHooks/Makefile 
@@ -1,1 +0,0 @@-include ../Tests.mk
− cabal/cabal/tests/systemTests/withHooks/Setup.buildinfo.in 
@@ -1,5 +0,0 @@-include-dirs: /tmp, /etc-extensions: CPP--executable: withHooks-extensions: TemplateHaskell
− cabal/cabal/tests/systemTests/withHooks/Setup.lhs 
@@ -1,78 +0,0 @@-#!/usr/bin/runhugs--> module Main where--> import Distribution.Simple-> import Distribution.PackageDescription (PackageDescription,->                                         readPackageDescription, readHookedBuildInfo)-> import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))-> import Distribution.Setup(CopyFlags(..), CopyDest(..), ConfigFlags(..))-> import Distribution.Compat.Directory (copyFile)-> import Distribution.Compat.FilePath(joinPaths)-> import Distribution.Simple.Utils (defaultHookedPackageDesc)-> import Distribution.Program(simpleProgram, rawSystemProgramConf)-> import System.Directory (removeFile, createDirectoryIfMissing)-> import System.Exit(ExitCode(..))-> import Control.Monad(when)-> import Data.Maybe(fromJust, isNothing)-- myPreConf :: Args -> ConfigFlags -> IO HookedBuildInfo--> myPreConf (h:_) flags = do->                        when (h /= "--woohoo")->                             (error "--woohoo flag (for testing) not passed to ./setup configure.")->                        copyFile "Setup.buildinfo.in" "Setup.buildinfo"->                        m <- defaultHookedPackageDesc->                        when (isNothing m) (error "can't open hooked package description!")->                        readHookedBuildInfo (configVerbose flags) (fromJust m)->-> myPreConf [] _ = error "--woohoo flag (for testing) not passed to ./setup configure."--> ppTestHandler :: a -> b -> FilePath -- ^InFile->               -> FilePath -- ^OutFile->               -> Int      -- ^verbose->               -> IO ExitCode-> ppTestHandler _ _ inFile outFile verbose->     = do when (verbose > 0) $->            putStrLn (inFile++" has been preprocessed as a test to "++outFile)->          stuff <- readFile inFile->          writeFile outFile ("-- this file has been preprocessed as a test\n\n" ++ stuff)->          return ExitSuccess--> testing :: Args -> Bool -> a -> b -> IO ExitCode-> testing [] _ _ _ = return ExitSuccess-> testing a@(h:_) _ _ _ = do putStrLn $ "testing: " ++ (show a)->                            if h == "--pass"->                               then return ExitSuccess->                               else return (ExitFailure 1)--> myCopyHook :: PackageDescription->            -> LocalBuildInfo->            -> Maybe UserHooks->            -> CopyFlags -- ^install-prefix, verbose->            -> IO ()-> myCopyHook a b c d@(CopyFlags (CopyPrefix p) _) = do->   -- call 'ls' from our hookedPrograms hook... pointless except as a demo->   rawSystemProgramConf 0 "ls" (withPrograms b) []->   let copySource = case compilerFlavor $ compiler b of->        GHC  -> foldl1 joinPaths ["dist", "build", "withHooks", "withHooks"]->        Hugs -> foldl1 joinPaths ["dist", "build", "Main.hs"] -- some random file->   createDirectoryIfMissing True p->   copyFile copySource (p `joinPaths` "withHooks")-->   -- now call the default copy hook so the rest of the test case works nice ... so tricky ;)->   (copyHook defaultUserHooks) a b c d-> myCopyHook _ _ _ _ = error "Please use --copy-prefix."--Override "gc" to test the overriding mechanism.--> main :: IO ()-> main = defaultMainWithHooks defaultUserHooks->        {preConf=myPreConf,->         hookedPrograms=[simpleProgram "ls"],->         runTests=testing,->         postConf=(\_ _ _ _ -> return ExitSuccess),->         hookedPreProcessors=  [("testSuffix", ppTestHandler), ("gc", ppTestHandler)],->         postClean=(\_ _ _ _ -> removeFile "Setup.buildinfo" >> return ExitSuccess),->         copyHook=myCopyHook->        }
− cabal/cabal/tests/systemTests/withHooks/WithHooks.hs 
@@ -1,3 +0,0 @@-module WithHooks where--f = 34
− cabal/cabal/tests/systemTests/withHooks/withHooks.cabal 
@@ -1,11 +0,0 @@-Name: withHooks-Version: 1.0-copyright: filler for test suite-maintainer: filler for test suite-synopsis: filler for test suite-build-depends: base-exposed-modules: Main, C, D--Executable: withHooks-Other-Modules: Main-Main-is: Main.hs
cabal/ghc-packages view
@@ -1,2 +1,2 @@-cabal+Cabal 
hackport.cabal view
@@ -1,5 +1,5 @@ Name:           hackport-Version:	0.2.18+Version:	0.2.19 License:	GPL License-file:   LICENSE Author:		Henning Günther, Duncan Coutts, Lennart Kolmodin@@ -20,21 +20,24 @@ Executable	hackport   Main-Is:	Main.hs   Default-Language: Haskell98-  Hs-Source-Dirs: ., cabal/cabal, cabal/cabal-install+  Hs-Source-Dirs: ., cabal, cabal/Cabal, cabal/cabal-install   Build-Depends:     base >= 2.0 && < 5,+    deepseq >= 1.3 && < 1.4,     filepath,     parsec,     mtl,     network,     pretty,     regex-compat,+    MissingH,     HTTP >= 4000.0.3,     zlib,     tar,     xml>1.3.5,     array,     extensible-exceptions,+    time,     -- cabal depends     unix @@ -127,8 +130,9 @@   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell98   Main-Is:              tests/resolveCat.hs-  Hs-Source-Dirs:       ., cabal/cabal, cabal/cabal-install+  Hs-Source-Dirs:       ., cabal, cabal/Cabal, cabal/cabal-install   Build-Depends:        base >= 3 && < 5,+                        deepseq >= 1.3 && < 1.4,                         bytestring,                         containers,                         directory,@@ -138,5 +142,6 @@                         mtl,                         pretty,                         process,+                        time,                         unix,                         xml