packages feed

Cabal 1.16.0.3 → 1.18.0

raw patch · 179 files changed

+7390/−2757 lines, 179 filesdep +deepseqdep +regex-posixdep +timedep −old-timedep ~QuickCheckdep ~basedep ~bytestring

Dependencies added: deepseq, regex-posix, time

Dependencies removed: old-time

Dependency ranges changed: QuickCheck, base, bytestring, process, test-framework-quickcheck2, unix

Files

Cabal.cabal view
@@ -1,172 +1,289 @@-Name: Cabal-Version: 1.16.0.3-Copyright: 2003-2006, Isaac Jones+name: Cabal+version: 1.18.0+copyright: 2003-2006, Isaac Jones            2005-2011, Duncan Coutts-License: BSD3-License-File: LICENSE-Author: Isaac Jones <ijones@syntaxpolice.org>+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/+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+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+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+extra-source-files:+  README tests/README changelog +  -- Generated with+  --+  -- find tests -type f -name '*.hs' -or -name '*.c' -or -name '*.sh' -or -name '*.cabal' -or name '*.hsc'+  -- | awk '/Check.hs$|UnitTests|PackageTester|autogen|PackageTests.hs|CreatePipe/+  -- { next } { print }'++  tests/PackageTests/BenchmarkExeV10/Foo.hs+  tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs+  tests/PackageTests/BenchmarkExeV10/my.cabal+  tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal+  tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs+  tests/PackageTests/BenchmarkStanza/my.cabal+  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal+  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs+  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal+  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs+  tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal+  tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs+  tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal+  tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs+  tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal+  tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs+  tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal+  tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal+  tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs+  tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal+  tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal+  tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs+  tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal+  tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs+  tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal+  tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs+  tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs+  tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs+  tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs+  tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal+  tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs+  tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs+  tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal+  tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs+  tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs+  tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal+  tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs+  tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal+  tests/PackageTests/CMain/Bar.hs+  tests/PackageTests/CMain/Setup.hs+  tests/PackageTests/CMain/foo.c+  tests/PackageTests/CMain/my.cabal+  tests/PackageTests/EmptyLib/empty/empty.cabal+  tests/PackageTests/OrderFlags/Foo.hs+  tests/PackageTests/OrderFlags/my.cabal+  tests/PackageTests/PathsModule/Executable/Main.hs+  tests/PackageTests/PathsModule/Executable/my.cabal+  tests/PackageTests/PathsModule/Library/my.cabal+  tests/PackageTests/PreProcess/Foo.hsc+  tests/PackageTests/PreProcess/Main.hs+  tests/PackageTests/PreProcess/my.cabal+  tests/PackageTests/TemplateHaskell/vanilla/Exe.hs+  tests/PackageTests/TemplateHaskell/vanilla/Lib.hs+  tests/PackageTests/TemplateHaskell/vanilla/TH.hs+  tests/PackageTests/TemplateHaskell/vanilla/my.cabal+  tests/PackageTests/TemplateHaskell/dynamic/Exe.hs+  tests/PackageTests/TemplateHaskell/dynamic/Lib.hs+  tests/PackageTests/TemplateHaskell/dynamic/TH.hs+  tests/PackageTests/TemplateHaskell/dynamic/my.cabal+  tests/PackageTests/TemplateHaskell/profiling/Exe.hs+  tests/PackageTests/TemplateHaskell/profiling/Lib.hs+  tests/PackageTests/TemplateHaskell/profiling/TH.hs+  tests/PackageTests/TemplateHaskell/profiling/my.cabal+  tests/PackageTests/TestOptions/TestOptions.cabal+  tests/PackageTests/TestOptions/test-TestOptions.hs+  tests/PackageTests/TestStanza/my.cabal+  tests/PackageTests/TestSuiteExeV10/Foo.hs+  tests/PackageTests/TestSuiteExeV10/my.cabal+  tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs+  tests/Setup.hs+  tests/hackage/check.sh+  tests/hackage/download.sh+  tests/hackage/unpack.sh+  tests/misc/ghc-supported-languages.hs+ 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.--Library-  build-depends:   base       >= 2   && < 5,-                   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+library+  build-depends:+    base       >= 4       && < 5,+    deepseq    >= 1.3     && < 1.4,+    filepath   >= 1       && < 1.4,+    directory  >= 1       && < 1.3,+    process    >= 1.0.1.1 && < 1.3,+    time       >= 1.1     && < 1.5,+    containers >= 0.1     && < 0.6,+    array      >= 0.1     && < 0.5,+    pretty     >= 1       && < 1.2,+    bytestring >= 0.9    if !os(windows)-    Build-Depends: unix       >= 2.0 && < 2.7+    build-depends:+      unix >= 2.0 && < 2.8 -  ghc-options: -Wall -fno-ignore-asserts-  if impl(ghc >= 6.8)-    ghc-options: -fwarn-tabs-  nhc98-Options: -K4M+  ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -  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+  exposed-modules:+    Distribution.Compat.Environment+    Distribution.Compat.Exception+    Distribution.Compat.ReadP+    Distribution.Compiler+    Distribution.InstalledPackageInfo+    Distribution.License+    Distribution.Make+    Distribution.ModuleName+    Distribution.Package+    Distribution.PackageDescription+    Distribution.PackageDescription.Check+    Distribution.PackageDescription.Configuration+    Distribution.PackageDescription.Parse+    Distribution.PackageDescription.PrettyPrint+    Distribution.PackageDescription.Utils+    Distribution.ParseUtils+    Distribution.ReadE+    Distribution.Simple+    Distribution.Simple.Bench+    Distribution.Simple.Build+    Distribution.Simple.Build.Macros+    Distribution.Simple.Build.PathsModule+    Distribution.Simple.BuildPaths+    Distribution.Simple.BuildTarget+    Distribution.Simple.CCompiler+    Distribution.Simple.Command+    Distribution.Simple.Compiler+    Distribution.Simple.Configure+    Distribution.Simple.GHC+    Distribution.Simple.Haddock+    Distribution.Simple.Hpc+    Distribution.Simple.Hugs+    Distribution.Simple.Install+    Distribution.Simple.InstallDirs+    Distribution.Simple.JHC+    Distribution.Simple.LHC+    Distribution.Simple.LocalBuildInfo+    Distribution.Simple.NHC+    Distribution.Simple.PackageIndex+    Distribution.Simple.PreProcess+    Distribution.Simple.PreProcess.Unlit+    Distribution.Simple.Program+    Distribution.Simple.Program.Ar+    Distribution.Simple.Program.Builtin+    Distribution.Simple.Program.Db+    Distribution.Simple.Program.Find+    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+    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+  other-modules:+    Distribution.Compat.CopyFile+    Distribution.Compat.TempFile+    Distribution.GetOpt+    Distribution.Simple.GHC.IPI641+    Distribution.Simple.GHC.IPI642+    Paths_Cabal -  Default-Language: Haskell98-  Default-Extensions: CPP+  default-language: Haskell98+  default-extensions: CPP +-- Small, fast running tests. 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.TestOptions.Check,-                 PackageTests.TestStanza.Check,-                 PackageTests.TestSuiteExeV10.Check,-                 PackageTests.BenchmarkOptions.Check,-                 PackageTests.BenchmarkStanza.Check,-                 PackageTests.BenchmarkExeV10.Check,-                 PackageTests.TemplateHaskell.Check,-                 PackageTests.PackageTester   hs-source-dirs: tests+  other-modules: UnitTests.Distribution.Compat.ReadP+  main-is: UnitTests.hs   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+    base,+    test-framework,+    test-framework-hunit,+    test-framework-quickcheck2,+    HUnit,+    QuickCheck,+    Cabal+  ghc-options: -Wall+  default-language: Haskell98++-- Large, system tests that build packages.+test-suite package-tests+  type: exitcode-stdio-1.0+  main-is: PackageTests.hs+  other-modules:+    Distribution.Compat.CreatePipe+    PackageTests.BenchmarkExeV10.Check+    PackageTests.BenchmarkOptions.Check+    PackageTests.BenchmarkStanza.Check+    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.SameDepsAllRound.Check+    PackageTests.BuildDeps.TargetSpecificDeps1.Check+    PackageTests.BuildDeps.TargetSpecificDeps2.Check+    PackageTests.BuildDeps.TargetSpecificDeps3.Check+    PackageTests.BuildTestSuiteDetailedV09.Check+    PackageTests.CMain.Check+    PackageTests.EmptyLib.Check+    PackageTests.OrderFlags.Check+    PackageTests.PackageTester+    PackageTests.PathsModule.Executable.Check+    PackageTests.PathsModule.Library.Check+    PackageTests.PreProcess.Check+    PackageTests.TemplateHaskell.Check+    PackageTests.TestOptions.Check+    PackageTests.TestStanza.Check+    PackageTests.TestSuiteExeV10.Check+  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,+    regex-posix+  if !os(windows)+    build-depends: unix+  ghc-options: -Wall+  default-extensions: CPP+  default-language: Haskell98
Distribution/Compat/CopyFile.hs view
@@ -1,10 +1,5 @@-{-# 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+{-# OPTIONS_HADDOCK hide #-} module Distribution.Compat.CopyFile (   copyFile,   copyOrdinaryFile,@@ -14,20 +9,15 @@   setDirOrdinary,   ) where -#ifdef __GLASGOW_HASKELL__  import Control.Monad          ( when ) import Control.Exception-         ( bracket, bracketOnError )+         ( bracket, bracketOnError, throwIO ) 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@@ -38,25 +28,15 @@          ( 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 ()@@ -70,17 +50,9 @@  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@@ -88,12 +60,9 @@ setDirOrdinary = setFileExecutable  copyFile :: FilePath -> FilePath -> IO ()-#ifdef __GLASGOW_HASKELL__ copyFile fromFPath toFPath =   copy-#if __GLASGOW_HASKELL__ >= 608-    `catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "copyFile"))-#endif+    `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile"))     where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->                  bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->                  do allocaBytes bufferSize $ copyContents hFrom hTmp@@ -110,6 +79,3 @@                   when (count > 0) $ do                           hPutBuf hTo buffer count                           copyContents hFrom hTo buffer-#else-copyFile fromFPath toFPath = readFile fromFPath >>= writeFile toFPath-#endif
+ Distribution/Compat/Environment.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}++module Distribution.Compat.Environment (getEnvironment)+       where++import qualified System.Environment as System++#ifdef mingw32_HOST_OS+import qualified Data.Char as Char (toUpper)+#endif++getEnvironment :: IO [(String, String)]+#ifdef mingw32_HOST_OS+-- On Windows, the names of environment variables are case-insensitive, but are+-- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise+-- them.+getEnvironment = fmap upcaseVars System.getEnvironment+  where+    upcaseVars = map upcaseVar+    upcaseVar (var, val) = (map Char.toUpper var, val)+#else+getEnvironment = System.getEnvironment+#endif
Distribution/Compat/Exception.hs view
@@ -1,61 +1,17 @@-{-# 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,+  catchIO,+  catchExit,+  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-
Distribution/Compat/ReadP.hs view
@@ -19,6 +19,8 @@ -- 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@@ -64,14 +66,12 @@   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 Control.Monad( MonadPlus(..), liftM2, ap ) import Data.Char (isSpace)+import Control.Applicative (Applicative(..))  infixr 5 +++, <++ @@ -88,6 +88,13 @@  -- Monad, MonadPlus +instance Functor (P s) where+  fmap f x = x >>= return . f++instance Applicative (P s) where+  pure = return+  (<*>) = ap+ instance Monad (P s) where   return x = Result x Fail @@ -139,6 +146,10 @@ instance Functor (Parser r s) where   fmap h (R f) = R (\k -> f (k . h)) +instance Applicative (Parser r s) where+  pure = return+  (<*>) = ap+ instance Monad (Parser r s) where   return x  = R (\k -> k x)   fail _    = R (\_ -> Fail)@@ -378,93 +389,5 @@ 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--}
Distribution/Compat/TempFile.hs view
@@ -1,10 +1,5 @@-{-# 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+{-# OPTIONS_HADDOCK hide #-} module Distribution.Compat.TempFile (   openTempFile,   openBinaryTempFile,@@ -16,39 +11,19 @@ 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 Distribution.Compat.Exception (tryIO)+import Control.Exception      (onException) 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 )@@ -64,43 +39,6 @@ -- 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.@@ -128,10 +66,6 @@      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@@ -145,17 +79,7 @@          -- 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+         h <- fdToHandle fd `onException` c_close fd          return (filepath, h)       where         filename        = prefix ++ show x ++ suffix@@ -181,7 +105,6 @@ 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
Distribution/Compiler.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Compiler@@ -54,6 +55,7 @@ module Distribution.Compiler (   -- * Compiler flavor   CompilerFlavor(..),+  buildCompilerId,   buildCompilerFlavor,   defaultCompilerFlavor,   parseCompilerFlavorCompat,@@ -62,9 +64,12 @@   CompilerId(..),   ) where +import Data.Data (Data)+import Data.Typeable (Typeable)+import Data.Maybe (fromMaybe) import Distribution.Version (Version(..)) -import qualified System.Info (compilerName)+import qualified System.Info (compilerName, compilerVersion) import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp@@ -75,7 +80,7 @@  data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC                     | OtherCompiler String-  deriving (Show, Read, Eq, Ord)+  deriving (Show, Read, Eq, Ord, Typeable, Data)  knownCompilerFlavors :: [CompilerFlavor] knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]@@ -92,9 +97,7 @@  classifyCompilerFlavor :: String -> CompilerFlavor classifyCompilerFlavor s =-  case lookup (lowercase s) compilerMap of-    Just compiler -> compiler-    Nothing       -> OtherCompiler s+  fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap   where     compilerMap = [ (display compiler, compiler)                   | compiler <- knownCompilerFlavors ]@@ -126,6 +129,12 @@  buildCompilerFlavor :: CompilerFlavor buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName++buildCompilerVersion :: Version+buildCompilerVersion = System.Info.compilerVersion++buildCompilerId :: CompilerId+buildCompilerId = CompilerId buildCompilerFlavor buildCompilerVersion  -- | The default compiler flavour to pick when compiling stuff. This defaults -- to the compiler used to build the Cabal lib.
Distribution/GetOpt.hs view
@@ -36,7 +36,7 @@ :-) -} --- #hide+{-# OPTIONS_HADDOCK hide #-} module Distribution.GetOpt (    -- * GetOpt    getOpt, getOpt',@@ -50,7 +50,8 @@    -- $example ) where -import Data.List ( isPrefixOf, intersperse, find )+import Data.List ( isPrefixOf, intercalate, find )+import Data.Maybe ( isJust )  -- |What to do with options following non-options data ArgOrder a@@ -98,7 +99,7 @@           -> [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)+   where (ss,ls,ds) = unzip3 [ (intercalate ", " (map (fmtShort ad) sos)                                ,concatMap (fmtLong  ad) (take 1 los)                                ,d)                              | Option sos los ad d <- optDescr ]@@ -111,7 +112,6 @@                       | (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 =@@ -201,11 +201,11 @@ 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]+                          , isJust (find (p opt) xs)]          exact     = getWith (==)          options   = if null exact then getWith isPrefixOf else exact          ads       = [ ad | Option _ _ ad _ <- options ]-         optStr    = ("--"++opt)+         optStr    = "--" ++ opt           long (_:_:_)      _        rest     = (errAmbig options optStr,rest)          long [NoArg  a  ] []       rest     = (Opt a,rest)
Distribution/InstalledPackageInfo.hs view
@@ -61,13 +61,15 @@         parseInstalledPackageInfo,         showInstalledPackageInfo,         showInstalledPackageInfoField,+        showSimpleInstalledPackageInfoField,         fieldsInstalledPackageInfo,   ) where  import Distribution.ParseUtils          ( FieldDescr(..), ParseResult(..), PError(..), PWarning          , simpleField, listField, parseLicenseQ-         , showFields, showSingleNamedField, parseFieldsFlat+         , showFields, showSingleNamedField, showSimpleSingleNamedField+         , parseFieldsFlat          , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ          , showFilePath, showToken, boolField, parseOptVersion          , parseFreeText, showFreeText )@@ -184,6 +186,9 @@  showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo++showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)+showSimpleInstalledPackageInfoField = showSimpleSingleNamedField fieldsInstalledPackageInfo  -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing
Distribution/License.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.License@@ -15,7 +16,7 @@ -- 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.+-- includes 'GPL', 'AGPL', 'LGPL', 'Apache 2.0', 'MIT' and 'BSD3' licenses.  {- All rights reserved. @@ -59,6 +60,8 @@ import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>)) import qualified Data.Char as Char (isAlphaNum)+import Data.Data (Data)+import Data.Typeable (Typeable)  -- |This datatype indicates the license under which your package is -- released.  It is also wise to add your license to each source file@@ -76,6 +79,9 @@     -- | GNU Public License. Source code must accompany alterations.     GPL (Maybe Version) +    -- | GNU Affero General Public License+  | AGPL (Maybe Version)+     -- | Lesser GPL, Less restrictive than GPL, useful for libraries.   | LGPL (Maybe Version) @@ -106,11 +112,12 @@     -- | Not a recognised license.     -- Allows us to deal with future extensions more gracefully.   | UnknownLicense String-  deriving (Read, Show, Eq)+  deriving (Read, Show, Eq, Typeable, Data)  knownLicenses :: [License] knownLicenses = [ GPL  unversioned, GPL  (version [2]),   GPL  (version [3])                 , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3])+                , AGPL unversioned,                       AGPL (version [3])                 , BSD3, MIT                 , Apache unversioned, Apache (version [2, 0])                 , PublicDomain, AllRightsReserved, OtherLicense]@@ -121,6 +128,7 @@ instance Text License where   disp (GPL  version)         = Disp.text "GPL"  <> dispOptVersion version   disp (LGPL version)         = Disp.text "LGPL" <> dispOptVersion version+  disp (AGPL version)         = Disp.text "AGPL" <> dispOptVersion version   disp (Apache version)       = Disp.text "Apache" <> dispOptVersion version   disp (UnknownLicense other) = Disp.text other   disp other                  = Disp.text (show other)@@ -131,6 +139,7 @@     return $! case (name, version :: Maybe Version) of       ("GPL",               _      ) -> GPL  version       ("LGPL",              _      ) -> LGPL version+      ("AGPL",              _      ) -> AGPL version       ("BSD3",              Nothing) -> BSD3       ("BSD4",              Nothing) -> BSD4       ("MIT",               Nothing) -> MIT
Distribution/Make.hs view
@@ -106,7 +106,7 @@          ( display )  import System.Environment (getArgs, getProgName)-import Data.List  (intersperse)+import Data.List  (intercalate) import System.Exit  defaultMain :: IO ()@@ -138,7 +138,7 @@     printHelp help = getProgName >>= putStr . help     printOptionsList = putStr . unlines     printErrors errs = do-      putStr (concat (intersperse "\n" errs))+      putStr (intercalate "\n" errs)       exitWith (ExitFailure 1)     printNumericVersion = putStrLn $ display cabalVersion     printVersion        = putStrLn $ "Cabal library version "
Distribution/ModuleName.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.ModuleName@@ -50,6 +51,8 @@ import Distribution.Text          ( Text(..) ) +import Data.Data (Data)+import Data.Typeable (Typeable) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp import qualified Data.Char as Char@@ -57,12 +60,12 @@ import System.FilePath          ( pathSeparator ) import Data.List-         ( intersperse )+         ( intercalate, intersperse )  -- | A valid Haskell module name. -- newtype ModuleName = ModuleName [String]-  deriving (Eq, Ord, Read, Show)+  deriving (Eq, Ord, Read, Show, Typeable, Data)  instance Text ModuleName where   disp (ModuleName ms) =@@ -127,4 +130,4 @@ -- > toFilePath (fromString "A.B.C") = "A/B/C" -- toFilePath :: ModuleName -> FilePath-toFilePath = concat . intersperse [pathSeparator] . components+toFilePath = intercalate [pathSeparator] . components
Distribution/Package.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Package@@ -70,17 +71,20 @@ 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.List ( intercalate )+import Data.Data ( Data )+import Data.Typeable ( Typeable )  newtype PackageName = PackageName String-    deriving (Read, Show, Eq, Ord)+    deriving (Read, Show, Eq, Ord, Typeable, Data)  instance Text PackageName where   disp (PackageName n) = Disp.text n   parse = do     ns <- Parse.sepBy1 component (Parse.char '-')-    return (PackageName (concat (intersperse "-" ns)))+    return (PackageName (intercalate "-" ns))     where       component = do         cs <- Parse.munch1 Char.isAlphaNum@@ -88,6 +92,9 @@         -- 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 @@ -97,7 +104,7 @@         pkgName    :: PackageName, -- ^The name of this package, eg. foo         pkgVersion :: Version -- ^the version of this package, eg 1.2      }-     deriving (Read, Show, Eq, Ord)+     deriving (Read, Show, Eq, Ord, Typeable, Data)  instance Text PackageIdentifier where   disp (PackageIdentifier n v) = case v of@@ -109,16 +116,19 @@     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'+-- | 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)+ deriving (Read,Show,Eq,Ord,Typeable,Data)  instance Text InstalledPackageId where   disp (InstalledPackageId str) = text str@@ -133,7 +143,7 @@ -- | Describes a dependency on a source package (API) -- data Dependency = Dependency PackageName VersionRange-                  deriving (Read, Show, Eq)+                  deriving (Read, Show, Eq, Typeable, Data)  instance Text Dependency where   disp (Dependency name ver) =
Distribution/PackageDescription.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.PackageDescription@@ -123,9 +124,11 @@         knownRepoTypes,   ) where -import Data.List   (nub, intersperse)-import Data.Maybe  (maybeToList)+import Data.Data   (Data)+import Data.List   (nub, intercalate)+import Data.Maybe  (fromMaybe, maybeToList) import Data.Monoid (Monoid(mempty, mappend))+import Data.Typeable ( Typeable ) import Control.Monad (MonadPlus(mplus)) import Text.PrettyPrint as Disp import qualified Distribution.Compat.ReadP as Parse@@ -191,9 +194,10 @@         dataFiles      :: [FilePath],         dataDir        :: FilePath,         extraSrcFiles  :: [FilePath],-        extraTmpFiles  :: [FilePath]+        extraTmpFiles  :: [FilePath],+        extraDocFiles  :: [FilePath]     }-    deriving (Show, Read, Eq)+    deriving (Show, Read, Eq, Typeable, Data)  instance Package PackageDescription where   packageId = package@@ -254,7 +258,8 @@                       dataFiles    = [],                       dataDir      = "",                       extraSrcFiles = [],-                      extraTmpFiles = []+                      extraTmpFiles = [],+                      extraDocFiles = []                      }  -- | The type of build system used by this package.@@ -270,7 +275,7 @@                 --   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)+                deriving (Show, Read, Eq, Typeable, Data)  knownBuildTypes :: [BuildType] knownBuildTypes = [Simple, Configure, Make, Custom]@@ -296,7 +301,7 @@         libExposed        :: Bool, -- ^ Is the lib to be exposed by default?         libBuildInfo      :: BuildInfo     }-    deriving (Show, Eq, Read)+    deriving (Show, Eq, Read, Typeable, Data)  instance Monoid Library where   mempty = Library {@@ -344,7 +349,7 @@         modulePath :: FilePath,         buildInfo  :: BuildInfo     }-    deriving (Show, Read, Eq)+    deriving (Show, Read, Eq, Typeable, Data)  instance Monoid Executable where   mempty = Executable {@@ -398,7 +403,7 @@         -- a better solution is waiting on the next overhaul to the         -- GenericPackageDescription -> PackageDescription resolution process.     }-    deriving (Show, Read, Eq)+    deriving (Show, Read, Eq, Typeable, Data)  -- | The test suite interfaces that are currently defined. Each test suite must -- specify which interface it supports.@@ -424,7 +429,7 @@      -- the given reason (e.g. unknown test type).      --    | TestSuiteUnsupported TestType-   deriving (Eq, Read, Show)+   deriving (Eq, Read, Show, Typeable, Data)  instance Monoid TestSuite where     mempty = TestSuite {@@ -438,7 +443,7 @@         testName      = combine' testName,         testInterface = combine  testInterface,         testBuildInfo = combine  testBuildInfo,-        testEnabled   = if testEnabled a then True else testEnabled b+        testEnabled   = testEnabled a || testEnabled b     }         where combine   field = field a `mappend` field b               combine' f = case (f a, f b) of@@ -480,33 +485,36 @@ 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)+    deriving (Show, Read, Eq, Typeable, Data)  knownTestTypes :: [TestType] knownTestTypes = [ TestTypeExe (Version [1,0] [])                  , TestTypeLib (Version [0,9] []) ] +stdParse :: Text ver => (ver -> String -> res) -> Parse.ReadP r res+stdParse f = do+  cs   <- Parse.sepBy1 component (Parse.char '-')+  _    <- Parse.char '-'+  ver  <- parse+  let name = intercalate "-" cs+  return $! f ver (lowercase name)+  where+    component = do+      cs <- Parse.munch1 Char.isAlphaNum+      if all Char.isDigit cs then Parse.pfail else return cs+      -- each component must contain an alphabetic character, to avoid+      -- ambiguity in identifiers like foo-1 (the 1 is the version number).+ instance Text TestType where   disp (TestTypeExe ver)          = text "exitcode-stdio-" <> disp ver   disp (TestTypeLib ver)          = text "detailed-"       <> disp ver   disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver -  parse = 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+  parse = stdParse $ \ver name -> case 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@@ -526,7 +534,7 @@         benchmarkEnabled   :: Bool         -- TODO: See TODO for 'testEnabled'.     }-    deriving (Show, Read, Eq)+    deriving (Show, Read, Eq, Typeable, Data)  -- | The benchmark interfaces that are currently defined. Each -- benchmark must specify which interface it supports.@@ -548,7 +556,7 @@      -- interfaces for the given reason (e.g. unknown benchmark type).      --    | BenchmarkUnsupported BenchmarkType-   deriving (Eq, Read, Show)+   deriving (Eq, Read, Show, Typeable, Data)  instance Monoid Benchmark where     mempty = Benchmark {@@ -562,8 +570,7 @@         benchmarkName      = combine' benchmarkName,         benchmarkInterface = combine  benchmarkInterface,         benchmarkBuildInfo = combine  benchmarkBuildInfo,-        benchmarkEnabled   = if benchmarkEnabled a then True-                             else benchmarkEnabled b+        benchmarkEnabled   = benchmarkEnabled a || benchmarkEnabled b     }         where combine   field = field a `mappend` field b               combine' f = case (f a, f b) of@@ -603,7 +610,7 @@                      -- ^ \"type: exitcode-stdio-x.y\"                    | BenchmarkTypeUnknown String Version                      -- ^ Some unknown benchmark type e.g. \"type: foo\"-    deriving (Show, Read, Eq)+    deriving (Show, Read, Eq, Typeable, Data)  knownBenchmarkTypes :: [BenchmarkType] knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ]@@ -612,21 +619,10 @@   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+  parse = stdParse $ \ver name -> case 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@@ -668,7 +664,7 @@                                                 -- simple assoc-list.         targetBuildDepends :: [Dependency] -- ^ Dependencies specific to a library or executable target     }-    deriving (Show,Read,Eq)+    deriving (Show,Read,Eq,Typeable,Data)  instance Monoid BuildInfo where   mempty = BuildInfo {@@ -842,7 +838,7 @@   -- given the default is \".\" ie no subdirectory.   repoSubdir   :: Maybe FilePath }-  deriving (Eq, Read, Show)+  deriving (Eq, Read, Show, Typeable, Data)  -- | What this repo info is for, what it represents. --@@ -858,7 +854,7 @@   | RepoThis    | RepoKindUnknown String-  deriving (Eq, Ord, Read, Show)+  deriving (Eq, Ord, Read, Show, Typeable, Data)  -- | 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@@ -867,7 +863,7 @@ data RepoType = Darcs | Git | SVN | CVS               | Mercurial | GnuArch | Bazaar | Monotone               | OtherRepoType String-  deriving (Eq, Ord, Read, Show)+  deriving (Eq, Ord, Read, Show, Typeable, Data)  knownRepoTypes :: [RepoType] knownRepoTypes = [Darcs, Git, SVN, CVS@@ -898,9 +894,7 @@  classifyRepoType :: String -> RepoType classifyRepoType s =-  case lookup (lowercase s) repoTypeMap of-    Just repoType' -> repoType'-    Nothing        -> OtherRepoType s+  fromMaybe (OtherRepoType s) $ lookup (lowercase s) repoTypeMap   where     repoTypeMap = [ (name, repoType')                   | repoType' <- knownRepoTypes@@ -952,7 +946,7 @@         condTestSuites     :: [(String, CondTree ConfVar [Dependency] TestSuite)],         condBenchmarks     :: [(String, CondTree ConfVar [Dependency] Benchmark)]       }-    deriving (Show, Eq)+    deriving (Show, Eq, Typeable, Data)  instance Package GenericPackageDescription where   packageId = packageId . packageDescription@@ -967,11 +961,11 @@     , flagDefault     :: Bool     , flagManual      :: Bool     }-    deriving (Show, Eq)+    deriving (Show, Eq, Typeable, Data)  -- | A 'FlagName' is the name of a user-defined configuration flag newtype FlagName = FlagName String-    deriving (Eq, Ord, Show, Read)+    deriving (Eq, Ord, Show, Read, Typeable, Data)  -- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to -- 'Bool' flag values. It represents the flags chosen by the user or@@ -985,7 +979,7 @@              | Arch Arch              | Flag FlagName              | Impl CompilerFlavor VersionRange-    deriving (Eq, Show)+    deriving (Eq, Show, Typeable, Data)  --instance Text ConfVar where --    disp (OS os) = "os(" ++ display os ++ ")"@@ -1000,7 +994,7 @@                  | CNot (Condition c)                  | COr (Condition c) (Condition c)                  | CAnd (Condition c) (Condition c)-    deriving (Show, Eq)+    deriving (Show, Eq, Typeable, Data)  --instance Text c => Text (Condition c) where --  disp (Var x) = text (show x)@@ -1016,7 +1010,7 @@                               , CondTree v c a                               , Maybe (CondTree v c a))]     }-    deriving (Show, Eq)+    deriving (Show, Eq, Typeable, Data)  --instance (Text v, Text c) => Text (CondTree v c a) where --  disp (CondNode _dat cs ifs) =
Distribution/PackageDescription/Check.hs view
@@ -70,7 +70,6 @@ import qualified System.Directory as System          ( doesFileExist, doesDirectoryExist ) -import Distribution.Package ( pkgName ) import Distribution.PackageDescription import Distribution.PackageDescription.Configuration          ( flattenPackageDescription, finalizePackageDescription )@@ -80,6 +79,8 @@          ( OS(..), Arch(..), buildPlatform ) import Distribution.License          ( License(..), knownLicenses )+import Distribution.Simple.CCompiler+         ( filenameCDialect ) import Distribution.Simple.Utils          ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase ) @@ -92,7 +93,7 @@          , asVersionIntervals, UpperBound(..), isNoVersion ) import Distribution.Package          ( PackageName(PackageName), packageName, packageVersion-         , Dependency(..) )+         , Dependency(..), pkgName )  import Distribution.Text          ( display, disp )@@ -138,6 +139,7 @@        -- quite legitimately refuse to publicly distribute packages with these        -- problems.      | PackageDistInexcusable { explanation :: String }+  deriving (Eq)  instance Show PackageCheck where     show notice = explanation notice@@ -146,6 +148,12 @@ check False _  = Nothing check True  pc = Just pc +checkSpecVersion :: PackageDescription -> [Int] -> Bool -> PackageCheck -> Maybe PackageCheck+checkSpecVersion pkg specver cond pc+  | specVersion pkg >= Version specver [] = Nothing+  | otherwise                             = check cond pc++ -- ------------------------------------------------------------ -- * Standard checks -- ------------------------------------------------------------@@ -171,7 +179,7 @@     pkg = fromMaybe (flattenPackageDescription gpkg) mpkg  --TODO: make this variant go away---      we should alwaws know the GenericPackageDescription+--      we should always know the GenericPackageDescription checkConfiguredPackage :: PackageDescription -> [PackageCheck] checkConfiguredPackage pkg =     checkSanity pkg@@ -212,10 +220,10 @@   ]   --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)+  ++ maybe []  (checkLibrary    pkg) (library pkg)+  ++ concatMap (checkExecutable pkg) (executables pkg)+  ++ concatMap (checkTestSuite  pkg) (testSuites pkg)+  ++ concatMap (checkBenchmark  pkg) (benchmarks pkg)    ++ catMaybes [ @@ -231,8 +239,8 @@     bmNames = map benchmarkName $ benchmarks pkg     duplicateNames = dups $ exeNames ++ testNames ++ bmNames -checkLibrary :: Library -> [PackageCheck]-checkLibrary lib =+checkLibrary :: PackageDescription -> Library -> [PackageCheck]+checkLibrary _pkg lib =   catMaybes [      check (not (null moduleDuplicates)) $@@ -244,20 +252,28 @@   where     moduleDuplicates = dups (libModules lib) -checkExecutable :: Executable -> [PackageCheck]-checkExecutable exe =+checkExecutable :: PackageDescription -> Executable -> [PackageCheck]+checkExecutable pkg exe =   catMaybes [      check (null (modulePath exe)) $       PackageBuildImpossible $-        "No 'Main-Is' field found for executable " ++ exeName exe+        "No 'main-is' field found for executable " ++ exeName exe    , check (not (null (modulePath exe))-       && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $+       && (not $ fileExtensionSupportedLanguage $ modulePath exe)) $       PackageBuildImpossible $-           "The 'Main-Is' field must specify a '.hs' or '.lhs' file "-        ++ "(even if it is generated by a preprocessor)."+           "The 'main-is' field must specify a '.hs' or '.lhs' file "+        ++ "(even if it is generated by a preprocessor), "+        ++ "or it may specify a C/C++/obj-C source file." +  , checkSpecVersion pkg [1,17]+          (fileExtensionSupportedLanguage (modulePath exe)+        && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $+      PackageDistInexcusable $+           "The package uses a C/C++/obj-C source file for the 'main-is' field. "+        ++ "To use this feature you must specify 'cabal-version: >= 1.18'."+   , check (not (null moduleDuplicates)) $        PackageBuildWarning $             "Duplicate modules in executable '" ++ exeName exe ++ "': "@@ -292,8 +308,14 @@   , check mainIsWrongExt $       PackageBuildImpossible $            "The 'main-is' field must specify a '.hs' or '.lhs' file "-        ++ "(even if it is generated by a preprocessor)."+        ++ "(even if it is generated by a preprocessor), "+        ++ "or it may specify a C/C++/obj-C source file." +  , checkSpecVersion pkg [1,17] (mainIsNotHsExt && not mainIsWrongExt) $+      PackageDistInexcusable $+           "The package uses a C/C++/obj-C source file for the 'main-is' field. "+        ++ "To use this feature you must specify 'cabal-version: >= 1.18'."+     -- 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.@@ -306,6 +328,10 @@     moduleDuplicates = dups $ testModules test      mainIsWrongExt = case testInterface test of+      TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f+      _                   -> False++    mainIsNotHsExt = case testInterface test of       TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]       _                   -> False @@ -412,7 +438,7 @@       PackageDistSuspicious $            "Deprecated extensions: "         ++ commaSep (map (quote . display . fst) deprecatedExtensions)-        ++ ". " ++ intercalate " "+        ++ ". " ++ unwords              [ "Instead of '" ++ display ext             ++ "' use '" ++ display replacement ++ "'."              | (ext, Just replacement) <- deprecatedExtensions ]@@ -424,7 +450,7 @@       PackageDistSuspicious "No 'maintainer' field."    , check (null (synopsis pkg) && null (description pkg)) $-      PackageDistInexcusable $ "No 'synopsis' or 'description' field."+      PackageDistInexcusable "No 'synopsis' or 'description' field."    , check (null (description pkg) && not (null (synopsis pkg))) $       PackageDistSuspicious "No 'description' field."@@ -517,6 +543,9 @@     unknownLicenseVersion (LGPL (Just v))       | v `notElem` knownVersions = Just knownVersions       where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ]+    unknownLicenseVersion (AGPL (Just v))+      | v `notElem` knownVersions = Just knownVersions+      where knownVersions = [ v' | AGPL (Just v') <- knownLicenses ]     unknownLicenseVersion (Apache  (Just v))       | v `notElem` knownVersions = Just knownVersions       where knownVersions = [ v' | Apache  (Just v') <- knownLicenses ]@@ -532,19 +561,19 @@                    ++ "The repo kind is usually 'head' or 'this'"       _ -> Nothing -  , check (repoType repo == Nothing) $+  , check (isNothing (repoType repo)) $       PackageDistInexcusable         "The source-repository 'type' is a required field." -  , check (repoLocation repo == Nothing) $+  , check (isNothing (repoLocation repo)) $       PackageDistInexcusable         "The source-repository 'location' is a required field." -  , check (repoType repo == Just CVS && repoModule repo == Nothing) $+  , check (repoType repo == Just CVS && isNothing (repoModule repo)) $       PackageDistInexcusable         "For a CVS source-repository, the 'module' is a required field." -  , check (repoKind repo == RepoThis && repoTag repo == Nothing) $+  , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $       PackageDistInexcusable $            "For the 'this' kind of source-repository, the 'tag' is a required "         ++ "field. It should specify the tag corresponding to this version "@@ -825,6 +854,7 @@     relPaths =          [ (path, "extra-src-files") | path <- extraSrcFiles pkg ]       ++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ]+      ++ [ (path, "extra-doc-files") | path <- extraDocFiles pkg ]       ++ [ (path, "data-files")      | path <- dataFiles     pkg ]       ++ [ (path, "data-dir")        | path <- [dataDir      pkg]]       ++ concat@@ -1092,7 +1122,7 @@         (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v'))         intersectVersionRanges unionVersionRanges id -    compatLicenses = [ GPL Nothing, LGPL Nothing, BSD3, BSD4+    compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4                      , PublicDomain, AllRightsReserved, OtherLicense ]      mentionedExtensions = [ ext | bi <- allBuildInfo pkg@@ -1199,7 +1229,7 @@   ]   where     -- TODO: What we really want to do is test if there exists any-    -- configuration in which the base version is unboudned above.+    -- configuration in which the base version is unbounded 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@@ -1493,3 +1523,11 @@  dups :: Ord a => [a] -> [a] dups xs = [ x | (x:_:_) <- group (sort xs) ]++fileExtensionSupportedLanguage :: FilePath -> Bool+fileExtensionSupportedLanguage path =+    isHaskell || isC+  where+    extension = takeExtension path+    isHaskell = extension `elem` [".hs", ".lhs"]+    isC       = isJust (filenameCDialect extension)
Distribution/PackageDescription/Configuration.hs view
@@ -1,13 +1,8 @@-{-# 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 #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-} ----------------------------------------------------------------------------- -- |--- Module      :  Distribution.Configuration+-- Module      :  Distribution.PackageDescription.Configuration -- Copyright   :  Thomas Schilling, 2007 -- -- Maintainer  :  cabal-devel@haskell.org@@ -70,6 +65,8 @@          , Flag(..), FlagName(..), FlagAssignment          , Benchmark(..), CondTree(..), ConfVar(..), Condition(..)          , TestSuite(..) )+import Distribution.PackageDescription.Utils+         ( cabalBug, userBug ) import Distribution.Version          ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) import Distribution.Compiler@@ -91,11 +88,6 @@ 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.@@ -220,7 +212,7 @@ 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.+-- | Try to find a flag assignment that satisfies the constraints of all trees. -- -- Returns either the missing dependencies, or a tuple containing the -- resulting data, the associated dependencies, and the chosen flag@@ -315,35 +307,8 @@ -- | 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) =@@ -361,7 +326,7 @@                  -> CondTree v d a                  -> (d, a) simplifyCondTree env (CondNode a d ifs) =-    foldr mappend (d, a) $ catMaybes $ map simplifyIf ifs+    mconcat $ (d, a) : catMaybes (map simplifyIf ifs)   where     simplifyIf (cnd, t, me) =         case simplifyCondition cnd env of@@ -431,7 +396,7 @@         , [(String, Benchmark)]) flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], []) targets   where-    untag (_, Lib _) (Just _, _, _, _) = bug "Only one library expected"+    untag (_, Lib _) (Just _, _, _, _) = userBug "Only one library expected"     untag (deps, Lib l) (Nothing, exes, tests, bms) =         (Just l', exes, tests, bms)       where@@ -439,29 +404,38 @@                 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)+        | any ((== n) . fst) exes =+          userBug $ "There exist several exes with the same name: '" ++ n ++ "'"+        | any ((== n) . fst) tests =+          userBug $ "There exists a test with the same name as an exe: '" ++ n ++ "'"+        | any ((== n) . fst) bms =+          userBug $ "There exists a benchmark with the same name as an exe: '" ++ n ++ "'"+        | otherwise = (mlib, (n, e'):exes, 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)+        | any ((== n) . fst) tests =+          userBug $ "There exist several tests with the same name: '" ++ n ++ "'"+        | any ((== n) . fst) exes =+          userBug $ "There exists an exe with the same name as the test: '" ++ n ++ "'"+        | any ((== n) . fst) bms =+          userBug $ "There exists a benchmark with the same name as the test: '" ++ n ++ "'"+        | otherwise = (mlib, exes, (n, t'):tests, 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')])+        | any ((== n) . fst) bms =+          userBug $ "There exist several benchmarks with the same name: '" ++ n ++ "'"+        | any ((== n) . fst) exes =+          userBug $ "There exists an exe with the same name as the benchmark: '" ++ n ++ "'"+        | any ((== n) . fst) tests =+          userBug $ "There exists a test with the same name as the benchmark: '" ++ n ++ "'"+        | otherwise = (mlib, exes, tests, (n, b'):bms)       where         b' = b {             benchmarkBuildInfo = (benchmarkBuildInfo b)@@ -489,7 +463,7 @@     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"+    _ `mappend` _ = cabalBug "Cannot combine incompatible tags"  -- | Create a package description with all configurations resolved. --@@ -647,6 +621,3 @@     if null (hsSourceDirs bi)     then bi { hsSourceDirs = [currentDir] }     else bi--bug :: String -> a-bug msg = error $ msg ++ ". Consider this a bug."
Distribution/PackageDescription/Parse.hs view
@@ -72,8 +72,11 @@ import Data.Maybe (listToMaybe, isJust) import Data.Monoid ( Monoid(..) ) import Data.List  (nub, unfoldr, partition, (\\))-import Control.Monad (liftM, foldM, when, unless)+import Control.Monad (liftM, foldM, when, unless, ap)+import Control.Applicative (Applicative(..))+import Control.Arrow (first) import System.Directory (doesFileExist)+import qualified Data.ByteString.Lazy.Char8 as BS.Char8  import Distribution.Text          ( Text(disp, parse), display, simpleParse )@@ -83,6 +86,8 @@  import Distribution.ParseUtils hiding (parseFields) import Distribution.PackageDescription+import Distribution.PackageDescription.Utils+         ( cabalBug, userBug ) import Distribution.Package          ( PackageIdentifier(..), Dependency(..), packageName, packageVersion ) import Distribution.ModuleName ( ModuleName )@@ -169,13 +174,16 @@  , listField "extra-tmp-files"            showFilePath       parseFilePathQ            extraTmpFiles          (\val pkg -> pkg{extraTmpFiles=val})+ , listField "extra-doc-files"+           showFilePath    parseFilePathQ+           extraDocFiles          (\val pkg -> pkg{extraDocFiles=val})  ]  -- | Store any fields beginning with "x-" in the customFields field of --   a PackageDescription.  All other fields will generate a warning. storeXFieldsPD :: UnrecFieldParser PackageDescription storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD =-                                                        (customFieldsPD pkg) ++ [(f,val)]}+                                                        customFieldsPD pkg ++ [(f,val)]} storeXFieldsPD _ _ = Nothing  -- ---------------------------------------------------------------------------@@ -193,7 +201,7 @@  storeXFieldsLib :: UnrecFieldParser Library storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) =-    Just $ l {libBuildInfo = bi{ customFieldsBI = (customFieldsBI bi) ++ [(f,val)]}}+    Just $ l {libBuildInfo = bi{ customFieldsBI = customFieldsBI bi ++ [(f,val)]}} storeXFieldsLib _ _ = Nothing  -- ---------------------------------------------------------------------------@@ -216,7 +224,7 @@  storeXFieldsExe :: UnrecFieldParser Executable storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) =-    Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}+    Just $ e {buildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}} storeXFieldsExe _ _ = Nothing  -- ---------------------------------------------------------------------------@@ -253,7 +261,7 @@  storeXFieldsTest :: UnrecFieldParser TestSuiteStanza storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) =-    Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}+    Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}} storeXFieldsTest _ _ = Nothing  validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite@@ -339,7 +347,7 @@ storeXFieldsBenchmark (f@('x':'-':_), val)     t@(BenchmarkStanza { benchmarkStanzaBuildInfo = bi }) =         Just $ t {benchmarkStanzaBuildInfo =-                       bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}+                       bi{ customFieldsBI = (f,val):customFieldsBI bi}} storeXFieldsBenchmark _ _ = Nothing  validateBenchmark :: LineNo -> BenchmarkStanza -> ParseResult Benchmark@@ -462,7 +470,7 @@  ]  storeXFieldsBI :: UnrecFieldParser BuildInfo-storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) }+storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):customFieldsBI bi } storeXFieldsBI _ _ = Nothing  ------------------------------------------------------------------------------@@ -513,7 +521,8 @@                  -> 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.")+  unless 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@@ -546,9 +555,9 @@  mapSimpleFields :: (Field -> ParseResult Field) -> [Field]                 -> ParseResult [Field]-mapSimpleFields f fs = mapM walk fs+mapSimpleFields f = mapM walk   where-    walk fld@(F _ _ _) = f fld+    walk fld@F{} = f fld     walk (IfBlock l c fs1 fs2) = do       fs1' <- mapM walk fs1       fs2' <- mapM walk fs2@@ -571,7 +580,7 @@ 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 ++ ")"+parseConstraint f = userBug $ "Constraint was expected (got: " ++ show f ++ ")"  {- headerFieldNames :: [String]@@ -595,6 +604,13 @@ -- on the 'mtl' package. newtype StT s m a = StT { runStT :: s -> m (a,s) } +instance Functor f => Functor (StT s f) where+    fmap g (StT f) = StT $ fmap (first g)  . f++instance (Monad m, Functor m) => Applicative (StT s m) where+    pure = return+    (<*>) = ap+ instance Monad m => Monad (StT s m) where     return a = StT (\s -> return (a,s))     StT f >>= g = StT $ \s -> do@@ -611,7 +627,7 @@ 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+evalStT st s = liftM fst $ runStT st s  -- Our monad for parsing a list/tree of fields. --@@ -622,7 +638,7 @@  -- return look-ahead field or nothing if we're at the end of the file peekField :: PM (Maybe Field)-peekField = get >>= return . listToMaybe+peekField = liftM listToMaybe get  -- Unconditionally discard the first field in our state.  Will error when it -- reaches end of file.  (Yes, that's evil.)@@ -710,7 +726,7 @@                    flags mlib exes tests bms    where-    oldSyntax flds = all isSimpleField flds+    oldSyntax = all isSimpleField     reportTabsError tabs =         syntaxError (fst (head tabs)) $           "Do not use tabs for indentation (use spaces instead)\n"@@ -780,7 +796,7 @@               | e == "executable" =                   let (efs, r') = break ((=="executable") . fName) r                   in Just (Section l "executable" n (deps ++ efs), r')-            toExe _ = bug "unexpeced input to 'toExe'"+            toExe _ = cabalBug "unexpected input to 'toExe'"           in             hdr ++            (if null libfs then []@@ -788,7 +804,7 @@             ++ exes       | otherwise = fs -    isSimpleField (F _ _ _) = True+    isSimpleField F{} = True     isSimpleField _ = False      -- warn if there's something at the end of the file@@ -803,7 +819,7 @@     -- fields     getHeader :: [Field] -> PM [Field]     getHeader acc = peekField >>= \mf -> case mf of-        Just f@(F _ _ _) -> skipField >> getHeader (f:acc)+        Just f@F{} -> skipField >> getHeader (f:acc)         _ -> return (reverse acc)      --@@ -862,7 +878,7 @@                     -- 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)+                    in hasTestType || any checkComponent components             if checkTestType emptyTestSuite flds                 then do                     skipField@@ -910,7 +926,7 @@                     -- 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)+                    in hasBenchmarkType || any checkComponent components             if checkBenchmarkType emptyBenchmark flds                 then do                     skipField@@ -924,7 +940,7 @@                       ++ intercalate ", " (map display knownBenchmarkTypes)          | sec_type == "library" -> do-            when (not (null sec_label)) $ lift $+            unless (null sec_label) $ lift $               syntaxError line_no "'library' expects no argument"             flds <- collectFields parseLibFields sec_fields             skipField@@ -956,7 +972,7 @@             repo <- lift $ parseFields                     sourceRepoFieldDescrs                     warnUnrec-                    (SourceRepo {+                    SourceRepo {                       repoKind     = kind,                       repoType     = Nothing,                       repoLocation = Nothing,@@ -964,7 +980,7 @@                       repoBranch   = Nothing,                       repoTag      = Nothing,                       repoSubdir   = Nothing-                    })+                    }                     sec_fields             skipField             (repos, flags, lib, exes, tests, bms) <- getBody@@ -990,7 +1006,7 @@     collectFields parser allflds = do          let simplFlds = [ F l n v | F l n v <- allflds ]-            condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ]+            condFlds = [ f | f@IfBlock{} <- allflds ]          let (depFlds, dataFlds) = partition isConstraint simplFlds @@ -1012,7 +1028,7 @@                    es -> do fs <- collectFields parser es                             return (Just fs)             return (cnd, t', e')-        processIfs _ = bug "processIfs called with wrong field type"+        processIfs _ = cabalBug "processIfs called with wrong field type"      parseLibFields :: [Field] -> PM Library     parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary@@ -1048,7 +1064,7 @@     checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()     checkCondTreeFlags definedFlags ct = do         let fv = nub $ freeVars ct-        when (not . all (`elem` definedFlags) $ fv) $+        unless (all (`elem` definedFlags) fv) $             fail $ "These flags are used without having been defined: "                 ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] @@ -1066,14 +1082,13 @@             -> 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)+       unless (null unknowns) $ 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@@ -1084,14 +1099,14 @@            -> (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)+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"+    Nothing -> (a, (l,f):us)+parseField _ _ _ _ = cabalBug "'parseField' called on a non-field"  deprecatedFields :: [(String,String)] deprecatedFields =@@ -1113,7 +1128,7 @@                       ++ "\" is deprecated, please use \"" ++ newName ++ "\""               return newName   return (F line fld' val)-deprecField _ = bug "'deprecField' called on a non-field"+deprecField _ = cabalBug "'deprecField' called on a non-field"   parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo@@ -1125,17 +1140,17 @@   return (mLib, biExes)   where     parseLib :: [Field] -> ParseResult (Maybe BuildInfo)-    parseLib (bi@((F _ inFieldName _):_))+    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)+    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 (_:_) = cabalBug "`parseExe' called on a non-field"     parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza"      parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st@@ -1168,7 +1183,8 @@ ppCustomField (name,val) = text name <> colon <+> showFreeText val  writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()-writeHookedBuildInfo fpath = writeFileAtomic fpath . showHookedBuildInfo+writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack+                             . showHookedBuildInfo  showHookedBuildInfo :: HookedBuildInfo -> String showHookedBuildInfo (mb_lib_bi, ex_bis) = render $@@ -1198,6 +1214,3 @@  --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."
Distribution/PackageDescription/PrettyPrint.hs view
@@ -46,8 +46,10 @@     showGenericPackageDescription, ) where +import Data.Monoid (Monoid(mempty)) import Distribution.PackageDescription-       ( TestSuite(..), TestSuiteInterface(..), testType+       ( Benchmark(..), BenchmarkInterface(..), benchmarkType+       , TestSuite(..), TestSuiteInterface(..), testType        , SourceRepo(..),         customFieldsBI, CondTree(..), Condition(..),         FlagName(..), ConfVar(..), Executable(..), Library(..),@@ -86,6 +88,7 @@         $+$ ppLibrary (condLibrary gpd)         $+$ ppExecutables (condExecutables gpd)         $+$ ppTestSuites (condTestSuites gpd)+        $+$ ppBenchmarks (condBenchmarks gpd)  ppPackageDescription :: PackageDescription -> Doc ppPackageDescription pd                  =      ppFields pkgDescrFieldDescrs pd@@ -169,13 +172,17 @@                      | (n,condTree) <- suites]   where     ppTestSuite testsuite Nothing =-                text "type:" <+> disp (testType testsuite)+                maybe empty (\t -> text "type:"        <+> disp t)+                            maybeTestType             $+$ 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))+      where+        maybeTestType | testInterface testsuite == mempty = Nothing+                      | otherwise = Just (testType testsuite)      ppTestSuite (TestSuite _ _ buildInfo' _)                     (Just (TestSuite _ _ buildInfo2 _)) =@@ -188,6 +195,32 @@      testSuiteModule test = case testInterface test of       TestSuiteLibV09 _ m -> Just m+      _                   -> Nothing++ppBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] -> Doc+ppBenchmarks suites =+    emptyLine $ vcat [     text ("benchmark " ++ n)+                       $+$ nest indentWith (ppCondTree condTree Nothing ppBenchmark)+                     | (n,condTree) <- suites]+  where+    ppBenchmark benchmark Nothing =+                maybe empty (\t -> text "type:"        <+> disp t)+                            maybeBenchmarkType+            $+$ maybe empty (\f -> text "main-is:"     <+> text f)+                            (benchmarkMainIs benchmark)+            $+$ ppFields binfoFieldDescrs (benchmarkBuildInfo benchmark)+            $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark))+      where+        maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing+                           | otherwise = Just (benchmarkType benchmark)++    ppBenchmark (Benchmark _ _ buildInfo' _)+                    (Just (Benchmark _ _ buildInfo2 _)) =+            ppDiffFields binfoFieldDescrs buildInfo' buildInfo2+            $+$ ppCustomFields (customFieldsBI buildInfo')++    benchmarkMainIs benchmark = case benchmarkInterface benchmark of+      BenchmarkExeV10 _ f -> Just f       _                   -> Nothing  ppCondition :: Condition ConfVar -> Doc
+ Distribution/PackageDescription/Utils.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.PackageDescription.Utils+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Common utils used by modules under Distribution.PackageDescription.*.++module Distribution.PackageDescription.Utils (+  cabalBug, userBug+  ) where++-- ----------------------------------------------------------------------------+-- Exception and logging utils++userBug :: String -> a+userBug msg = error $ msg ++ ". This is a bug in your .cabal file."++cabalBug :: String -> a+cabalBug msg = error $ msg ++ ". This is possibly a bug in Cabal.\n"+               ++ "Please report it to the developers: "+               ++ "https://github.com/haskell/cabal/issues/new"
Distribution/ParseUtils.hs view
@@ -47,13 +47,14 @@  -- This module is meant to be local-only to Distribution... --- #hide+{-# OPTIONS_HADDOCK 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,+        showFields, showSingleNamedField, showSimpleSingleNamedField,+        parseFields, parseFieldsFlat,         parseFilePathQ, parseTokenQ, parseTokenQ',         parseModuleNameQ, parseBuildTool, parsePkgconfigDependency,         parseOptVersion, parsePackageNameQ, parseVersionRangeQ,@@ -86,7 +87,8 @@ import Data.Maybe       (fromMaybe) import Data.Tree as Tree (Tree(..), flatten) import qualified Data.Map as Map-import Control.Monad (foldM)+import Control.Monad (foldM, ap) +import Control.Applicative (Applicative(..)) import System.FilePath (normalise) import Data.List (sortBy) @@ -94,15 +96,15 @@  type LineNo = Int -data PError = AmbigousParse String LineNo+data PError = AmbiguousParse String LineNo             | NoParse String LineNo             | TabsError LineNo             | FromString String (Maybe LineNo)-        deriving Show+        deriving (Eq, Show)  data PWarning = PWarning String               | UTFWarning LineNo String-        deriving Show+        deriving (Eq, Show)  showPWarning :: FilePath -> PWarning -> String showPWarning fpath (PWarning msg) =@@ -114,8 +116,17 @@ data ParseResult a = ParseFailed PError | ParseOk [PWarning] a         deriving Show +instance Functor ParseResult where+        fmap _ (ParseFailed err) = ParseFailed err+        fmap f (ParseOk ws x) = ParseOk ws $ f x+        +instance Applicative ParseResult where+        pure = return+        (<*>) = ap+        + instance Monad ParseResult where-        return x = ParseOk [] x+        return = ParseOk []         ParseFailed err >>= _ = ParseFailed err         ParseOk ws x >>= f = case f x of                                ParseFailed err -> ParseFailed err@@ -139,8 +150,8 @@     []  -> 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)+             _   -> ParseFailed (AmbiguousParse fieldname line)+    _   -> ParseFailed (AmbiguousParse fieldname line)   where results = readP_to_S p s  runE :: LineNo -> String -> ReadE a -> String -> ParseResult a@@ -157,10 +168,12 @@          , '\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)+locatedErrorMsg (AmbiguousParse 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)@@ -183,7 +196,7 @@         -- successful.  Otherwise, reports an error on line number @n@.       } -field :: String -> (a -> Doc) -> (ReadP a a) -> FieldDescr a+field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a field name showF readF =   FieldDescr name showF (\line val _st -> runP line name readF val) @@ -191,7 +204,7 @@ -- 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))+ = FieldDescr name (showF . get)         (\line str b -> do             a <- parseF line str (get b)             return (set a b))@@ -199,12 +212,12 @@ -- 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)+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)+commaListField :: String -> (a -> Doc) -> ReadP [a] a                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b commaListField name showF readF get set =   liftField get set' $@@ -212,7 +225,7 @@   where     set' xs b = set (get b ++ xs) b -spaceListField :: String -> (a -> Doc) -> (ReadP [a] a)+spaceListField :: String -> (a -> Doc) -> ReadP [a] a                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b spaceListField name showF readF get set =   liftField get set' $@@ -220,7 +233,7 @@   where     set' xs b = set (get b ++ xs) b -listField :: String -> (a -> Doc) -> (ReadP [a] a)+listField :: String -> (a -> Doc) -> ReadP [a] a                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b listField name showF readF get set =   liftField get set' $@@ -228,7 +241,8 @@   where     set' xs b = set (get b ++ xs) b -optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr 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) $@@ -244,7 +258,7 @@  -- 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!+--       because it does not support warnings. We need a new parser framework! boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b boolField name get set = liftField get set (FieldDescr name showF readF)   where@@ -276,12 +290,19 @@     []      -> Nothing     (get:_) -> Just (render . ppField f . get) +showSimpleSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String)+showSimpleSingleNamedField fields f =+  case [ get | (FieldDescr f' get _) <- fields, f' == f ] of+    []      -> Nothing+    (get:_) -> Just (renderStyle myStyle . get)+ where myStyle = style { mode = LeftMode }+ parseFields :: [FieldDescr a] -> a -> String -> ParseResult a-parseFields fields initial = \str ->+parseFields fields initial str =   readFields str >>= accumFields fields initial  parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a-parseFieldsFlat fields initial = \str ->+parseFieldsFlat fields initial str =   readFieldsFlat str >>= accumFields fields initial  accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a@@ -314,7 +335,7 @@ --   warnings will be generated) ignores unrecognized fields, by --   returning the structure being built unmodified. ignoreUnrec :: UnrecFieldParser a-ignoreUnrec _ x = Just x+ignoreUnrec _ = Just  ------------------------------------------------------------------------------ @@ -370,7 +391,7 @@  -- attach line number and determine indentation trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)]-trimLines ls = [ (lineno, indent, hastabs, (trimTrailing l'))+trimLines ls = [ (lineno, indent, hastabs, trimTrailing l')                | (lineno, l) <- zip [1..] ls                , let (sps, l') = span isSpace l                      indent    = length sps@@ -492,7 +513,7 @@         ([], _)   -> 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 _ _ (   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@@ -567,7 +588,8 @@        | 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 "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''')@@ -585,11 +607,16 @@   -- removed until normalise is no longer broken, was:   --   liftM normalise parseTokenQ +betweenSpaces :: ReadP r a -> ReadP r a+betweenSpaces act = do skipSpaces+                       res <- act+                       skipSpaces+                       return res+ parseBuildTool :: ReadP r Dependency parseBuildTool = do name <- parseBuildToolNameQ-                    skipSpaces-                    ver <- parseVersionRangeQ <++ return anyVersion-                    skipSpaces+                    ver <- betweenSpaces $+                           parseVersionRangeQ <++ return anyVersion                     return $ Dependency name ver  parseBuildToolNameQ :: ReadP r PackageName@@ -607,10 +634,10 @@ -- 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+parsePkgconfigDependency = do name <- munch1+                                      (\c -> isAlphaNum c || c `elem` "+-._")+                              ver <- betweenSpaces $+                                     parseVersionRangeQ <++ return anyVersion                               return $ Dependency (PackageName name) ver  parsePackageNameQ :: ReadP r PackageName@@ -630,9 +657,7 @@   where     tw :: ReadP r (CompilerFlavor,VersionRange)     tw = do compiler <- parseCompilerFlavorCompat-            skipSpaces-            version <- parse <++ return anyVersion-            skipSpaces+            version <- betweenSpaces $ parse <++ return anyVersion             return (compiler,version)  parseLicenseQ :: ReadP r License@@ -656,13 +681,13 @@ parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',')  parseTokenQ' :: ReadP r String-parseTokenQ' = parseHaskellString <++ munch1 (\x -> not (isSpace x))+parseTokenQ' = parseHaskellString <++ munch1 (not . isSpace)  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+    where separator = betweenSpaces sepr  parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas                -> ReadP r [a]@@ -677,7 +702,7 @@ parseOptCommaList = parseSepList (optional (ReadP.char ','))  parseQuoted :: ReadP r a -> ReadP r a-parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p+parseQuoted = between (ReadP.char '"') (ReadP.char '"')  parseFreeText :: ReadP.ReadP s String parseFreeText = ReadP.munch (const True)
Distribution/ReadE.hs view
@@ -63,14 +63,14 @@ succeedReadE f = ReadE (Right . f)  failReadE :: ErrorMsg -> ReadE a-failReadE = ReadE . const Left+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 :: ReadE a -> String -> a readEOrFail r = either error id . runReadE r  readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a
Distribution/Simple.hs view
@@ -101,7 +101,7 @@ import Distribution.Simple.Setup import Distribution.Simple.Command -import Distribution.Simple.Build        ( build )+import Distribution.Simple.Build        ( build, repl ) import Distribution.Simple.SrcDist      ( sdist ) import Distribution.Simple.Register          ( register, unregister )@@ -131,15 +131,17 @@          ( display )  -- Base-import System.Environment(getArgs, getProgName, getEnvironment)+import System.Environment(getArgs, getProgName) import System.Directory(removeFile, doesFileExist,                         doesDirectoryExist, removeDirectoryRecursive) import System.Exit import System.IO.Error   (isDoesNotExistError)-import Distribution.Compat.Exception (catchIO, throwIOIO)+import Control.Exception (throwIO)+import Distribution.Compat.Environment (getEnvironment)+import Distribution.Compat.Exception (catchIO)  import Control.Monad   (when)-import Data.List       (intersperse, unionBy, nub, (\\))+import Data.List       (intercalate, unionBy, nub, (\\))  -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the@@ -187,7 +189,7 @@     printHelp help = getProgName >>= putStr . help     printOptionsList = putStr . unlines     printErrors errs = do-      putStr (concat (intersperse "\n" errs))+      putStr (intercalate "\n" errs)       exitWith (ExitFailure 1)     printNumericVersion = putStrLn $ display cabalVersion     printVersion        = putStrLn $ "Cabal library version "@@ -198,6 +200,7 @@       [configureCommand progs `commandAddAction` \fs as ->                                                  configureAction    hooks fs as >> return ()       ,buildCommand     progs `commandAddAction` buildAction        hooks+      ,replCommand      progs `commandAddAction` replAction         hooks       ,installCommand         `commandAddAction` installAction      hooks       ,copyCommand            `commandAddAction` copyAction         hooks       ,haddockCommand         `commandAddAction` haddockAction      hooks@@ -272,8 +275,26 @@    hookedAction preBuild buildHook postBuild                (return lbi { withPrograms = progs })-               hooks flags args+               hooks flags { buildArgs = args } args +replAction :: UserHooks -> ReplFlags -> Args -> IO ()+replAction hooks flags args = do+  let distPref  = fromFlag $ replDistPref flags+      verbosity = fromFlag $ replVerbosity flags++  lbi <- getBuildConfig hooks verbosity distPref+  progs <- reconfigurePrograms verbosity+             (replProgramPaths flags)+             (replProgramArgs flags)+             (withPrograms lbi)++  pbi <- preRepl hooks args flags+  let lbi' = lbi { withPrograms = progs }+      pkg_descr0 = localPkgDescr lbi'+      pkg_descr = updatePackageDescription pbi pkg_descr0+  replHook hooks pkg_descr lbi' hooks flags args+  postRepl hooks args flags pkg_descr lbi'+ hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () hscolourAction hooks flags args     = do let distPref  = fromFlag $ hscolourDistPref flags@@ -455,7 +476,7 @@     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. " +                      ++ "Re-configuring with most recently used options. "                       ++ "If this fails, please run configure manually.\n"       let cFlags = configFlags lbi       let cFlags' = cFlags {@@ -502,8 +523,7 @@             isDir <- doesDirectoryExist fname             isFile <- doesFileExist fname             if isDir then removeDirectoryRecursive fname-              else if isFile then removeFile fname-              else return ()+              else when isFile $ removeFile fname         verbosity = fromFlag (cleanVerbosity flags)  -- --------------------------------------------------------------------------@@ -517,6 +537,7 @@        confHook  = configure,        postConf  = finalChecks,        buildHook = defaultBuildHook,+       replHook  = defaultReplHook,        copyHook  = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params        testHook = defaultTestHook,        benchHook = defaultBenchHook,@@ -551,14 +572,14 @@ defaultUserHooks = autoconfUserHooks {           confHook = \pkg flags -> do                        let verbosity = fromFlag (configVerbosity flags)-                       warn verbosity $+                       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+    -- https://github.com/haskell/cabal/issues/158     where oldCompatPostConf args flags pkg_descr lbi               = do let verbosity = fromFlag (configVerbosity flags)                    noExtraFlags args@@ -632,7 +653,7 @@     rawSystemExitWithEnv verbosity "sh" args' env'    where-    args = "configure" : configureArgs backwardsCompatHack flags+    args = "./configure" : configureArgs backwardsCompatHack flags      appendToEnvironment (key, val) [] = [(key, val)]     appendToEnvironment (key, val) (kv@(k, v) : rest)@@ -647,7 +668,7 @@       = action           `catchIO` \ioe -> if isDoesNotExistError ioe                               then die notFoundMsg-                              else throwIOIO ioe+                              else throwIO ioe      notFoundMsg = "The package has a './configure' script. This requires a "                ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin."@@ -692,6 +713,11 @@         -> UserHooks -> BuildFlags -> IO () defaultBuildHook pkg_descr localbuildinfo hooks flags =   build pkg_descr localbuildinfo flags (allSuffixHandlers hooks)++defaultReplHook :: PackageDescription -> LocalBuildInfo+        -> UserHooks -> ReplFlags -> [String] -> IO ()+defaultReplHook pkg_descr localbuildinfo hooks flags args =+  repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args  defaultRegHook :: PackageDescription -> LocalBuildInfo         -> UserHooks -> RegisterFlags -> IO ()
Distribution/Simple/Bench.hs view
@@ -152,5 +152,6 @@     fromPathTemplate $ substPathTemplate env template   where     env = initialPathTemplateEnv-          (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) +++          (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)+          (LBI.hostPlatform lbi) ++           [(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)]
Distribution/Simple/Build.hs view
@@ -3,7 +3,7 @@ -- Module      :  Distribution.Simple.Build -- Copyright   :  Isaac Jones 2003-2005, --                Ross Paterson 2006,---                Duncan Coutts 2007-2008+--                Duncan Coutts 2007-2008, 2012 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -46,7 +46,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}  module Distribution.Simple.Build (-    build,+    build, repl,      initialBuildSteps,     writeAutogenFiles,@@ -73,15 +73,22 @@          , BenchmarkInterface(..) ) import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.ModuleName as ModuleName+import Distribution.ModuleName (ModuleName)  import Distribution.Simple.Setup-         ( BuildFlags(..), fromFlag )+         ( BuildFlags(..), ReplFlags(..), fromFlag )+import Distribution.Simple.BuildTarget+         ( BuildTarget(..), readBuildTargets ) import Distribution.Simple.PreProcess          ( preprocessComponent, PPSuffixHandler ) import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms)-         , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI-         , componentBuildInfo, inplacePackageId )+         , Component(..), componentName, getComponent, componentBuildInfo+         , ComponentLocalBuildInfo(..), pkgEnabledComponents+         , withComponentsInBuildOrder, componentsInBuildOrder+         , ComponentName(..), showComponentName+         , ComponentDisabledReason(..), componentDisabledReason+         , inplacePackageId, LibraryName(..) ) import Distribution.Simple.Program.Types import Distribution.Simple.Program.Db import Distribution.Simple.BuildPaths@@ -91,7 +98,7 @@ import Distribution.Simple.Test ( stubFilePath, stubName ) import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, rewriteFile-         , die, info, setupMessage )+         , die, info, debug, warn, setupMessage )  import Distribution.Verbosity          ( Verbosity )@@ -100,10 +107,12 @@  import Data.Maybe          ( maybeToList )+import Data.Either+         ( partitionEithers ) import Data.List-         ( intersect )+         ( intersect, intercalate ) import Control.Monad-         ( unless )+         ( when, unless, forM_ ) import System.FilePath          ( (</>), (<.>) ) import System.Directory@@ -120,12 +129,21 @@ build pkg_descr lbi flags suffixes = do   let distPref  = fromFlag (buildDistPref flags)       verbosity = fromFlag (buildVerbosity flags)++  targets  <- readBuildTargets pkg_descr (buildArgs flags)+  targets' <- checkBuildTargets verbosity pkg_descr targets+  let componentsToBuild = map fst (componentsInBuildOrder lbi (map fst targets'))+  info verbosity $ "Component build order: "+                ++ intercalate ", " (map showComponentName componentsToBuild)+   initialBuildSteps distPref pkg_descr lbi verbosity-  setupMessage verbosity "Building" (packageId pkg_descr)+  when (null targets) $+    -- Only bother with this message if we're building the whole package+    setupMessage verbosity "Building" (packageId pkg_descr)    internalPackageDB <- createInternalPackageDB distPref -  withComponentsLBI pkg_descr lbi $ \comp clbi ->+  withComponentsInBuildOrder pkg_descr lbi componentsToBuild $ \comp clbi ->     let bi     = componentBuildInfo comp         progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)         lbi'   = lbi {@@ -135,6 +153,52 @@     in buildComponent verbosity pkg_descr lbi' suffixes comp clbi distPref  +repl     :: PackageDescription  -- ^ Mostly information from the .cabal file+         -> LocalBuildInfo      -- ^ Configuration information+         -> ReplFlags           -- ^ Flags that the user passed to build+         -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling+         -> [String]+         -> IO ()+repl pkg_descr lbi flags suffixes args = do+  let distPref  = fromFlag (replDistPref flags)+      verbosity = fromFlag (replVerbosity flags)++  targets  <- readBuildTargets pkg_descr args+  targets' <- case targets of+    []       -> return $ take 1 [ componentName c+                                | c <- pkgEnabledComponents pkg_descr ]+    [target] -> fmap (map fst) (checkBuildTargets verbosity pkg_descr [target])+    _        -> die $ "The 'repl' command does not support multiple targets at once."+  let componentsToBuild = componentsInBuildOrder lbi targets'+      componentForRepl  = last componentsToBuild+  debug verbosity $ "Component build order: "+                 ++ intercalate ", "+                      [ showComponentName c | (c,_) <- componentsToBuild ]++  initialBuildSteps distPref pkg_descr lbi verbosity++  internalPackageDB <- createInternalPackageDB distPref+  let lbiForComponent comp lbi' =+        lbi' {+          withPackageDB = withPackageDB lbi ++ [internalPackageDB],+          withPrograms  = addInternalBuildTools pkg_descr lbi'+                            (componentBuildInfo comp) (withPrograms lbi')+        }++  -- build any dependent components+  sequence_+    [ let comp = getComponent pkg_descr cname+          lbi' = lbiForComponent comp lbi+       in buildComponent verbosity pkg_descr lbi' suffixes comp clbi distPref+    | (cname, clbi) <- init componentsToBuild ]++  -- repl for target components+  let (cname, clbi) = componentForRepl+      comp = getComponent pkg_descr cname+      lbi' = lbiForComponent comp lbi+   in replComponent verbosity pkg_descr lbi' suffixes comp clbi distPref++ buildComponent :: Verbosity                -> PackageDescription                -> LocalBuildInfo@@ -171,15 +235,9 @@   buildComponent verbosity pkg_descr lbi suffixes-               comp@(CTest-                 test@TestSuite { testInterface = TestSuiteExeV10 _ f })+               comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })                clbi _distPref = do-    let bi  = testBuildInfo test-        exe = Executable {-                exeName    = testName test,-                modulePath = f,-                buildInfo  = bi-              }+    let exe = testSuiteExeV10AsExe test     preprocessComponent pkg_descr comp lbi False verbosity suffixes     info verbosity $ "Building test suite " ++ testName test ++ "..."     buildExe verbosity pkg_descr lbi exe clbi@@ -187,51 +245,19 @@  buildComponent verbosity pkg_descr lbi suffixes                comp@(CTest-                 test@TestSuite { testInterface = TestSuiteLibV09 _ m })-               clbi distPref = do+                 test@TestSuite { testInterface = TestSuiteLibV09{} })+               clbi -- This ComponentLocalBuildInfo corresponds to a detailed+                    -- test suite and not a real component. It should not+                    -- be used, except to construct the CLBIs for the+                    -- library and stub executable that will actually be+                    -- built.+               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))-                  }+    let (pkg, lib, libClbi, ipi, exe, exeClbi) =+          testSuiteLibV09AsLibAndExe pkg_descr lbi test clbi distPref pwd     preprocessComponent pkg_descr comp lbi False verbosity suffixes     info verbosity $ "Building test suite " ++ testName test ++ "..."-    buildLib verbosity pkg lbi lib clbi+    buildLib verbosity pkg lbi lib libClbi     registerPackage verbosity ipi pkg lbi True $ withPackageDB lbi     buildExe verbosity pkg_descr lbi exe exeClbi @@ -243,18 +269,12 @@   buildComponent verbosity pkg_descr lbi suffixes-               comp@(CBench-                 bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f })+               comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} })                clbi _ = do-    let bi  = benchmarkBuildInfo bm-        exe = Executable-            { exeName = benchmarkName bm-            , modulePath = f-            , buildInfo  = bi-            }+    let (exe, exeClbi) = benchmarkExeV10asExe bm clbi     preprocessComponent pkg_descr comp lbi False verbosity suffixes     info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..."-    buildExe verbosity pkg_descr lbi exe clbi+    buildExe verbosity pkg_descr lbi exe exeClbi   buildComponent _ _ _ _@@ -263,6 +283,156 @@     die $ "No support for building benchmark type " ++ display tt  +replComponent :: Verbosity+              -> PackageDescription+              -> LocalBuildInfo+              -> [PPSuffixHandler]+              -> Component+              -> ComponentLocalBuildInfo+              -> FilePath+              -> IO ()+replComponent verbosity pkg_descr lbi suffixes+               comp@(CLib lib) clbi _ = do+    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    replLib verbosity pkg_descr lbi lib clbi++replComponent verbosity pkg_descr lbi suffixes+               comp@(CExe exe) clbi _ = do+    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    replExe verbosity pkg_descr lbi exe clbi+++replComponent verbosity pkg_descr lbi suffixes+               comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })+               clbi _distPref = do+    let exe = testSuiteExeV10AsExe test+    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    replExe verbosity pkg_descr lbi exe clbi+++replComponent verbosity pkg_descr lbi suffixes+               comp@(CTest+                 test@TestSuite { testInterface = TestSuiteLibV09{} })+               clbi distPref = do+    pwd <- getCurrentDirectory+    let (pkg, lib, libClbi, _, _, _) =+          testSuiteLibV09AsLibAndExe pkg_descr lbi test clbi distPref pwd+    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    replLib verbosity pkg lbi lib libClbi+++replComponent _ _ _ _+              (CTest TestSuite { testInterface = TestSuiteUnsupported tt })+              _ _ =+    die $ "No support for building test suite type " ++ display tt+++replComponent verbosity pkg_descr lbi suffixes+               comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} })+               clbi _ = do+    let (exe, exeClbi) = benchmarkExeV10asExe bm clbi+    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    replExe verbosity pkg_descr lbi exe exeClbi+++replComponent _ _ _ _+              (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt })+              _ _ =+    die $ "No support for building benchmark type " ++ display tt++----------------------------------------------------+-- Shared code for buildComponent and replComponent+--++-- | Translate a exe-style 'TestSuite' component into an exe for building+testSuiteExeV10AsExe :: TestSuite -> Executable+testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } =+    Executable {+      exeName    = testName test,+      modulePath = mainFile,+      buildInfo  = testBuildInfo test+    }+testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind"++-- | Translate a lib-style 'TestSuite' component into a lib + exe for building+testSuiteLibV09AsLibAndExe :: PackageDescription+                           -> LocalBuildInfo+                           -> TestSuite+                           -> ComponentLocalBuildInfo+                           -> FilePath+                           -> FilePath+                           -> (PackageDescription,+                               Library, ComponentLocalBuildInfo,+                               IPI.InstalledPackageInfo_ ModuleName,+                               Executable, ComponentLocalBuildInfo)+testSuiteLibV09AsLibAndExe pkg_descr lbi+                     test@TestSuite { testInterface = TestSuiteLibV09 _ m }+                     clbi distPref pwd =+    (pkg, lib, libClbi, ipi, exe, exeClbi)+  where+    bi  = testBuildInfo test+    lib = Library {+            exposedModules = [ m ],+            libExposed     = True,+            libBuildInfo   = bi+          }+    libClbi = LibComponentLocalBuildInfo+                { componentPackageDeps = componentPackageDeps clbi+                , componentLibraries = [LibraryName (testName 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 libClbi) {+            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 = ExeComponentLocalBuildInfo {+                componentPackageDeps =+                    (IPI.installedPackageId ipi, packageId ipi)+                  : (filter (\(_, x) -> let PackageName name = pkgName x+                                        in name == "Cabal" || name == "base")+                            (componentPackageDeps clbi))+              }+testSuiteLibV09AsLibAndExe _ _ TestSuite{} _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"+++-- | Translate a exe-style 'Benchmark' component into an exe for building+benchmarkExeV10asExe :: Benchmark -> ComponentLocalBuildInfo+                     -> (Executable, ComponentLocalBuildInfo)+benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f }+                     clbi =+    (exe, exeClbi)+  where+    exe = Executable {+            exeName    = benchmarkName bm,+            modulePath = f,+            buildInfo  = benchmarkBuildInfo bm+          }+    exeClbi = ExeComponentLocalBuildInfo {+                componentPackageDeps = componentPackageDeps clbi+              }+benchmarkExeV10asExe Benchmark{} _ = error "benchmarkExeV10asExe: wrong kind"+ -- | Initialize a new package db file for libraries defined -- internally to the package. createInternalPackageDB :: FilePath -> IO PackageDB@@ -314,6 +484,22 @@     UHC  -> UHC.buildExe  verbosity pkg_descr lbi exe clbi     _    -> die "Building is not supported with this compiler." ++replLib :: Verbosity -> PackageDescription -> LocalBuildInfo+                     -> Library            -> ComponentLocalBuildInfo -> IO ()+replLib verbosity pkg_descr lbi lib clbi =+  case compilerFlavor (compiler lbi) of+    GHC  -> GHC.replLib verbosity pkg_descr lbi lib clbi+    _    -> die "A REPL is not supported for this compiler."++replExe :: Verbosity -> PackageDescription -> LocalBuildInfo+                     -> Executable         -> ComponentLocalBuildInfo -> IO ()+replExe verbosity pkg_descr lbi exe clbi =+  case compilerFlavor (compiler lbi) of+    GHC  -> GHC.replExe verbosity pkg_descr lbi exe clbi+    _    -> die "A REPL is not supported for this compiler."++ initialBuildSteps :: FilePath -- ^"dist" prefix                   -> PackageDescription  -- ^mostly information from the .cabal file                   -> LocalBuildInfo -- ^Configuration information@@ -347,3 +533,48 @@    let cppHeaderPath = autogenModulesDir lbi </> cppHeaderName   rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi)++-- | Check that the given build targets are valid in the current context.+--+-- Also swizzle into a more convenient form.+--+checkBuildTargets :: Verbosity -> PackageDescription -> [BuildTarget]+                  -> IO [(ComponentName, Maybe (Either ModuleName FilePath))]+checkBuildTargets _ pkg []      =+    return [ (componentName c, Nothing) | c <- pkgEnabledComponents pkg ]++checkBuildTargets verbosity pkg targets = do++    let (enabled, disabled) =+          partitionEithers+            [ case componentDisabledReason (getComponent pkg cname) of+                Nothing     -> Left  target'+                Just reason -> Right (cname, reason)+            | target <- targets+            , let target'@(cname,_) = swizzleTarget target ]++    case disabled of+      []                 -> return ()+      ((cname,reason):_) -> die $ formatReason (showComponentName cname) reason++    forM_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) ->+      warn verbosity $ "Ignoring '" ++ either display id t ++ ". The whole "+                    ++ showComponentName c ++ " will be built. (Support for "+                    ++ "module and file targets has not been implemented yet.)"++    return enabled++  where+    swizzleTarget (BuildTargetComponent c)   = (c, Nothing)+    swizzleTarget (BuildTargetModule    c m) = (c, Just (Left  m))+    swizzleTarget (BuildTargetFile      c f) = (c, Just (Right f))++    formatReason cn DisabledComponent =+        "Cannot build the " ++ cn ++ " because the component is marked "+     ++ "as disabled in the .cabal file."+    formatReason cn DisabledAllTests =+        "Cannot build the " ++ cn ++ " because test suites are not "+     ++ "enabled. Run configure with the flag --enable-tests"+    formatReason cn DisabledAllBenchmarks =+        "Cannot build the " ++ cn ++ " because benchmarks are not "+     ++ "enabled. Re-run configure with the flag --enable-benchmarks"
Distribution/Simple/Build/Macros.hs view
@@ -18,7 +18,8 @@ -- numbers. -- module Distribution.Simple.Build.Macros (-    generate+    generate,+    generatePackageVersionMacros,   ) where  import Distribution.Package@@ -36,9 +37,20 @@ -- * Generate cabal_macros.h -- ------------------------------------------------------------ +-- | The contents of the @cabal_macros.h@ for the given configured package.+-- generate :: PackageDescription -> LocalBuildInfo -> String-generate _pkg_descr lbi = concat $-  "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" :+generate _pkg_descr lbi =+  "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" +++  generatePackageVersionMacros (map snd (externalPackageDeps lbi))+++-- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@+-- macros for a list of package ids (usually used with the specific deps of+-- a configured package).+--+generatePackageVersionMacros :: [PackageIdentifier] -> String+generatePackageVersionMacros pkgids = concat   [ concat     ["/* package ",display pkgid," */\n"     ,"#define VERSION_",pkgname," ",show (display version),"\n"@@ -48,7 +60,7 @@     ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"     ,"\n\n"     ]-  | (_, pkgid@(PackageIdentifier name version)) <- externalPackageDeps lbi+  | pkgid@(PackageIdentifier name version) <- pkgids   , let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)         pkgname = map fixchar (display name)   ]
Distribution/Simple/Build/PathsModule.hs view
@@ -68,7 +68,7 @@         "module " ++ display paths_modulename ++ " (\n"++         "    version,\n"++         "    getBinDir, getLibDir, getDataDir, getLibexecDir,\n"++-        "    getDataFileName\n"+++        "    getDataFileName, getSysconfDir\n"++         "  ) where\n"++         "\n"++         foreign_imports++@@ -85,17 +85,19 @@         body         | absolute =-          "\nbindir, libdir, datadir, libexecdir :: FilePath\n"+++          "\nbindir, libdir, datadir, libexecdir, sysconfdir :: FilePath\n"++           "\nbindir     = " ++ show flat_bindir ++           "\nlibdir     = " ++ show flat_libdir ++           "\ndatadir    = " ++ show flat_datadir ++           "\nlibexecdir = " ++ show flat_libexecdir +++          "\nsysconfdir = " ++ show flat_sysconfdir ++           "\n"++-          "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"+++          "\ngetBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: 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"+++          "getSysconfDir = "++mkGetEnvOr "sysconfdir" "return sysconfdir"++"\n"++           "\n"++           "getDataFileName :: FilePath -> IO FilePath\n"++           "getDataFileName name = do\n"++@@ -115,6 +117,8 @@                               (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++           "getLibexecDir :: IO FilePath\n"++           "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"+++          "getSysconfDir :: IO FilePath\n"+++          "getSysconfDir = "++mkGetDir flat_sysconfdir flat_sysconfdirrel++"\n\n"++           "getDataFileName :: FilePath -> IO FilePath\n"++           "getDataFileName name = do\n"++           "  dir <- getDataDir\n"++@@ -131,13 +135,15 @@           bindir     = flat_bindir,           libdir     = flat_libdir,           datadir    = flat_datadir,-          libexecdir = flat_libexecdir+          libexecdir = flat_libexecdir,+          sysconfdir = flat_sysconfdir         } = absoluteInstallDirs pkg_descr lbi NoCopyDest         InstallDirs {           bindir     = flat_bindirrel,           libdir     = flat_libdirrel,           datadir    = flat_datadirrel,           libexecdir = flat_libexecdirrel,+          sysconfdir = flat_sysconfdirrel,           progdir    = flat_progdirrel         } = prefixRelativeInstallDirs (packageId pkg_descr) lbi @@ -181,7 +187,7 @@ -- component of interest. pkgPathEnvVar :: PackageDescription               -> String     -- ^ path component; one of \"bindir\", \"libdir\",-                            -- \"datadir\" or \"libexecdir\"+                            -- \"datadir\", \"libexecdir\", or \"sysconfdir\"               -> String     -- ^ environment variable name pkgPathEnvVar pkg_descr var =     showPkgName (packageName pkg_descr) ++ "_" ++ var@@ -210,7 +216,7 @@     where cconv = case arch of                   I386 -> "stdcall"                   X86_64 -> "ccall"-+                  _ -> error "win32 supported only with I386, X86_64"  get_prefix_hugs :: String get_prefix_hugs =
Distribution/Simple/BuildPaths.hs view
@@ -63,13 +63,14 @@ import System.FilePath ((</>), (<.>))  import Distribution.Package-         ( PackageIdentifier, packageName )+         ( 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.LocalBuildInfo+         ( LocalBuildInfo(buildDir), LibraryName(..) ) import Distribution.Simple.Setup (defaultDistPref) import Distribution.Text          ( display )@@ -109,18 +110,18 @@ -- --------------------------------------------------------------------------- -- Library file names -mkLibName :: PackageIdentifier -> String-mkLibName lib = "libHS" ++ display lib <.> "a"+mkLibName :: LibraryName -> String+mkLibName (LibraryName lib) = "lib" ++ lib <.> "a" -mkProfLibName :: PackageIdentifier -> String-mkProfLibName lib =  "libHS" ++ display lib ++ "_p" <.> "a"+mkProfLibName :: LibraryName -> String+mkProfLibName (LibraryName lib) =  "lib" ++ 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+mkSharedLibName :: CompilerId -> LibraryName -> String+mkSharedLibName (CompilerId compilerFlavor compilerVersion) (LibraryName lib)+  = "lib" ++ lib ++ "-" ++ comp <.> dllExtension   where comp = display compilerFlavor ++ display compilerVersion  -- ------------------------------------------------------------
+ Distribution/Simple/BuildTarget.hs view
@@ -0,0 +1,927 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.BuildTargets+-- Copyright   :  (c) Duncan Coutts 2012+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+--+-- Handling for user-specified build targets+-----------------------------------------------------------------------------+module Distribution.Simple.BuildTarget (++    -- * Build targets+    BuildTarget(..),+    readBuildTargets,++    -- * Parsing user build targets+    UserBuildTarget,+    readUserBuildTargets,+    UserBuildTargetProblem(..),+    reportUserBuildTargetProblems,++    -- * Resolving build targets+    resolveBuildTargets,+    BuildTargetProblem(..),+    reportBuildTargetProblems,+  ) where++import Distribution.Package+         ( Package(..), PackageId, packageName )++import Distribution.PackageDescription+         ( PackageDescription+         , Executable(..)+         , TestSuite(..), TestSuiteInterface(..), testModules+         , Benchmark(..), BenchmarkInterface(..), benchmarkModules+         , BuildInfo(..), libModules, exeModules )+import Distribution.ModuleName+         ( ModuleName, toFilePath )+import Distribution.Simple.LocalBuildInfo+         ( Component(..), ComponentName(..)+         , pkgComponents, componentName, componentBuildInfo )++import Distribution.Text+         ( display )+import Distribution.Simple.Utils+         ( die, lowercase, equating )++import Data.List+         ( nub, stripPrefix, sortBy, groupBy, partition, intercalate )+import Data.Ord+import Data.Maybe+         ( listToMaybe, catMaybes )+import Data.Either+         ( partitionEithers )+import qualified Data.Map as Map+import Control.Monad+import Control.Applicative (Applicative(..))+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.ReadP+         ( (+++), (<++) )+import Data.Char+         ( isSpace, isAlphaNum )+import System.FilePath as FilePath+         ( dropExtension, normalise, splitDirectories, joinPath, splitPath+         , hasTrailingPathSeparator )+import System.Directory+         ( doesFileExist, doesDirectoryExist )++-- ------------------------------------------------------------+-- * User build targets+-- ------------------------------------------------------------++-- | Various ways that a user may specify a build target.+--+data UserBuildTarget =++     -- | A target specified by a single name. This could be a component+     -- module or file.+     --+     -- > cabal build foo+     -- > cabal build Data.Foo+     -- > cabal build Data/Foo.hs  Data/Foo.hsc+     --+     UserBuildTargetSingle String++     -- | A target specified by a qualifier and name. This could be a component+     -- name qualified by the component namespace kind, or a module or file+     -- qualified by the component name.+     --+     -- > cabal build lib:foo exe:foo+     -- > cabal build foo:Data.Foo+     -- > cabal build foo:Data/Foo.hs+     --+   | UserBuildTargetDouble String String++     -- A fully qualified target, either a module or file qualified by a+     -- component name with the component namespace kind.+     --+     -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs+     -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo+     --+   | UserBuildTargetTriple String String String+  deriving (Show, Eq, Ord)+++-- ------------------------------------------------------------+-- * Resolved build targets+-- ------------------------------------------------------------++-- | A fully resolved build target.+--+data BuildTarget =++     -- | A specific component+     --+     BuildTargetComponent ComponentName++     -- | A specific module within a specific component.+     --+   | BuildTargetModule ComponentName ModuleName++     -- | A specific file within a specific component.+     --+   | BuildTargetFile ComponentName FilePath+  deriving (Show,Eq)+++-- ------------------------------------------------------------+-- * Do everything+-- ------------------------------------------------------------++readBuildTargets :: PackageDescription -> [String] -> IO [BuildTarget]+readBuildTargets pkg targetStrs = do+    let (uproblems, utargets) = readUserBuildTargets targetStrs+    reportUserBuildTargetProblems uproblems++    utargets' <- mapM checkTargetExistsAsFile utargets++    let (bproblems, btargets) = resolveBuildTargets pkg utargets'+    reportBuildTargetProblems bproblems++    return btargets++checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)+checkTargetExistsAsFile t = do+    fexists <- existsAsFile (fileComponentOfTarget t)+    return (t, fexists)++  where+    existsAsFile f = do+      exists <- doesFileExist f+      case splitPath f of+        (d:_)   | hasTrailingPathSeparator d -> doesDirectoryExist d+        (d:_:_) | not exists                 -> doesDirectoryExist d+        _                                    -> return exists++    fileComponentOfTarget (UserBuildTargetSingle     s1) = s1+    fileComponentOfTarget (UserBuildTargetDouble _   s2) = s2+    fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3+++-- ------------------------------------------------------------+-- * Parsing user targets+-- ------------------------------------------------------------++readUserBuildTargets :: [String] -> ([UserBuildTargetProblem]+                                    ,[UserBuildTarget])+readUserBuildTargets = partitionEithers . map readUserBuildTarget++readUserBuildTarget :: String -> Either UserBuildTargetProblem+                                        UserBuildTarget+readUserBuildTarget targetstr =+    case readPToMaybe parseTargetApprox targetstr of+      Nothing  -> Left  (UserBuildTargetUnrecognised targetstr)+      Just tgt -> Right tgt++  where+    parseTargetApprox :: Parse.ReadP r UserBuildTarget+    parseTargetApprox =+          (do a <- tokenQ+              return (UserBuildTargetSingle a))+      +++ (do a <- token+              _ <- Parse.char ':'+              b <- tokenQ+              return (UserBuildTargetDouble a b))+      +++ (do a <- token+              _ <- Parse.char ':'+              b <- token+              _ <- Parse.char ':'+              c <- tokenQ+              return (UserBuildTargetTriple a b c))++    token  = Parse.munch1 (\x -> not (isSpace x) && x /= ':')+    tokenQ = parseHaskellString <++ token+    parseHaskellString :: Parse.ReadP r String+    parseHaskellString = Parse.readS_to_P reads++    readPToMaybe :: Parse.ReadP a a -> String -> Maybe a+    readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str+                                         , all isSpace s ]++data UserBuildTargetProblem+   = UserBuildTargetUnrecognised String+  deriving Show++reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO ()+reportUserBuildTargetProblems problems = do+    case [ target | UserBuildTargetUnrecognised target <- problems ] of+      []     -> return ()+      target ->+        die $ unlines+                [ "Unrecognised build target '" ++ name ++ "'."+                | name <- target ]+           ++ "Examples:\n"+           ++ " - build foo          -- component name "+           ++ "(library, executable, test-suite or benchmark)\n"+           ++ " - build Data.Foo     -- module name\n"+           ++ " - build Data/Foo.hsc -- file name\n"+           ++ " - build lib:foo exe:foo   -- component qualified by kind\n"+           ++ " - build foo:Data.Foo      -- module qualified by component\n"+           ++ " - build foo:Data/Foo.hsc  -- file qualified by component"++showUserBuildTarget :: UserBuildTarget -> String+showUserBuildTarget = intercalate ":" . components+  where+    components (UserBuildTargetSingle s1)       = [s1]+    components (UserBuildTargetDouble s1 s2)    = [s1,s2]+    components (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3]+++-- ------------------------------------------------------------+-- * Resolving user targets to build targets+-- ------------------------------------------------------------++{-+stargets =+  [ BuildTargetComponent (CExeName "foo")+  , BuildTargetModule    (CExeName "foo") (mkMn "Foo")+  , BuildTargetModule    (CExeName "tst") (mkMn "Foo")+  ]+    where+    mkMn :: String -> ModuleName+    mkMn  = fromJust . simpleParse++ex_pkgid :: PackageIdentifier+Just ex_pkgid = simpleParse "thelib"+-}++-- | Given a bunch of user-specified targets, try to resolve what it is they+-- refer to.+--+resolveBuildTargets :: PackageDescription+                    -> [(UserBuildTarget, Bool)]+                    -> ([BuildTargetProblem], [BuildTarget])+resolveBuildTargets pkg = partitionEithers+                        . map (uncurry (resolveBuildTarget pkg))++resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool+                   -> Either BuildTargetProblem BuildTarget+resolveBuildTarget pkg userTarget fexists =+    case findMatch (matchBuildTarget pkg userTarget fexists) of+      Unambiguous target  -> Right target+      Ambiguous   targets -> Left (BuildTargetAmbigious userTarget targets')+                               where targets' = disambiguateBuildTargets+                                                    (packageId pkg) userTarget+                                                    targets+      None        errs    -> Left (classifyMatchErrors errs)++  where+    classifyMatchErrors errs+      | not (null expected) = let (things, got:_) = unzip expected in+                              BuildTargetExpected userTarget things got+      | not (null nosuch)   = BuildTargetNoSuch   userTarget nosuch+      | otherwise = error $ "resolveBuildTarget: internal error in matching"+      where+        expected = [ (thing, got) | MatchErrorExpected thing got <- errs ]+        nosuch   = [ (thing, got) | MatchErrorNoSuch   thing got <- errs ]+++data BuildTargetProblem+   = BuildTargetExpected  UserBuildTarget [String]  String+     -- ^  [expected thing] (actually got)+   | BuildTargetNoSuch    UserBuildTarget [(String, String)]+     -- ^ [(no such thing,  actually got)]+   | BuildTargetAmbigious UserBuildTarget [(UserBuildTarget, BuildTarget)]+  deriving Show+++disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget]+                         -> [(UserBuildTarget, BuildTarget)]+disambiguateBuildTargets pkgid original =+    disambiguate (userTargetQualLevel original)+  where+    disambiguate ql ts+        | null amb  = unamb+        | otherwise = unamb ++ disambiguate (succ ql) amb+      where+        (amb, unamb) = step ql ts++    userTargetQualLevel (UserBuildTargetSingle _    ) = QL1+    userTargetQualLevel (UserBuildTargetDouble _ _  ) = QL2+    userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3++    step  :: QualLevel -> [BuildTarget]+          -> ([BuildTarget], [(UserBuildTarget, BuildTarget)])+    step ql = (\(amb, unamb) -> (map snd $ concat amb, concat unamb))+            . partition (\g -> length g > 1)+            . groupBy (equating fst)+            . sortBy (comparing fst)+            . map (\t -> (renderBuildTarget ql t pkgid, t))++data QualLevel = QL1 | QL2 | QL3+  deriving (Enum, Show)++renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget+renderBuildTarget ql target pkgid =+    case ql of+      QL1 -> UserBuildTargetSingle s1        where  s1          = single target+      QL2 -> UserBuildTargetDouble s1 s2     where (s1, s2)     = double target+      QL3 -> UserBuildTargetTriple s1 s2 s3  where (s1, s2, s3) = triple target++  where+    single (BuildTargetComponent cn  ) = dispCName cn+    single (BuildTargetModule    _  m) = display m+    single (BuildTargetFile      _  f) = f++    double (BuildTargetComponent cn  ) = (dispKind cn, dispCName cn)+    double (BuildTargetModule    cn m) = (dispCName cn, display m)+    double (BuildTargetFile      cn f) = (dispCName cn, f)++    triple (BuildTargetComponent _   ) = error "triple BuildTargetComponent"+    triple (BuildTargetModule    cn m) = (dispKind cn, dispCName cn, display m)+    triple (BuildTargetFile      cn f) = (dispKind cn, dispCName cn, f)++    dispCName = componentStringName pkgid+    dispKind  = showComponentKindShort . componentKind++reportBuildTargetProblems :: [BuildTargetProblem] -> IO ()+reportBuildTargetProblems problems = do++    case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of+      []      -> return ()+      targets ->+        die $ unlines+          [    "Unrecognised build target '" ++ showUserBuildTarget target+            ++ "'.\n"+            ++ "Expected a " ++ intercalate " or " expected+            ++ ", rather than '" ++ got ++ "'."+          | (target, expected, got) <- targets ]++    case [ (t, e) | BuildTargetNoSuch t e <- problems ] of+      []      -> return ()+      targets ->+        die $ unlines+          [    "Unknown build target '" ++ showUserBuildTarget target+            ++ "'.\nThere is no "+            ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'"+                                  | (thing, got) <- nosuch ] ++ "."+          | (target, nosuch) <- targets ]+        where+          mungeThing "file" = "file target"+          mungeThing thing  = thing++    case [ (t, ts) | BuildTargetAmbigious t ts <- problems ] of+      []      -> return ()+      targets ->+        die $ unlines+          [    "Ambiguous build target '" ++ showUserBuildTarget target+            ++ "'. It could be:\n "+            ++ unlines [ "   "++ showUserBuildTarget ut +++                         " (" ++ showBuildTargetKind bt ++ ")"+                       | (ut, bt) <- amb ]+          | (target, amb) <- targets ]++  where+    showBuildTargetKind (BuildTargetComponent _  ) = "component"+    showBuildTargetKind (BuildTargetModule    _ _) = "module"+    showBuildTargetKind (BuildTargetFile      _ _) = "file"+++----------------------------------+-- Top level BuildTarget matcher+--++matchBuildTarget :: PackageDescription+                 -> UserBuildTarget -> Bool -> Match BuildTarget+matchBuildTarget pkg = \utarget fexists ->+    case utarget of+      UserBuildTargetSingle str1 ->+        matchBuildTarget1 cinfo str1 fexists++      UserBuildTargetDouble str1 str2 ->+        matchBuildTarget2 cinfo str1 str2 fexists++      UserBuildTargetTriple str1 str2 str3 ->+        matchBuildTarget3 cinfo str1 str2 str3 fexists+  where+    cinfo = pkgComponentInfo pkg++matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget+matchBuildTarget1 cinfo str1 fexists =+                        matchComponent1 cinfo str1+   `matchPlusShadowing` matchModule1    cinfo str1+   `matchPlusShadowing` matchFile1      cinfo str1 fexists+++matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool+                  -> Match BuildTarget+matchBuildTarget2 cinfo str1 str2 fexists =+                        matchComponent2 cinfo str1 str2+   `matchPlusShadowing` matchModule2    cinfo str1 str2+   `matchPlusShadowing` matchFile2      cinfo str1 str2 fexists+++matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool+                  -> Match BuildTarget+matchBuildTarget3 cinfo str1 str2 str3 fexists =+                        matchModule3    cinfo str1 str2 str3+   `matchPlusShadowing` matchFile3      cinfo str1 str2 str3 fexists+++data ComponentInfo = ComponentInfo {+       cinfoName    :: ComponentName,+       cinfoStrName :: ComponentStringName,+       cinfoSrcDirs :: [FilePath],+       cinfoModules :: [ModuleName],+       cinfoHsFiles :: [FilePath],   -- other hs files (like main.hs)+       cinfoCFiles  :: [FilePath]+     }++type ComponentStringName = String++pkgComponentInfo :: PackageDescription -> [ComponentInfo]+pkgComponentInfo pkg =+    [ ComponentInfo {+        cinfoName    = componentName c,+        cinfoStrName = componentStringName pkg (componentName c),+        cinfoSrcDirs = hsSourceDirs bi,+        cinfoModules = componentModules c,+        cinfoHsFiles = componentHsFiles c,+        cinfoCFiles  = cSources bi+      }+    | c <- pkgComponents pkg+    , let bi = componentBuildInfo c ]++componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName+componentStringName pkg CLibName          = display (packageName pkg)+componentStringName _   (CExeName  name)  = name+componentStringName _   (CTestName  name) = name+componentStringName _   (CBenchName name) = name++componentModules :: Component -> [ModuleName]+componentModules (CLib   lib)   = libModules lib+componentModules (CExe   exe)   = exeModules exe+componentModules (CTest  test)  = testModules test+componentModules (CBench bench) = benchmarkModules bench++componentHsFiles :: Component -> [FilePath]+componentHsFiles (CExe exe) = [modulePath exe]+componentHsFiles (CTest  TestSuite {+                           testInterface = TestSuiteExeV10 _ mainfile+                         }) = [mainfile]+componentHsFiles (CBench Benchmark {+                           benchmarkInterface = BenchmarkExeV10 _ mainfile+                         }) = [mainfile]+componentHsFiles _          = []++{-+ex_cs :: [ComponentInfo]+ex_cs =+  [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])+  , (mkC (CExeName "tst") ["src1", "test"]      ["Foo"])+  ]+    where+    mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms)+    mkMn :: String -> ModuleName+    mkMn  = fromJust . simpleParse+    pkgid :: PackageIdentifier+    Just pkgid = simpleParse "thelib"+-}++------------------------------+-- Matching component kinds+--++data ComponentKind = LibKind | ExeKind | TestKind | BenchKind+  deriving (Eq, Ord, Show)++componentKind :: ComponentName -> ComponentKind+componentKind CLibName       = LibKind+componentKind (CExeName  _)  = ExeKind+componentKind (CTestName  _) = TestKind+componentKind (CBenchName _) = BenchKind++cinfoKind :: ComponentInfo -> ComponentKind+cinfoKind = componentKind . cinfoName++matchComponentKind :: String -> Match ComponentKind+matchComponentKind s+  | s `elem` ["lib", "library"]            = increaseConfidence >> return LibKind+  | s `elem` ["exe", "executable"]         = increaseConfidence >> return ExeKind+  | s `elem` ["tst", "test", "test-suite"] = increaseConfidence+                                             >> return TestKind+  | s `elem` ["bench", "benchmark"]        = increaseConfidence+                                             >> return BenchKind+  | otherwise                              = matchErrorExpected+                                             "component kind" s++showComponentKind :: ComponentKind -> String+showComponentKind LibKind   = "library"+showComponentKind ExeKind   = "executable"+showComponentKind TestKind  = "test-suite"+showComponentKind BenchKind = "benchmark"++showComponentKindShort :: ComponentKind -> String+showComponentKindShort LibKind   = "lib"+showComponentKindShort ExeKind   = "exe"+showComponentKindShort TestKind  = "test"+showComponentKindShort BenchKind = "bench"++------------------------------+-- Matching component targets+--++matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget+matchComponent1 cs = \str1 -> do+    guardComponentName str1+    c <- matchComponentName cs str1+    return (BuildTargetComponent (cinfoName c))++matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget+matchComponent2 cs = \str1 str2 -> do+    ckind <- matchComponentKind str1+    guardComponentName str2+    c <- matchComponentKindAndName cs ckind str2+    return (BuildTargetComponent (cinfoName c))++-- utils:++guardComponentName :: String -> Match ()+guardComponentName s+  | all validComponentChar s+    && not (null s)  = increaseConfidence+  | otherwise        = matchErrorExpected "component name" s+  where+    validComponentChar c = isAlphaNum c || c == '.'+                        || c == '_' || c == '-' || c == '\''++matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo+matchComponentName cs str =+    orNoSuchThing "component" str+  $ increaseConfidenceFor+  $ matchInexactly caseFold+      [ (cinfoStrName c, c) | c <- cs ]+      str++matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String+                          -> Match ComponentInfo+matchComponentKindAndName cs ckind str =+    orNoSuchThing (showComponentKind ckind ++ " component") str+  $ increaseConfidenceFor+  $ matchInexactly (\(ck, cn) -> (ck, caseFold cn))+      [ ((cinfoKind c, cinfoStrName c), c) | c <- cs ]+      (ckind, str)+++------------------------------+-- Matching module targets+--++matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget+matchModule1 cs = \str1 -> do+    guardModuleName str1+    nubMatchErrors $ do+      c <- tryEach cs+      let ms = cinfoModules c+      m <- matchModuleName ms str1+      return (BuildTargetModule (cinfoName c) m)++matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget+matchModule2 cs = \str1 str2 -> do+    guardComponentName str1+    guardModuleName    str2+    c <- matchComponentName cs str1+    let ms = cinfoModules c+    m <- matchModuleName ms str2+    return (BuildTargetModule (cinfoName c) m)++matchModule3 :: [ComponentInfo] -> String -> String -> String+             -> Match BuildTarget+matchModule3 cs str1 str2 str3 = do+    ckind <- matchComponentKind str1+    guardComponentName str2+    c <- matchComponentKindAndName cs ckind str2+    guardModuleName    str3+    let ms = cinfoModules c+    m <- matchModuleName ms str3+    return (BuildTargetModule (cinfoName c) m)++-- utils:++guardModuleName :: String -> Match ()+guardModuleName s+  | all validModuleChar s+    && not (null s)       = increaseConfidence+  | otherwise             = matchErrorExpected "module name" s+  where+    validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''++matchModuleName :: [ModuleName] -> String -> Match ModuleName+matchModuleName ms str =+    orNoSuchThing "module" str+  $ increaseConfidenceFor+  $ matchInexactly caseFold+      [ (display m, m)+      | m <- ms ]+      str+++------------------------------+-- Matching file targets+--++matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget+matchFile1 cs str1 exists =+    nubMatchErrors $ do+      c <- tryEach cs+      filepath <- matchComponentFile c str1 exists+      return (BuildTargetFile (cinfoName c) filepath)+++matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget+matchFile2 cs str1 str2 exists = do+    guardComponentName str1+    c <- matchComponentName cs str1+    filepath <- matchComponentFile c str2 exists+    return (BuildTargetFile (cinfoName c) filepath)+++matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool+           -> Match BuildTarget+matchFile3 cs str1 str2 str3 exists = do+    ckind <- matchComponentKind str1+    guardComponentName str2+    c <- matchComponentKindAndName cs ckind str2+    filepath <- matchComponentFile c str3 exists+    return (BuildTargetFile (cinfoName c) filepath)+++matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath+matchComponentFile c str fexists =+    expecting "file" str $+      matchPlus+        (matchFileExists str fexists)+        (matchPlusShadowing+          (msum [ matchModuleFileRooted   dirs ms      str+                , matchOtherFileRooted    dirs hsFiles str ])+          (msum [ matchModuleFileUnrooted      ms      str+                , matchOtherFileUnrooted       hsFiles str+                , matchOtherFileUnrooted       cFiles  str ]))+  where+    dirs = cinfoSrcDirs c+    ms   = cinfoModules c+    hsFiles = cinfoHsFiles c+    cFiles  = cinfoCFiles c+++-- utils++matchFileExists :: FilePath -> Bool -> Match a+matchFileExists _     False = mzero+matchFileExists fname True  = do increaseConfidence+                                 matchErrorNoSuch "file" fname++matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath+matchModuleFileUnrooted ms str = do+    let filepath = normalise str+    _ <- matchModuleFileStem ms filepath+    return filepath++matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath+matchModuleFileRooted dirs ms str = nubMatches $ do+    let filepath = normalise str+    filepath' <- matchDirectoryPrefix dirs filepath+    _ <- matchModuleFileStem ms filepath'+    return filepath++matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName+matchModuleFileStem ms =+      increaseConfidenceFor+    . matchInexactly caseFold+        [ (toFilePath m, m) | m <- ms ]+    . dropExtension++matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath+matchOtherFileRooted dirs fs str = do+    let filepath = normalise str+    filepath' <- matchDirectoryPrefix dirs filepath+    _ <- matchFile fs filepath'+    return filepath++matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath+matchOtherFileUnrooted fs str = do+    let filepath = normalise str+    _ <- matchFile fs filepath+    return filepath++matchFile :: [FilePath] -> FilePath -> Match FilePath+matchFile fs = increaseConfidenceFor+             . matchInexactly caseFold [ (f, f) | f <- fs ]++matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath+matchDirectoryPrefix dirs filepath =+    exactMatches $+      catMaybes+       [ stripDirectory (normalise dir) filepath | dir <- dirs ]+  where+    stripDirectory :: FilePath -> FilePath -> Maybe FilePath+    stripDirectory dir fp =+      joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp)+++------------------------------+-- Matching monad+--++-- | A matcher embodies a way to match some input as being some recognised+-- value. In particular it deals with multiple and ambigious matches.+--+-- There are various matcher primitives ('matchExactly', 'matchInexactly'),+-- ways to combine matchers ('ambigiousWith', 'shadows') and finally we can+-- run a matcher against an input using 'findMatch'.+--++data Match a = NoMatch      Confidence [MatchError]+             | ExactMatch   Confidence [a]+             | InexactMatch Confidence [a]+  deriving Show++type Confidence = Int++data MatchError = MatchErrorExpected String String+                | MatchErrorNoSuch   String String+  deriving (Show, Eq)+++instance MonadPlus Match where+  mzero = matchZero+  mplus = matchPlus++matchZero :: Match a+matchZero = NoMatch 0 []++-- | Combine two matchers. Exact matches are used over inexact matches+-- but if we have multiple exact, or inexact then the we collect all the+-- ambigious matches.+--+matchPlus :: Match a -> Match a -> Match a+matchPlus   (ExactMatch   d1 xs)   (ExactMatch   d2 xs') =+  ExactMatch (max d1 d2) (xs ++ xs')+matchPlus a@(ExactMatch   _  _ )   (InexactMatch _  _  ) = a+matchPlus a@(ExactMatch   _  _ )   (NoMatch      _  _  ) = a+matchPlus   (InexactMatch _  _ ) b@(ExactMatch   _  _  ) = b+matchPlus   (InexactMatch d1 xs)   (InexactMatch d2 xs') =+  InexactMatch (max d1 d2) (xs ++ xs')+matchPlus a@(InexactMatch _  _ )   (NoMatch      _  _  ) = a+matchPlus   (NoMatch      _  _ ) b@(ExactMatch   _  _  ) = b+matchPlus   (NoMatch      _  _ ) b@(InexactMatch _  _  ) = b+matchPlus a@(NoMatch      d1 ms) b@(NoMatch      d2 ms')+                                             | d1 >  d2  = a+                                             | d1 <  d2  = b+                                             | otherwise = NoMatch d1 (ms ++ ms')++-- | Combine two matchers. This is similar to 'ambigiousWith' with the+-- difference that an exact match from the left matcher shadows any exact+-- match on the right. Inexact matches are still collected however.+--+matchPlusShadowing :: Match a -> Match a -> Match a+matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a+matchPlusShadowing a                   b               = matchPlus a b++instance Functor Match where+  fmap _ (NoMatch      d ms) = NoMatch      d ms+  fmap f (ExactMatch   d xs) = ExactMatch   d (fmap f xs)+  fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)++instance Applicative Match where+  pure = return+  (<*>) = ap++instance Monad Match where+  return a                = ExactMatch 0 [a]+  NoMatch      d ms >>= _ = NoMatch d ms+  ExactMatch   d xs >>= f = addDepth d+                          $ foldr matchPlus matchZero (map f xs)+  InexactMatch d xs >>= f = addDepth d .  forceInexact+                          $ foldr matchPlus matchZero (map f xs)++addDepth :: Confidence -> Match a -> Match a+addDepth d' (NoMatch      d msgs) = NoMatch      (d'+d) msgs+addDepth d' (ExactMatch   d xs)   = ExactMatch   (d'+d) xs+addDepth d' (InexactMatch d xs)   = InexactMatch (d'+d) xs++forceInexact :: Match a -> Match a+forceInexact (ExactMatch d ys) = InexactMatch d ys+forceInexact m                 = m++------------------------------+-- Various match primitives+--++matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a+matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got]+matchErrorNoSuch   thing got = NoMatch 0 [MatchErrorNoSuch   thing got]++expecting :: String -> String -> Match a -> Match a+expecting thing got (NoMatch 0 _) = matchErrorExpected thing got+expecting _     _   m             = m++orNoSuchThing :: String -> String -> Match a -> Match a+orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got+orNoSuchThing _     _   m             = m++increaseConfidence :: Match ()+increaseConfidence = ExactMatch 1 [()]++increaseConfidenceFor :: Match a -> Match a+increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r++nubMatches :: Eq a => Match a -> Match a+nubMatches (NoMatch      d msgs) = NoMatch      d msgs+nubMatches (ExactMatch   d xs)   = ExactMatch   d (nub xs)+nubMatches (InexactMatch d xs)   = InexactMatch d (nub xs)++nubMatchErrors :: Match a -> Match a+nubMatchErrors (NoMatch      d msgs) = NoMatch      d (nub msgs)+nubMatchErrors (ExactMatch   d xs)   = ExactMatch   d xs+nubMatchErrors (InexactMatch d xs)   = InexactMatch d xs++-- | Lift a list of matches to an exact match.+--+exactMatches, inexactMatches :: [a] -> Match a++exactMatches [] = matchZero+exactMatches xs = ExactMatch 0 xs++inexactMatches [] = matchZero+inexactMatches xs = InexactMatch 0 xs++tryEach :: [a] -> Match a+tryEach = exactMatches+++------------------------------+-- Top level match runner+--++-- | Given a matcher and a key to look up, use the matcher to find all the+-- possible matches. There may be 'None', a single 'Unambiguous' match or+-- you may have an 'Ambiguous' match with several possibilities.+--+findMatch :: Eq b => Match b -> MaybeAmbigious b+findMatch match =+    case match of+      NoMatch    _ msgs -> None (nub msgs)+      ExactMatch   _ xs -> checkAmbigious xs+      InexactMatch _ xs -> checkAmbigious xs+  where+    checkAmbigious xs = case nub xs of+                          [x] -> Unambiguous x+                          xs' -> Ambiguous   xs'++data MaybeAmbigious a = None [MatchError] | Unambiguous a | Ambiguous [a]+  deriving Show+++------------------------------+-- Basic matchers+--++{-+-- | A primitive matcher that looks up a value in a finite 'Map'. The+-- value must match exactly.+--+matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b)+matchExactly xs =+    \x -> case Map.lookup x m of+            Nothing -> matchZero+            Just ys -> ExactMatch 0 ys+  where+    m :: Ord a => Map a [b]+    m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]+-}++-- | A primitive matcher that looks up a value in a finite 'Map'. It checks+-- for an exact or inexact match. We get an inexact match if the match+-- is not exact, but the canonical forms match. It takes a canonicalisation+-- function for this purpose.+--+-- So for example if we used string case fold as the canonicalisation+-- function, then we would get case insensitive matching (but it will still+-- report an exact match when the case matches too).+--+matchInexactly :: (Ord a, Ord a') =>+                        (a -> a') ->+                        [(a, b)] -> (a -> Match b)+matchInexactly cannonicalise xs =+    \x -> case Map.lookup x m of+            Just ys -> exactMatches ys+            Nothing -> case Map.lookup (cannonicalise x) m' of+                         Just ys -> inexactMatches ys+                         Nothing -> matchZero+  where+    m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]++    -- the map of canonicalised keys to groups of inexact matches+    m' = Map.mapKeysWith (++) cannonicalise m++++------------------------------+-- Utils+--++caseFold :: String -> String+caseFold = lowercase
+ Distribution/Simple/CCompiler.hs view
@@ -0,0 +1,121 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.CCompiler+-- Copyright   :  2011, Dan Knapp+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This simple package provides types and functions for interacting with+-- C compilers.  Currently it's just a type enumerating extant C-like+-- languages, which we call dialects.++{-+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.CCompiler (+   CDialect(..),+   cSourceExtensions,+   cDialectFilenameExtension,+   filenameCDialect+  ) where++import Data.Monoid+     ( Monoid(..) )+import System.FilePath+     ( takeExtension )+++-- | Represents a dialect of C.  The Monoid instance expresses backward+--   compatibility, in the sense that 'mappend a b' is the least inclusive+--   dialect which both 'a' and 'b' can be correctly interpreted as.+data CDialect = C+              | ObjectiveC+              | CPlusPlus+              | ObjectiveCPlusPlus+              deriving (Show)++instance Monoid CDialect where+  mempty = C++  mappend C                  anything           = anything+  mappend ObjectiveC         CPlusPlus          = ObjectiveCPlusPlus+  mappend CPlusPlus          ObjectiveC         = ObjectiveCPlusPlus+  mappend _                  ObjectiveCPlusPlus = ObjectiveCPlusPlus+  mappend ObjectiveC         _                  = ObjectiveC+  mappend CPlusPlus          _                  = CPlusPlus+  mappend ObjectiveCPlusPlus _                  = ObjectiveCPlusPlus+++-- | A list of all file extensions which are recognized as possibly containing+--   some dialect of C code.  Note that this list is only for source files,+--   not for header files.+cSourceExtensions :: [String]+cSourceExtensions = ["c", "i", "ii", "m", "mi", "mm", "M", "mii", "cc", "cp",+                     "cxx", "cpp", "CPP", "c++", "C"]+++-- | Takes a dialect of C and whether code is intended to be passed through+--   the preprocessor, and returns a filename extension for containing that+--   code.+cDialectFilenameExtension :: CDialect -> Bool -> String+cDialectFilenameExtension C True  = "c"+cDialectFilenameExtension C False = "i"+cDialectFilenameExtension ObjectiveC True  = "m"+cDialectFilenameExtension ObjectiveC False = "mi"+cDialectFilenameExtension CPlusPlus True   = "cpp"+cDialectFilenameExtension CPlusPlus False  = "ii"+cDialectFilenameExtension ObjectiveCPlusPlus True  = "mm"+cDialectFilenameExtension ObjectiveCPlusPlus False = "mii"+++-- | Infers from a filename's extension the dialect of C which it contains,+--   and whether it is intended to be passed through the preprocessor.+filenameCDialect :: String -> Maybe (CDialect, Bool)+filenameCDialect filename = do+  extension <- case takeExtension filename of+                 '.':ext -> Just ext+                 _       -> Nothing+  case extension of+    "c"   -> return (C, True)+    "i"   -> return (C, False)+    "ii"  -> return (CPlusPlus, False)+    "m"   -> return (ObjectiveC, True)+    "mi"  -> return (ObjectiveC, False)+    "mm"  -> return (ObjectiveCPlusPlus, True)+    "M"   -> return (ObjectiveCPlusPlus, True)+    "mii" -> return (ObjectiveCPlusPlus, False)+    "cc"  -> return (CPlusPlus, True)+    "cp"  -> return (CPlusPlus, True)+    "cxx" -> return (CPlusPlus, True)+    "cpp" -> return (CPlusPlus, True)+    "CPP" -> return (CPlusPlus, True)+    "c++" -> return (CPlusPlus, True)+    "C"   -> return (CPlusPlus, True)+    _     -> Nothing
Distribution/Simple/Command.hs view
@@ -55,6 +55,7 @@   -- ** Constructing commands   ShowOrParseArgs(..),   makeCommand,+  hiddenCommand,    -- ** Associating actions with commands   Command,@@ -102,7 +103,8 @@     commandName        :: String,     -- | A short, one line description of the command to use in help texts.     commandSynopsis :: String,-    -- | The useage line summary for this command+    -- | A function that maps a program name to a usage summary for this+    -- command.     commandUsage    :: String -> String,     -- | Additional explanation of the command to use in help texts.     commandDescription :: Maybe (String -> String),@@ -113,7 +115,6 @@   }  data ShowOrParseArgs = ShowArgs | ParseArgs- type Name        = String type Description = String @@ -126,12 +127,19 @@   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])+-- | 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) +                 | 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@@ -142,24 +150,30 @@  -- | 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 :: 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"+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.+--   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.+            -> [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+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)+  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])@@ -176,8 +190,9 @@     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' :: 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@@ -185,34 +200,42 @@ 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 :: (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 _ _ _ _ _ _ _ _ _ = error+                            "Distribution.Simple.Setup.boolOpt: unreachable" -boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags -> MkOptDescr (a -> b) (b -> a -> a) a+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 :: 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+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 :: ShowOrParseArgs -> CommandUI flags+                  -> [GetOpt.OptDescr (flags -> flags)] commandGetOpts showOrParse command =     concatMap viewAsGetOpt (commandOptions command showOrParse) @@ -232,53 +255,72 @@          [ 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.+-- | 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 []) =+  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+    where+      optDescr = head $ sortBy cmp dd++      cmp :: OptDescr a -> OptDescr a -> Ordering+      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 :: a -> Doc+      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. +        ChoiceOpt alts ->+          fromMaybe empty $ listToMaybe+          [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]++        BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t++--    set :: LineNo -> String -> a -> ParseResult a+      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 (ChoiceOpt alts) val = listToMaybe+                                           [ set | (_,(_sf,lf:_), set, _) <- alts+                                                 , lf == val] -getChoiceByLongFlag _ _ = error "Distribution.command.getChoiceByLongFlag: expected a choice option"+getChoiceByLongFlag _ _ =+  error "Distribution.command.getChoiceByLongFlag: expected a choice option"  getCurrentChoice :: OptDescr a -> a -> [String] getCurrentChoice (ChoiceOpt alts) a =@@ -288,7 +330,8 @@   liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b-liftOption get' set' opt = opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt}+liftOption get' set' opt =+  opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt}   liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b@@ -297,7 +340,8 @@               | (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')+    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')@@ -449,16 +493,24 @@   fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags)  -data Command action = Command String String ([String] -> CommandParse action)+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)+          (fmap (uncurry applyDefaultArgs) . commandParseArgs command False)+          NormalCommand    where applyDefaultArgs mkflags args =           let flags = mkflags (commandDefaultFlags command)@@ -475,20 +527,21 @@     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)+      (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 ]+    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' ]+    commandNames   = [ name | (Command name _ _ NormalCommand) <- commands' ]     globalCommand' = globalCommand {       commandUsage = \pname ->            (case commandUsage globalCommand pname of@@ -500,12 +553,13 @@       commandDescription = Just $ \pname ->            "Commands:\n"         ++ unlines [ "  " ++ align name ++ "    " ++ description-                   | Command name description _ <- commands' ]+                   | Command name description _ NormalCommand <- commands' ]         ++ case commandDescription globalCommand of              Nothing   -> ""              Just desc -> '\n': desc pname     }-      where maxlen = maximum [ length name | Command name _ _ <- commands' ]+      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"@@ -518,7 +572,7 @@         CommandReadyToGo (_,[])  -> CommandHelp globalHelp         CommandReadyToGo (_,(name:cmdArgs')) ->           case lookupCommand name of-            [Command _ _ action] ->+            [Command _ _ action _] ->               case action ("--help":cmdArgs') of                 CommandHelp help -> CommandHelp help                 CommandList _    -> CommandList []@@ -527,7 +581,7 @@       where globalHelp = commandHelp globalCommand'     helpCommandUI =-      (makeCommand "help" "Help about commands" Nothing () (const [])) {+      (makeCommand "help" "Help about commands." Nothing () (const [])) {         commandUsage = \pname ->              "Usage: " ++ pname ++ " help [FLAGS]\n"           ++ "   or: " ++ pname ++ " help COMMAND [FLAGS]\n\n"
Distribution/Simple/Compiler.hs view
@@ -57,6 +57,8 @@         PackageDB(..),         PackageDBStack,         registrationPackageDB,+        absolutePackageDBPaths,+        absolutePackageDBPath,          -- * Support for optimisation levels         OptimisationLevel(..),@@ -75,8 +77,10 @@ import Distribution.Text (display) import Language.Haskell.Extension (Language(Haskell98), Extension) +import Control.Monad (liftM) import Data.List (nub) import Data.Maybe (catMaybes, isNothing)+import System.Directory (canonicalizePath)  data Compiler = Compiler {         compilerId              :: CompilerId,@@ -134,6 +138,18 @@ registrationPackageDB :: PackageDBStack -> PackageDB registrationPackageDB []  = error "internal error: empty package db set" registrationPackageDB dbs = last dbs++-- | Make package paths absolute+++absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack+absolutePackageDBPaths = mapM absolutePackageDBPath++absolutePackageDBPath :: PackageDB -> IO PackageDB+absolutePackageDBPath GlobalPackageDB        = return GlobalPackageDB+absolutePackageDBPath UserPackageDB          = return UserPackageDB+absolutePackageDBPath (SpecificPackageDB db) =+  SpecificPackageDB `liftM` canonicalizePath db  -- ------------------------------------------------------------ -- * Optimisation levels
Distribution/Simple/Configure.hs view
@@ -54,21 +54,30 @@                                       writePersistBuildConfig,                                       getPersistBuildConfig,                                       checkPersistBuildConfigOutdated,+                                      tryGetPersistBuildConfig,                                       maybeGetPersistBuildConfig,                                       localBuildInfoFile,-                                      getInstalledPackages,+                                      getInstalledPackages, getPackageDBContents,                                       configCompiler, configCompilerAux,+                                      configCompilerEx, configCompilerAuxEx,                                       ccLdOptionsBuildInfo,-                                      tryGetConfigStateFile,                                       checkForeignDeps,                                       interpretPackageDbFlags,++                                      ConfigStateFileErrorType(..),+                                      ConfigStateFileError,+                                      tryGetConfigStateFile,+                                      platformDefines,                                      )     where +import Distribution.Compiler+    ( CompilerId(..) ) import Distribution.Simple.Compiler     ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion     , showCompilerId, unsupportedLanguages, unsupportedExtensions     , PackageDB(..), PackageDBStack )+import Distribution.Simple.PreProcess ( platformDefines ) import Distribution.Package     ( PackageName(PackageName), PackageIdentifier(..), PackageId     , packageName, packageVersion, Package(..)@@ -92,6 +101,7 @@ import Distribution.Simple.Program     ( Program(..), ProgramLocation(..), ConfiguredProgram(..)     , ProgramConfiguration, defaultProgramConfiguration+    , ProgramSearchPathEntry(..), getProgramSearchPath, setProgramSearchPath     , configureAllKnownPrograms, knownPrograms, lookupKnownProgram     , userSpecifyArgss, userSpecifyPaths     , requireProgram, requireProgramVersion@@ -101,22 +111,29 @@ import Distribution.Simple.InstallDirs     ( InstallDirs(..), defaultInstallDirs, combineInstallDirs ) import Distribution.Simple.LocalBuildInfo-    ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)+    ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)+    , LibraryName(..)     , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId-    , allComponentsBy, Component(..), foldComponent, ComponentName(..) )+    , ComponentName(..), showComponentName, pkgEnabledComponents+    , componentBuildInfo, componentName, checkComponentsCyclic ) import Distribution.Simple.BuildPaths     ( autogenModulesDir ) import Distribution.Simple.Utils-    ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose+    ( die, warn, info, setupMessage+    , createDirectoryIfMissingVerbose, moreRecentFile     , intercalate, cabalVersion     , withFileContents, writeFileAtomic     , withTempFile ) import Distribution.System-    ( OS(..), buildOS, Arch(..), buildArch, buildPlatform )+    ( OS(..), buildOS, Platform, buildPlatform ) import Distribution.Version          ( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion ) import Distribution.Verbosity     ( Verbosity, lessVerbose )+import Distribution.Simple.Program.Db+    ( lookupProgram )+import Distribution.Simple.Program.Builtin+    ( ghcProgram )  import qualified Distribution.Simple.GHC  as GHC import qualified Distribution.Simple.JHC  as JHC@@ -126,52 +143,59 @@ import qualified Distribution.Simple.UHC  as UHC  import Control.Monad-    ( when, unless, foldM, filterM, forM )+    ( when, unless, foldM, filterM ) import Data.List-    ( nub, partition, isPrefixOf, inits, find )+    ( nub, partition, isPrefixOf, inits ) import Data.Maybe-    ( isNothing, catMaybes, mapMaybe )+    ( isNothing, catMaybes, fromMaybe ) import Data.Monoid     ( Monoid(..) )-import Data.Graph-    ( SCC(..), graphFromEdges, transposeG, vertices, stronglyConnCompR ) import System.Directory-    ( doesFileExist, getModificationTime, createDirectoryIfMissing, getTemporaryDirectory )-import System.Exit-    ( ExitCode(..), exitWith )+    ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) import System.FilePath     ( (</>), isAbsolute ) import qualified System.Info     ( compilerName, compilerVersion ) import System.IO-    ( hPutStrLn, stderr, hClose )+    ( hPutStrLn, hClose ) import Distribution.Text     ( Text(disp), display, simpleParse ) import Text.PrettyPrint     ( comma, punctuate, render, nest, sep ) import Distribution.Compat.Exception ( catchExit, catchIO ) -tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a)+import qualified Data.ByteString.Lazy.Char8 as BS.Char8++data ConfigStateFileErrorType = ConfigStateFileCantParse+                              | ConfigStateFileMissing+                              | ConfigStateFileBadVersion+                              deriving Eq+type ConfigStateFileError = (String, ConfigStateFileErrorType)++tryGetConfigStateFile :: (Read a) => FilePath+                         -> IO (Either ConfigStateFileError a) tryGetConfigStateFile filename = do   exists <- doesFileExist filename   if not exists-    then return (Left missing)+    then return (Left (missing, ConfigStateFileMissing))     else withFileContents filename $ \str ->       case lines str of-        [headder, rest] -> case checkHeader headder of-          Just msg -> return (Left msg)+        [header, rest] -> case checkHeader header of+          Just err -> return (Left err)           Nothing  -> case reads rest of             [(bi,_)] -> return (Right bi)-            _        -> return (Left cantParse)-        _            -> return (Left cantParse)+            _        -> return (Left (cantParse, ConfigStateFileCantParse))+        _            -> return (Left (cantParse, ConfigStateFileCantParse))   where-    checkHeader :: String -> Maybe String+    checkHeader :: String -> Maybe ConfigStateFileError     checkHeader header = case parseHeader header of       Just (cabalId, compId)         | cabalId        == currentCabalId -> Nothing-        | otherwise      -> Just (badVersion cabalId compId)-      Nothing            -> Just cantParse+        | otherwise      -> Just (badVersion cabalId compId+                                 ,ConfigStateFileBadVersion)+      Nothing            -> Just (cantParse+                                 ,ConfigStateFileCantParse)      missing   = "Run the 'configure' command first."     cantParse = "Saved package config file seems to be corrupt. "@@ -189,8 +213,9 @@              ++ display currentCompilerId              ++ ") which is probably the cause of the problem." --- internal function-tryGetPersistBuildConfig :: FilePath -> IO (Either String LocalBuildInfo)+-- |Try to read the 'localBuildInfoFile'.+tryGetPersistBuildConfig :: FilePath+                            -> IO (Either ConfigStateFileError LocalBuildInfo) tryGetPersistBuildConfig distPref     = tryGetConfigStateFile (localBuildInfoFile distPref) @@ -200,7 +225,7 @@ getPersistBuildConfig :: FilePath -> IO LocalBuildInfo getPersistBuildConfig distPref = do   lbi <- tryGetPersistBuildConfig distPref-  either die return lbi+  either (die . fst) return lbi  -- |Try to read the 'localBuildInfoFile'. maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo)@@ -214,7 +239,7 @@ writePersistBuildConfig distPref lbi = do   createDirectoryIfMissing False distPref   writeFileAtomic (localBuildInfoFile distPref)-                  (showHeader pkgid ++ '\n' : show lbi)+                  (BS.Char8.pack $ showHeader pkgid ++ '\n' : show lbi)   where     pkgid   = packageId (localPkgDescr lbi) @@ -249,9 +274,7 @@ -- .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)+  pkg_descr_file `moreRecentFile` (localBuildInfoFile distPref)  -- |@dist\/setup-config@ localBuildInfoFile :: FilePath -> FilePath@@ -274,15 +297,13 @@          createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref -        let programsConfig = userSpecifyArgss (configProgramArgs cfg)-                           . userSpecifyPaths (configProgramPaths cfg)-                           $ configPrograms cfg-            userInstall = fromFlag (configUserInstall cfg)-            packageDbs  = interpretPackageDbFlags userInstall-                            (configPackageDBs cfg)+        let programsConfig = mkProgramsConfig cfg (configPrograms cfg)+            userInstall    = fromFlag (configUserInstall cfg)+            packageDbs     = interpretPackageDbFlags userInstall+                             (configPackageDBs cfg)          -- detect compiler-        (comp, programsConfig') <- configCompiler+        (comp, compPlatform, programsConfig') <- configCompilerEx           (flagToMaybe $ configHcFlavor cfg)           (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg)           programsConfig (lessVerbose verbosity)@@ -310,7 +331,8 @@                 --      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.installedPackageId =+                   InstalledPackageId $ display $ pid,                 Installed.sourcePackageId = pid               }             internalPackageSet = PackageIndex.fromList [internalPackage]@@ -325,8 +347,10 @@             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))+            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 }@@ -335,7 +359,7 @@                 case finalizePackageDescription                        (configConfigurationsFlags cfg)                        dependencySatisfiable-                       Distribution.System.buildPlatform+                       compPlatform                        (compilerId comp)                        (configConstraints cfg)                        pkg_descr0''@@ -364,12 +388,16 @@                 (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ]))               . map (selectDependency internalPackageSet installedPackageSet) -            (failedDeps, allPkgDeps) = selectDependencies (buildDepends pkg_descr)+            (failedDeps, allPkgDeps) =+              selectDependencies (buildDepends pkg_descr) -            internalPkgDeps = [ pkgid | InternalDependency _ pkgid <- allPkgDeps ]-            externalPkgDeps = [ pkg   | ExternalDependency _ pkg   <- allPkgDeps ]+            internalPkgDeps = [ pkgid+                              | InternalDependency _ pkgid <- allPkgDeps ]+            externalPkgDeps = [ pkg+                              | ExternalDependency _ pkg   <- allPkgDeps ] -        when (not (null internalPkgDeps) && not (newPackageDepsBehaviour pkg_descr)) $+        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 "@@ -394,9 +422,11 @@                             | (pkg, deps) <- broken ]          let pseudoTopPkg = emptyInstalledPackageInfo {-                Installed.installedPackageId = InstalledPackageId (display (packageId pkg_descr)),+                Installed.installedPackageId =+                   InstalledPackageId (display (packageId pkg_descr)),                 Installed.sourcePackageId = packageId pkg_descr,-                Installed.depends = map Installed.installedPackageId externalPkgDeps+                Installed.depends =+                  map Installed.installedPackageId externalPkgDeps               }         case PackageIndex.dependencyInconsistencies            . PackageIndex.insert pseudoTopPkg@@ -411,13 +441,21 @@                          | (name, uses) <- inconsistencies                          , (pkg, ver) <- uses ] +        -- internal component graph+        buildComponents <-+          case mkComponentsLocalBuildInfo pkg_descr+                 internalPkgDeps externalPkgDeps of+            Left  componentCycle -> reportComponentCycle componentCycle+            Right components     -> return components+         -- installation directories         defaultDirs <- defaultInstallDirs flavor userInstall (hasLibs pkg_descr)         let installDirs = combineInstallDirs fromFlagOrDefault                             defaultDirs (configInstallDirs cfg)          -- check languages and extensions-        let langlist = nub $ catMaybes $ map defaultLanguage (allBuildInfo pkg_descr)+        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)@@ -438,7 +476,8 @@               [ buildTool               | let exeNames = map exeName (executables pkg_descr)               , bi <- allBuildInfo pkg_descr-              , buildTool@(Dependency (PackageName toolName) reqVer) <- buildTools bi+              , buildTool@(Dependency (PackageName toolName) reqVer)+                <- buildTools bi               , let isInternal =                         toolName `elem` exeNames                         -- we assume all internal build-tools are@@ -463,66 +502,17 @@                                           "--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]))+        sharedLibsByDefault <-+            case compilerId comp of+            CompilerId GHC _ ->+                case lookupProgram ghcProgram programsConfig''' of+                Just ghcProg ->+                    -- if ghc is dynamic, then ghci needs a shared+                    -- library, so we build one by default.+                    GHC.ghcDynamic verbosity ghcProg+                Nothing -> return False+            _ -> return False          let lbi = LocalBuildInfo {                     configFlags         = cfg,@@ -531,22 +521,20 @@                                                -- did they would go here.                     installDirTemplates = installDirs,                     compiler            = comp,+                    hostPlatform        = compPlatform,                     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,+                    componentsConfigs   = buildComponents,                     installedPkgs       = packageDependsIndex,                     pkgDescrFile        = Nothing,                     localPkgDescr       = pkg_descr',                     withPrograms        = programsConfig''',                     withVanillaLib      = fromFlag $ configVanillaLib cfg,                     withProfLib         = fromFlag $ configProfLib cfg,-                    withSharedLib       = fromFlag $ configSharedLib cfg,+                    withSharedLib       = fromFlagOrDefault sharedLibsByDefault $+                                          configSharedLib cfg,                     withDynExe          = fromFlag $ configDynExe cfg,                     withProfExe         = fromFlag $ configProfExe cfg,                     withOptimization    = fromFlag $ configOptimization cfg,@@ -582,6 +570,7 @@         dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative)         dirinfo "Data files"       (datadir dirs)    (datadir relative)         dirinfo "Documentation"    (docdir dirs)     (docdir relative)+        dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative)          sequence_ [ reportProgram verbosity prog configuredProg                   | (prog, configuredProg) <- knownPrograms programsConfig''' ]@@ -592,11 +581,24 @@       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}+              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}+                      , executables = modifyExecutable  `map`+                                      executables pkg_descr} +mkProgramsConfig :: ConfigFlags -> ProgramConfiguration -> ProgramConfiguration+mkProgramsConfig cfg initialProgramsConfig = programsConfig+  where+    programsConfig = userSpecifyArgss (configProgramArgs cfg)+                   . userSpecifyPaths (configProgramPaths cfg)+                   . setProgramSearchPath searchpath+                   $ initialProgramsConfig+    searchpath     = getProgramSearchPath (initialProgramsConfig)+                  ++ map ProgramSearchPathDir (configProgramPathExtra cfg)+ -- ----------------------------------------------------------------------------- -- Configuring package dependencies @@ -616,7 +618,8 @@ hackageUrl = "http://hackage.haskell.org/package/"  data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo-                        | InternalDependency Dependency PackageId -- should be a lib name+                        | InternalDependency Dependency PackageId -- should be a+                                                                  -- lib name  data FailedDependency = DependencyNotExists PackageName                       | DependencyNoVersion Dependency@@ -698,6 +701,19 @@     flv -> die $ "don't know how to find the installed packages for "               ++ display flv +-- | Like 'getInstalledPackages', but for a single package DB.+getPackageDBContents :: Verbosity -> Compiler+                     -> PackageDB -> ProgramConfiguration+                     -> IO PackageIndex+getPackageDBContents verbosity comp packageDB progconf = do+  info verbosity "Reading installed packages..."+  case compilerFlavor comp of+    GHC -> GHC.getPackageDBContents verbosity packageDB progconf++    -- For other compilers, try to fall back on 'getInstalledPackages'.+    _   -> getInstalledPackages verbosity comp [packageDB] progconf++ -- | 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@@ -715,7 +731,8 @@     extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs  newPackageDepsBehaviourMinVersion :: Version-newPackageDepsBehaviourMinVersion = Version { versionBranch = [1,7,1], versionTags = [] }+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@@ -729,12 +746,15 @@ -- ----------------------------------------------------------------------------- -- Configuring program dependencies -configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration -> IO ProgramConfiguration+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) =+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@@ -835,33 +855,133 @@ -- ----------------------------------------------------------------------------- -- 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))+configCompilerAuxEx :: ConfigFlags+                    -> IO (Compiler, Platform, ProgramConfiguration)+configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg)+                                           (flagToMaybe $ configHcPath cfg)+                                           (flagToMaybe $ configHcPkg cfg)+                                           programsConfig+                                           (fromFlag (configVerbosity cfg))   where-    programsConfig = userSpecifyArgss (configProgramArgs cfg)-                   . userSpecifyPaths (configProgramPaths cfg)-                   $ defaultProgramConfiguration+    programsConfig = mkProgramsConfig cfg defaultProgramConfiguration +configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath+                 -> ProgramConfiguration -> Verbosity+                 -> IO (Compiler, Platform, ProgramConfiguration)+configCompilerEx Nothing _ _ _ _ = die "Unknown compiler"+configCompilerEx (Just hcFlavor) hcPath hcPkg conf verbosity = do+  (comp, maybePlatform, programsConfig) <- case hcFlavor of+    GHC  -> GHC.configure  verbosity hcPath hcPkg conf+    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"+  return (comp, fromMaybe buildPlatform maybePlatform, programsConfig)++-- Ideally we would like to not have separate configCompiler* and+-- configCompiler*Ex sets of functions, but there are many custom setup scripts+-- in the wild that are using them, so the versions with old types are kept for+-- backwards compatibility. Platform was added to the return triple in 1.18.++{-# DEPRECATED configCompiler+    "'configCompiler' is deprecated. Use 'configCompilerEx' instead." #-} configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath                -> ProgramConfiguration -> Verbosity                -> IO (Compiler, ProgramConfiguration)-configCompiler 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"+configCompiler mFlavor hcPath hcPkg conf verbosity =+  fmap (\(a,_,b) -> (a,b)) $ configCompilerEx mFlavor hcPath hcPkg conf verbosity +{-# DEPRECATED configCompilerAux+    "configCompilerAux is deprecated. Use 'configCompilerAuxEx' instead." #-}+configCompilerAux :: ConfigFlags+                  -> IO (Compiler, ProgramConfiguration)+configCompilerAux = fmap (\(a,_,b) -> (a,b)) . configCompilerAuxEx +-- -----------------------------------------------------------------------------+-- Making the internal component graph+++mkComponentsLocalBuildInfo :: PackageDescription+                           -> [PackageId] -> [InstalledPackageInfo]+                           -> Either [ComponentName]+                                     [(ComponentName,+                                       ComponentLocalBuildInfo, [ComponentName])]+mkComponentsLocalBuildInfo pkg_descr internalPkgDeps externalPkgDeps =+    let graph = [ (c, componentName c, componentDeps c)+                | c <- pkgEnabledComponents pkg_descr ]+     in case checkComponentsCyclic graph of+          Just ccycle -> Left  [ cname | (_,cname,_) <- ccycle ]+          Nothing     -> Right [ (cname, clbi, cdeps)+                               | (c, cname, cdeps) <- graph+                               , let clbi = componentLocalBuildInfo c ]+  where+    -- The dependencies for the given component+    componentDeps component =+         [ CExeName toolname | Dependency (PackageName toolname) _+                               <- buildTools bi+                             , toolname `elem` map exeName+                               (executables pkg_descr) ]++      ++ [ CLibName          | Dependency pkgname _ <- targetBuildDepends bi+                             , pkgname `elem` map packageName internalPkgDeps ]+      where+        bi = componentBuildInfo component++    -- The allPkgDeps contains all the package deps for the whole package+    -- but we need to select the subset for this specific component.+    -- we just take the subset for the package names this component+    -- needs. Note, this only works because we cannot yet depend on two+    -- versions of the same package.+    componentLocalBuildInfo component =+      case component of+      CLib _ ->+        LibComponentLocalBuildInfo {+          componentPackageDeps = cpds,+          componentLibraries = [LibraryName+                                ("HS" ++ display (package pkg_descr))]+        }+      CExe _ ->+        ExeComponentLocalBuildInfo {+          componentPackageDeps = cpds+        }+      CTest _ ->+        TestComponentLocalBuildInfo {+          componentPackageDeps = cpds+        }+      CBench _ ->+        BenchComponentLocalBuildInfo {+          componentPackageDeps = cpds+        }+      where+        bi = componentBuildInfo component+        cpds = 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 ]++reportComponentCycle :: [ComponentName] -> IO a+reportComponentCycle cnames =+    die $ "Components in the package depend on each other in a cyclic way:\n  "+       ++ intercalate " depends on "+            [ "'" ++ showComponentName cname ++ "'"+            | cname <- cnames ++ [head cnames] ]+++-- -----------------------------------------------------------------------------+-- Testing C lib and header dependencies+ -- Try to build a test C program which includes every header and links every -- lib. If that fails, try to narrow it down by preprocessing (only) and linking -- with individual headers and libs.  If none is the obvious culprit then give a@@ -869,7 +989,8 @@ -- 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+  ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling+                                                               -- lucky            (return ())            (do missingLibs <- findMissingLibs                missingHdr  <- findOffendingHdr@@ -906,7 +1027,7 @@          libExists lib = builds (makeProgram []) (makeLdArgs [lib]) -        commonCppArgs = hcDefines (compiler lbi)+        commonCppArgs = platformDefines lbi                      ++ [ "-I" ++ autogenModulesDir lbi ]                      ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ]                      ++ ["-I."]@@ -1005,66 +1126,6 @@           ++ "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@@ -1077,5 +1138,4 @@       warnings = [ w | PackageBuildWarning    w <- pureChecks ++ ioChecks ]   if null errors     then mapM_ (warn verbosity) warnings-    else do mapM_ (hPutStrLn stderr . ("Error: " ++)) errors-            exitWith (ExitFailure 1)+    else die (intercalate "\n\n" errors)
Distribution/Simple/GHC.hs view
@@ -61,24 +61,26 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}  module Distribution.Simple.GHC (-        configure, getInstalledPackages,+        getGhcInfo,+        configure, getInstalledPackages, getPackageDBContents,         buildLib, buildExe,+        replLib, replExe,         installLib, installExe,         libAbiHash,+        initPackageDB,+        invokeHcPkg,         registerPackage,         componentGhcOptions,         ghcLibDir,--        -- * Deprecated-        ghcVerbosityOptions,-        ghcPackageDbOptions,+        ghcDynamic,  ) where  import qualified Distribution.Simple.GHC.IPI641 as IPI641 import qualified Distribution.Simple.GHC.IPI642 as IPI642 import Distribution.PackageDescription as PD          ( PackageDescription(..), BuildInfo(..), Executable(..)-         , Library(..), libModules, hcOptions, usedExtensions, allExtensions )+         , Library(..), libModules, exeModules, hcOptions+         , usedExtensions, allExtensions ) import Distribution.InstalledPackageInfo          ( InstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo@@ -87,19 +89,20 @@ import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-         , absoluteInstallDirs )+         , LibraryName(..), absoluteInstallDirs ) import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package-         ( PackageIdentifier, Package(..), PackageName(..) )+         ( Package(..), PackageName(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg-         , ProgramLocation(..), rawSystemProgram+         ( Program(..), ConfiguredProgram(..), ProgramConfiguration+         , ProgramLocation(..), ProgramSearchPath, ProgramSearchPathEntry(..)+         , rawSystemProgram          , rawSystemProgramStdout, rawSystemProgramStdoutConf-         , getProgramInvocationOutput-         , requireProgramVersion, requireProgram, getProgramOutput+         , getProgramOutput, getProgramInvocationOutput, suppressOverrideArgs+         , requireProgramVersion, requireProgram          , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram          , ghcProgram, ghcPkgProgram, hsc2hsProgram          , arProgram, ranlibProgram, ldProgram@@ -120,9 +123,10 @@ import Distribution.Verbosity import Distribution.Text          ( display, simpleParse )-import Language.Haskell.Extension (Language(..), Extension(..), KnownExtension(..))+import Language.Haskell.Extension (Language(..), Extension(..)+                                  ,KnownExtension(..)) -import Control.Monad            ( unless, when, liftM )+import Control.Monad            ( unless, when ) import Data.Char                ( isSpace ) import Data.List import Data.Maybe               ( catMaybes, fromMaybe )@@ -131,16 +135,20 @@          ( removeFile, getDirectoryContents, doesFileExist          , getTemporaryDirectory ) import System.FilePath          ( (</>), (<.>), takeExtension,-                                  takeDirectory, replaceExtension, splitExtension )+                                  takeDirectory, replaceExtension,+                                  splitExtension ) import System.IO (hClose, hPutStrLn) import System.Environment (getEnv) import Distribution.Compat.Exception (catchExit, catchIO)+import Distribution.System (Platform, platformFromTriple) + -- ----------------------------------------------------------------------------- -- Configuring  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)+          -> ProgramConfiguration+          -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath hcPkgPath conf0 = do    (ghcProg, ghcVersion, conf1) <-@@ -171,24 +179,20 @@   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 []+  ghcInfo <- getGhcInfo verbosity ghcProg    let comp = Compiler {         compilerId             = CompilerId GHC ghcVersion,         compilerLanguages      = languages,         compilerExtensions     = extensions       }+      compPlatform = targetPlatform ghcInfo       conf4 = configureToolchain ghcProg ghcInfo conf3 -- configure gcc and ld-  return (comp, conf4)+  return (comp, compPlatform, conf4) +targetPlatform :: [(String, String)] -> Maybe Platform+targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo+ -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find -- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking -- for a versioned or unversioned ghc-pkg in the same dir, that is:@@ -197,28 +201,36 @@ -- > /usr/local/bin/ghc-pkg-6.6.1(.exe) -- > /usr/local/bin/ghc-pkg(.exe) ---guessToolFromGhcPath :: FilePath -> ConfiguredProgram -> Verbosity+guessToolFromGhcPath :: Program -> ConfiguredProgram+                     -> Verbosity -> ProgramSearchPath                      -> IO (Maybe FilePath)-guessToolFromGhcPath tool ghcProg verbosity-  = do let path              = programPath ghcProg+guessToolFromGhcPath tool ghcProg verbosity searchpath+  = do let toolname          = programName tool+           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+           guessNormal       = dir </> toolname <.> exeExtension+           guessGhcVersioned = dir </> (toolname ++ "-ghc" ++ versionSuffix)+                               <.> exeExtension+           guessVersioned    = dir </> (toolname ++ versionSuffix)+                               <.> exeExtension            guesses | null versionSuffix = [guessNormal]                    | otherwise          = [guessGhcVersioned,                                            guessVersioned,                                            guessNormal]-       info verbosity $ "looking for tool " ++ show tool ++ " near compiler in " ++ dir+       info verbosity $ "looking for tool " ++ toolname+         ++ " 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+                   -- If we can't find it near ghc, fall back to the usual+                   -- method.+         []     -> programFindLocation tool verbosity searchpath+         (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp                       return (Just fp)    where takeVersionSuffix :: FilePath -> String-        takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") . reverse+        takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") .+                            reverse          dropExeExtension :: FilePath -> FilePath         dropExeExtension filepath =@@ -234,8 +246,9 @@ -- > /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"+guessGhcPkgFromGhcPath :: ConfiguredProgram+                       -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram  -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a -- corresponding hsc2hs, we try looking for both a versioned and unversioned@@ -245,8 +258,9 @@ -- > /usr/local/bin/hsc2hs-6.6.1(.exe) -- > /usr/local/bin/hsc2hs(.exe) ---guessHsc2hsFromGhcPath :: ConfiguredProgram -> Verbosity -> IO (Maybe FilePath)-guessHsc2hsFromGhcPath = guessToolFromGhcPath "hsc2hs"+guessHsc2hsFromGhcPath :: ConfiguredProgram+                       -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram  -- | Adjust the way we find and configure gcc and ld --@@ -255,30 +269,18 @@                                         -> ProgramConfiguration configureToolchain ghcProg ghcInfo =     addKnownProgram gccProgram {-      programFindLocation = findProg gccProgram-                              [ if ghcVersion >= Version [6,12] []-                                  then mingwBinDir </> binPrefix ++ "gcc.exe"-                                  else baseDir     </> "gcc.exe" ],+      programFindLocation = findProg gccProgram extraGccPath,       programPostConf     = configureGcc     }   . addKnownProgram ldProgram {-      programFindLocation = findProg ldProgram-                              [ if ghcVersion >= Version [6,12] []-                                  then mingwBinDir </> binPrefix ++ "ld.exe"-                                  else libDir      </> "ld.exe" ],+      programFindLocation = findProg ldProgram extraLdPath,       programPostConf     = configureLd     }   . addKnownProgram arProgram {-      programFindLocation = findProg arProgram-                              [ if ghcVersion >= Version [6,12] []-                                  then mingwBinDir </> binPrefix ++ "ar.exe"-                                  else libDir      </> "ar.exe" ]+      programFindLocation = findProg arProgram extraArPath     }   . addKnownProgram stripProgram {-      programFindLocation = findProg stripProgram-                              [ if ghcVersion >= Version [6,12] []-                                  then mingwBinDir </> binPrefix ++ "strip.exe"-                                  else libDir      </> "strip.exe" ]+      programFindLocation = findProg stripProgram extraStripPath     }   where     Just ghcVersion = programVersion ghcProg@@ -290,19 +292,28 @@     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+    -- on Windows finding and configuring ghc's gcc & binutils is a bit special+    extraGccPath+      | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix ++ "gcc.exe"+      | otherwise                       = baseDir     </> "gcc.exe"+    extraLdPath+      | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix ++ "ld.exe"+      | otherwise                       = libDir      </> "ld.exe"+    extraArPath+      | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix ++ "ar.exe"+      | otherwise                       = libDir      </> "ar.exe"+    extraStripPath+      | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix +++                                          "strip.exe"+      | otherwise                       = libDir      </> "strip.exe"++    findProg :: Program -> FilePath+             -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+    findProg prog extraPath v searchpath =+        programFindLocation prog v searchpath'       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+        searchpath' | isWindows = ProgramSearchPathDir extraPath : searchpath+                    | otherwise = searchpath      ccFlags        = getFlags "C compiler flags"     gccLinkerFlags = getFlags "Gcc Linker flags"@@ -315,11 +326,15 @@                        [(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 ConfiguredProgram+    configureGcc v gccProg = do+      gccProg' <- configureGcc' v gccProg+      return gccProg' {+        programDefaultArgs = programDefaultArgs gccProg'+                             ++ ccFlags ++ gccLinkerFlags+      } -    configureGcc' :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+    configureGcc' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram     configureGcc'       | isWindows = \_ gccProg -> case programLocation gccProg of           -- if it's found on system then it means we're using the result@@ -329,20 +344,25 @@           -- various files:           FoundOnSystem {}            | ghcVersion < Version [6,11] [] ->-              return ["-B" ++ libDir, "-I" ++ includeDir]-          _ -> return []-      | otherwise = \_ _   -> return []+               return gccProg { programDefaultArgs = ["-B" ++ libDir,+                                                      "-I" ++ includeDir] }+          _ -> return gccProg+      | otherwise = \_ gccProg -> return gccProg -    configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg]-    configureLd v cp = liftM (++ ldLinkerFlags) $ configureLd' v cp+    configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram+    configureLd v ldProg = do+      ldProg' <- configureLd' v ldProg+      return ldProg' {+        programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags+      }      -- we need to find out if ld supports the -x flag-    configureLd' :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+    configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram     configureLd' verbosity ldProg = do       tempDir <- getTemporaryDirectory       ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->              withTempFile tempDir ".o" $ \testofile testohnd -> do-               hPutStrLn testchnd "int foo() {}"+               hPutStrLn testchnd "int foo() { return 0; }"                hClose testchnd; hClose testohnd                rawSystemProgram verbosity ghcProg ["-c", testcfile,                                                    "-o", testofile]@@ -355,8 +375,8 @@                  `catchIO`   (\_ -> return False)                  `catchExit` (\_ -> return False)       if ldx-        then return ["-x"]-        else return []+        then return ldProg { programDefaultArgs = ["-x"] }+        else return ldProg  getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)] getLanguages _ ghcProg@@ -367,11 +387,27 @@   where     Just ghcVersion = programVersion ghcProg +getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]+getGhcInfo verbosity ghcProg =+    case programVersion ghcProg of+    Just ghcVersion+     | ghcVersion >= Version [6,7] [] ->+        do xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)+                 ["--info"]+           case reads xs of+               [(i, ss)]+                | all isSpace ss ->+                   return i+               _ ->+                   die "Can't parse --info output of GHC"+    _ ->+        return []+ getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] getExtensions verbosity ghcProg   | ghcVersion >= Version [6,7] [] = do -    str <- rawSystemStdout verbosity (programPath ghcProg)+    str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)               ["--supported-languages"]     let extStrs = if ghcVersion >= Version [7] []                   then lines str@@ -466,24 +502,24 @@     ,(DeriveDataTypeable         , fglasgowExts)     ,(ConstrainedClassMethods    , fglasgowExts)     ]+-- | Given a single package DB, return all installed packages.+getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration+                        -> IO PackageIndex+getPackageDBContents verbosity packagedb conf = do+  pkgss <- getInstalledPackages' verbosity [packagedb] conf+  toPackageIndex verbosity pkgss conf +-- | Given a package DB stack, return all installed packages. getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration                      -> IO PackageIndex getInstalledPackages verbosity packagedbs conf = do   checkPackageDbEnvVar   checkPackageDbStack packagedbs   pkgss <- getInstalledPackages' verbosity packagedbs conf-  topDir <- ghcLibDir' verbosity ghcProg-  let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)-                | (_, pkgs) <- pkgss ]-  return $! hackRtsPackage (mconcat indexes)+  index <- toPackageIndex verbosity pkgss conf+  return $! hackRtsPackage index    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])]@@ -491,10 +527,30 @@         _  -> index -- No (or multiple) ghc rts package is registered!!                     -- Feh, whatever, the ghc testsuite does some crazy stuff. +-- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a+-- @PackageIndex@. Helper function used by 'getPackageDBContents' and+-- 'getInstalledPackages'.+toPackageIndex :: Verbosity+               -> [(PackageDB, [InstalledPackageInfo])]+               -> ProgramConfiguration+               -> IO PackageIndex+toPackageIndex verbosity pkgss conf = do+  -- On Windows, various fields have $topdir/foo rather than full+  -- paths. We need to substitute the right value in so that when+  -- we, for example, call gcc, we have proper paths to give it.+  topDir <- ghcLibDir' verbosity ghcProg+  let indices = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)+                | (_, pkgs) <- pkgss ]+  return $! (mconcat indices)++  where+    Just ghcProg = lookupProgram ghcProgram conf+ ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath ghcLibDir verbosity lbi =     (reverse . dropWhile isSpace . reverse) `fmap`-     rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"]+     rawSystemProgramStdoutConf verbosity ghcProgram+     (withPrograms lbi) ["--print-libdir"]  ghcLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath ghcLibDir' verbosity ghcProg =@@ -606,15 +662,30 @@  -- | Build a library with GHC. ---buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity pkg_descr lbi lib clbi = do-  let pref = buildDir lbi+buildLib, replLib :: Verbosity+                  -> PackageDescription -> LocalBuildInfo+                  -> Library            -> ComponentLocalBuildInfo -> IO ()+buildLib = buildOrReplLib False+replLib  = buildOrReplLib True++buildOrReplLib :: Bool -> Verbosity+               -> PackageDescription -> LocalBuildInfo+               -> Library            -> ComponentLocalBuildInfo -> IO ()+buildOrReplLib forRepl verbosity pkg_descr lbi lib clbi = do+  libName <- case componentLibraries clbi of+             [libName] -> return libName+             [] -> die "No library name found when building library"+             _  -> die "Multiple library names found when building library"++  let libTargetDir = 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)+      whenVanillaLib forceVanilla =+        when (not forRepl && (forceVanilla || withVanillaLib lbi))+      whenProfLib = when (not forRepl && withProfLib lbi)+      whenSharedLib forceShared =+        when (not forRepl &&  (forceShared || withSharedLib lbi))+      whenGHCiLib = when (not forRepl && withGHCiLib lbi && withVanillaLib lbi)+      ifReplLib = when forRepl       comp = compiler lbi       ghcVersion = compilerVersion comp @@ -624,13 +695,18 @@   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+  isGhcDynamic <- ghcDynamic verbosity ghcProg+  dynamicTooSupported <- ghcSupportsDynamicToo verbosity ghcProg+  let doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi+      forceVanillaLib = doingTH && not isGhcDynamic+      forceSharedLib  = doingTH &&     isGhcDynamic+      -- TH always needs default libs, even when building for profiling    createDirectoryIfMissingVerbose verbosity True libTargetDir-  -- TODO: do we need to put hs-boot files into place for mutually recurive modules?-  let baseOpts    = componentGhcOptions verbosity lbi libBi clbi libTargetDir+  -- TODO: do we need to put hs-boot files into place for mutually recursive+  -- modules?+  let cObjs       = map (`replaceExtension` objExtension) (cSources libBi)+      baseOpts    = componentGhcOptions verbosity lbi libBi clbi libTargetDir       vanillaOpts = baseOpts `mappend` mempty {                       ghcOptMode         = toFlag GhcModeMake,                       ghcOptPackageName  = toFlag pkgid,@@ -645,49 +721,90 @@                     }        sharedOpts  = vanillaOpts `mappend` mempty {-                      ghcOptDynamic   = toFlag True,-                      ghcOptFPic      = toFlag True,-                      ghcOptHiSuffix  = toFlag "dyn_hi",-                      ghcOptObjSuffix = toFlag "dyn_o",-                      ghcOptExtra     = ghcSharedOptions libBi+                      ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                      ghcOptFPic        = toFlag True,+                      ghcOptHiSuffix    = toFlag "dyn_hi",+                      ghcOptObjSuffix   = toFlag "dyn_o",+                      ghcOptExtra       = ghcSharedOptions libBi                     }+      linkerOpts = mempty {+                      ghcOptLinkOptions    = PD.ldOptions libBi,+                      ghcOptLinkLibs       = extraLibs libBi,+                      ghcOptLinkLibPath    = extraLibDirs libBi,+                      ghcOptLinkFrameworks = PD.frameworks libBi,+                      ghcOptInputFiles     = [libTargetDir </> x | x <- cObjs]+                   }+      replOpts    = vanillaOpts {+                      ghcOptExtra        = filterGhciFlags+                                           (ghcOptExtra vanillaOpts)+                    }+                    `mappend` linkerOpts+                    `mappend` mempty {+                      ghcOptMode         = toFlag GhcModeInteractive,+                      ghcOptOptimisation = toFlag GhcNoOptimisation+                    } +      vanillaSharedOpts = vanillaOpts `mappend` mempty {+                      ghcOptDynLinkMode  = toFlag GhcStaticAndDynamic,+                      ghcOptDynHiSuffix  = toFlag "dyn_hi",+                      ghcOptDynObjSuffix = toFlag "dyn_o"+                    }+   unless (null (libModules lib)) $-    do ifVanillaLib forceVanillaLib (runGhcProg vanillaOpts)-       ifProfLib (runGhcProg profOpts)-       ifSharedLib (runGhcProg sharedOpts)+    do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts)+           shared  = whenSharedLib  forceSharedLib  (runGhcProg sharedOpts)+           useDynToo = dynamicTooSupported &&+                       (forceVanillaLib || withVanillaLib lbi) &&+                       (forceSharedLib  || withSharedLib  lbi) &&+                       null (ghcSharedOptions libBi)+       if useDynToo+           then runGhcProg vanillaSharedOpts+           else if isGhcDynamic then do shared;  vanilla+                                else do vanilla; shared+       whenProfLib (runGhcProg profOpts)    -- build any C sources   unless (null (cSources libBi)) $ do      info verbosity "Building C Sources..."      sequence_        [ do let vanillaCcOpts = (componentCcGhcOptions verbosity lbi-                                    libBi clbi pref filename) `mappend` mempty {-                                  ghcOptProfilingMode = toFlag (withProfLib lbi)+                                    libBi clbi libTargetDir filename)+                profCcOpts    = vanillaCcOpts `mappend` mempty {+                                  ghcOptProfilingMode = toFlag True,+                                  ghcOptObjSuffix     = toFlag "p_o"                                 }                 sharedCcOpts  = vanillaCcOpts `mappend` mempty {-                                  ghcOptFPic      = toFlag True,-                                  ghcOptDynamic   = toFlag True,-                                  ghcOptObjSuffix = toFlag "dyn_o"+                                  ghcOptFPic        = toFlag True,+                                  ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                                  ghcOptObjSuffix   = toFlag "dyn_o"                                 }                 odir          = fromFlag (ghcOptObjDir vanillaCcOpts)             createDirectoryIfMissingVerbose verbosity True odir             runGhcProg vanillaCcOpts-            ifSharedLib (runGhcProg sharedCcOpts)+            whenSharedLib forceSharedLib (runGhcProg sharedCcOpts)+            whenProfLib (runGhcProg profCcOpts)        | filename <- cSources libBi] +  -- TODO: problem here is we need the .c files built first, so we can load them+  -- with ghci, but .c files can depend on .h files generated by ghc by ffi+  -- exports.+  unless (null (libModules lib)) $+     ifReplLib (runGhcProg replOpts)++   -- link:   info verbosity "Linking..."-  let 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+  let cProfObjs   = map (`replaceExtension` ("p_" ++ objExtension))+                    (cSources libBi)+      cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))+                    (cSources libBi)+      cid = compilerId (compiler lbi)+      vanillaLibFilePath = libTargetDir </> mkLibName           libName+      profileLibFilePath = libTargetDir </> mkProfLibName       libName+      sharedLibFilePath  = libTargetDir </> mkSharedLibName cid libName+      ghciLibFilePath    = libTargetDir </> mkGHCiLibName       libName       libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest-      sharedLibInstallPath = libInstallPath </> mkSharedLibName pkgid-                                              (compilerId (compiler lbi))+      sharedLibInstallPath = libInstallPath </> mkSharedLibName cid libName    stubObjs <- fmap catMaybes $ sequence     [ findFileWithExtension [objExtension] [libTargetDir]@@ -706,40 +823,40 @@     , x <- libModules lib ]    hObjs     <- getHaskellObjects lib lbi-                    pref objExtension True+                    libTargetDir objExtension True   hProfObjs <-     if (withProfLib lbi)             then getHaskellObjects lib lbi-                    pref ("p_" ++ objExtension) True+                    libTargetDir ("p_" ++ objExtension) True             else return []   hSharedObjs <-     if (withSharedLib lbi)             then getHaskellObjects lib lbi-                    pref ("dyn_" ++ objExtension) False+                    libTargetDir ("dyn_" ++ objExtension) False             else return []    unless (null hObjs && null cObjs && null stubObjs) $ do     -- first remove library files if they exists-    sequence_+    unless forRepl $ sequence_       [ removeFile libFilePath `catchIO` \_ -> return ()       | libFilePath <- [vanillaLibFilePath, profileLibFilePath                        ,sharedLibFilePath,  ghciLibFilePath] ]      let staticObjectFiles =                hObjs-            ++ map (pref </>) cObjs+            ++ map (libTargetDir </>) cObjs             ++ stubObjs         profObjectFiles =                hProfObjs-            ++ map (pref </>) cObjs+            ++ map (libTargetDir </>) cProfObjs             ++ stubProfObjs         ghciObjFiles =                hObjs-            ++ map (pref </>) cObjs+            ++ map (libTargetDir </>) cObjs             ++ stubObjs         dynamicObjectFiles =                hSharedObjs-            ++ map (pref </>) cSharedObjs+            ++ map (libTargetDir </>) cSharedObjs             ++ stubSharedObjs         -- After the relocation lib is created we invoke ghc -shared         -- with the dependencies spelled out as -package arguments@@ -747,7 +864,7 @@         ghcSharedLinkArgs =             mempty {               ghcOptShared             = toFlag True,-              ghcOptDynamic            = toFlag True,+              ghcOptDynLinkMode        = toFlag GhcDynamicOnly,               ghcOptInputFiles         = dynamicObjectFiles,               ghcOptOutputFile         = toFlag sharedLibFilePath,               -- For dynamic libs, Mac OS/X needs to know the install location@@ -763,32 +880,38 @@               ghcOptLinkLibPath        = extraLibDirs libBi             } -    ifVanillaLib False $ do+    whenVanillaLib False $ do       (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi)       Ar.createArLibArchive verbosity arProg         vanillaLibFilePath staticObjectFiles -    ifProfLib $ do+    whenProfLib $ do       (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi)       Ar.createArLibArchive verbosity arProg         profileLibFilePath profObjectFiles -    ifGHCiLib $ do+    whenGHCiLib $ do       (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)       Ld.combineObjectFiles verbosity ldProg         ghciLibFilePath ghciObjFiles -    ifSharedLib $+    whenSharedLib False $       runGhcProg ghcSharedLinkArgs   -- | Build an executable with GHC. ---buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe verbosity _pkg_descr lbi+buildExe, replExe :: Verbosity+                  -> PackageDescription -> LocalBuildInfo+                  -> Executable         -> ComponentLocalBuildInfo -> IO ()+buildExe = buildOrReplExe False+replExe  = buildOrReplExe True++buildOrReplExe :: Bool -> Verbosity+               -> PackageDescription -> LocalBuildInfo+               -> Executable         -> ComponentLocalBuildInfo -> IO ()+buildOrReplExe forRepl 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@@ -798,69 +921,140 @@    -- exeNameReal, the name that GHC really uses (with .exe on Windows)   let exeNameReal = exeName' <.>-                    (if null $ takeExtension exeName' then exeExtension else "")+                    (if takeExtension exeName' /= ('.':exeExtension)+                       then exeExtension+                       else "") -  let targetDir = pref </> exeName'+  let targetDir = (buildDir lbi) </> exeName'   let exeDir    = targetDir </> (exeName' ++ "-tmp")   createDirectoryIfMissingVerbose verbosity True targetDir   createDirectoryIfMissingVerbose verbosity True exeDir-  -- TODO: do we need to put hs-boot files into place for mutually recursive modules?-  -- FIX: what about exeName.hi-boot?+  -- 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+  srcMainFile         <- findFile (exeDir : hsSourceDirs exeBi) modPath+  isGhcDynamic        <- ghcDynamic verbosity ghcProg+  dynamicTooSupported <- ghcSupportsDynamicToo verbosity ghcProg -  let cObjs = map (`replaceExtension` objExtension) (cSources exeBi)-  let vanillaOpts = (componentGhcOptions verbosity lbi exeBi clbi exeDir)+  let isHaskellMain = elem (takeExtension srcMainFile) [".hs", ".lhs"]+      cSrcs         = cSources exeBi ++ [srcMainFile | not isHaskellMain]+      cObjs         = map (`replaceExtension` objExtension) cSrcs+      baseOpts   = (componentGhcOptions verbosity lbi exeBi clbi exeDir)                     `mappend` mempty {-                      ghcOptMode           = toFlag GhcModeMake,-                      ghcOptInputFiles     = [exeDir </> x | x <- cObjs]-                                          ++ [srcMainFile],-                      ghcOptLinkOptions    = PD.ldOptions exeBi,-                      ghcOptLinkLibs       = extraLibs exeBi,-                      ghcOptLinkLibPath    = extraLibDirs exeBi,-                      ghcOptLinkFrameworks = PD.frameworks exeBi+                      ghcOptMode         = toFlag GhcModeMake,+                      ghcOptInputFiles   =+                        [ srcMainFile | isHaskellMain],+                      ghcOptInputModules =+                        [ m | not isHaskellMain, m <- exeModules exe]                     }--      exeOpts     | withProfExe lbi = vanillaOpts `mappend` mempty {+      staticOpts = baseOpts `mappend` mempty {+                      ghcOptDynLinkMode    = toFlag GhcStaticOnly+                   }+      profOpts   = baseOpts `mappend` mempty {                       ghcOptProfilingMode  = toFlag True,                       ghcOptHiSuffix       = toFlag "p_hi",                       ghcOptObjSuffix      = toFlag "p_o",                       ghcOptExtra          = ghcProfOptions exeBi                     }-                  | withDynExe lbi = vanillaOpts `mappend` mempty {-                      ghcOptDynamic        = toFlag True,+      dynOpts    = baseOpts `mappend` mempty {+                      ghcOptDynLinkMode    = toFlag GhcDynamicOnly,                       ghcOptHiSuffix       = toFlag "dyn_hi",                       ghcOptObjSuffix      = toFlag "dyn_o",                       ghcOptExtra          = ghcSharedOptions exeBi                     }-                  | otherwise = vanillaOpts+      dynTooOpts = staticOpts `mappend` mempty {+                      ghcOptDynLinkMode    = toFlag GhcStaticAndDynamic,+                      ghcOptDynHiSuffix    = toFlag "dyn_hi",+                      ghcOptDynObjSuffix   = toFlag "dyn_o"+                    }+      linkerOpts = mempty {+                      ghcOptLinkOptions    = PD.ldOptions exeBi,+                      ghcOptLinkLibs       = extraLibs exeBi,+                      ghcOptLinkLibPath    = extraLibDirs exeBi,+                      ghcOptLinkFrameworks = PD.frameworks exeBi,+                      ghcOptInputFiles     = [exeDir </> x | x <- cObjs]+                   }+      replOpts   = baseOpts {+                      ghcOptExtra          = filterGhciFlags+                                             (ghcOptExtra baseOpts)+                   }+                   -- For a normal compile we do separate invocations of ghc for+                   -- compiling as for linking. But for repl we have to do just+                   -- the one invocation, so that one has to include all the+                   -- linker stuff too, like -l flags and any .o files from C+                   -- files etc.+                   `mappend` linkerOpts+                   `mappend` mempty {+                      ghcOptMode           = toFlag GhcModeInteractive,+                      ghcOptOptimisation   = toFlag GhcNoOptimisation+                   }+      commonOpts  | withProfExe lbi = profOpts+                  | withDynExe  lbi = dynOpts+                  | otherwise       = staticOpts+      compileOpts | useDynToo = dynTooOpts+                  | otherwise = commonOpts+      withStaticExe = (not $ withProfExe lbi) && (not $ withDynExe lbi) -  -- For building exe's 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 }+      -- For building exe's that use TH with -prof or -dynamic we actually have+      -- to build twice, once without -prof/-dynamic and then again with+      -- -prof/-dynamic. This is because the code that TH needs to run at+      -- compile time needs to be the vanilla ABI so it can be loaded up and run+      -- by the compiler.+      -- With dynamic-by-default GHC the TH object files loaded at compile-time+      -- need to be .dyn_o instead of .o.+      doingTH = EnableExtension TemplateHaskell `elem` allExtensions exeBi+      -- Should we use -dynamic-too instead of compilng twice?+      useDynToo = dynamicTooSupported && isGhcDynamic+                  && doingTH && withStaticExe && null (ghcSharedOptions exeBi)+      compileTHOpts | isGhcDynamic = dynOpts+                    | otherwise    = staticOpts+      compileForTH+        | forRepl      = False+        | useDynToo    = False+        | isGhcDynamic = doingTH && (withProfExe lbi || withStaticExe)+        | otherwise    = doingTH && (withProfExe lbi || withDynExe lbi) -  runGhcProg exeOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }+      linkOpts = commonOpts `mappend`+                 linkerOpts `mappend` mempty {+                      ghcOptLinkNoHsMain   = toFlag (not isHaskellMain)+                 } +  -- Build static/dynamic object files for TH, if needed.+  when compileForTH $+    runGhcProg compileTHOpts { ghcOptNoLink = toFlag True } +  unless forRepl $+    runGhcProg compileOpts { ghcOptNoLink = toFlag True }++  -- build any C sources+  unless (null cSrcs) $ do+   info verbosity "Building C Sources..."+   sequence_+     [ do let opts = (componentCcGhcOptions verbosity lbi exeBi clbi+                         exeDir filename) `mappend` mempty {+                       ghcOptDynLinkMode   = toFlag (if withDynExe lbi+                                                       then GhcDynamicOnly+                                                       else GhcStaticOnly),+                       ghcOptProfilingMode = toFlag (withProfExe lbi)+                     }+              odir = fromFlag (ghcOptObjDir opts)+          createDirectoryIfMissingVerbose verbosity True odir+          runGhcProg opts+     | filename <- cSrcs ]++  -- TODO: problem here is we need the .c files built first, so we can load them+  -- with ghci, but .c files can depend on .h files generated by ghc by ffi+  -- exports.+  when forRepl $ runGhcProg replOpts++  -- link:+  unless forRepl $ do+    info verbosity "Linking..."+    runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }++ -- | Filter the "-threaded" flag when profiling as it does not --   work with ghc-6.8 and older. hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo@@ -877,6 +1071,19 @@       [ (hc, if hc == GHC then filter p opts else opts)       | (hc, opts) <- hcoptss ] +-- | Strip out flags that are not supported in ghci+filterGhciFlags :: [String] -> [String]+filterGhciFlags = filter supported+  where+    supported ('-':'O':_) = False+    supported "-debug"    = False+    supported "-threaded" = False+    supported "-ticky"    = False+    supported "-eventlog" = False+    supported "-prof"     = False+    supported "-unreg"    = False+    supported _           = True+ -- when using -split-objs, we need to search for object files in the -- Module_split directory for each module. getHaskellObjects :: Library -> LocalBuildInfo@@ -908,13 +1115,30 @@   libBi <- hackThreadedFlag verbosity              (compiler lbi) (withProfLib lbi) (libBuildInfo lib)   let-      ghcArgs =+      vanillaArgs =         (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))         `mappend` mempty {           ghcOptMode         = toFlag GhcModeAbiHash,           ghcOptPackageName  = toFlag (packageId pkg_descr),           ghcOptInputModules = exposedModules lib         }+      sharedArgs = vanillaArgs `mappend` mempty {+                       ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                       ghcOptFPic        = toFlag True,+                       ghcOptHiSuffix    = toFlag "dyn_hi",+                       ghcOptObjSuffix   = toFlag "dyn_o",+                       ghcOptExtra       = ghcSharedOptions libBi+                   }+      profArgs = vanillaArgs `mappend` mempty {+                     ghcOptProfilingMode = toFlag True,+                     ghcOptHiSuffix      = toFlag "p_hi",+                     ghcOptObjSuffix     = toFlag "p_o",+                     ghcOptExtra         = ghcProfOptions libBi+                 }+      ghcArgs = if withVanillaLib lbi then vanillaArgs+           else if withSharedLib  lbi then sharedArgs+           else if withProfLib    lbi then profArgs+           else error "libAbiHash: Can't find an enabled library way"   --   (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)   getProgramInvocationOutput verbosity (ghcInvocation ghcProg ghcArgs)@@ -942,6 +1166,7 @@       ghcOptObjDir          = toFlag odir,       ghcOptHiDir           = toFlag odir,       ghcOptStubDir         = toFlag odir,+      ghcOptOutputDir       = toFlag odir,       ghcOptOptimisation    = toGhcOptimisation (withOptimization lbi),       ghcOptExtra           = hcOptions GHC bi,       ghcOptLanguage        = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),@@ -965,7 +1190,8 @@       ghcOptMode           = toFlag GhcModeCompile,       ghcOptInputFiles     = [filename], -      ghcOptCppIncludePath = odir : PD.includeDirs bi,+      ghcOptCppIncludePath = [autogenModulesDir lbi, odir]+                                   ++ PD.includeDirs bi,       ghcOptPackageDBs     = withPackageDB lbi,       ghcOptPackages       = componentPackageDeps clbi,       ghcOptCcOptions      = PD.ccOptions bi@@ -979,27 +1205,8 @@          | 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"+mkGHCiLibName :: LibraryName -> String+mkGHCiLibName (LibraryName lib) = lib <.> "o"  -- ----------------------------------------------------------------------------- -- Installing@@ -1013,7 +1220,8 @@            -> PackageDescription            -> Executable            -> IO ()-installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do+installExe verbosity lbi installDirs buildPref+  (progprefix, progsuffix) _pkg exe = do   let binDir = bindir installDirs   createDirectoryIfMissingVerbose verbosity True binDir   let exeFileName = exeName exe <.> exeExtension@@ -1050,8 +1258,9 @@               -> FilePath  -- ^Build location               -> PackageDescription               -> Library+              -> ComponentLocalBuildInfo               -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do+installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do   -- copy .hi files over:   let copyHelper installFun src dst n = do         createDirectoryIfMissingVerbose verbosity True dst@@ -1061,36 +1270,36 @@       copyModuleFiles ext =         findModuleFiles [builtDir] [ext] (libModules lib)           >>= installOrdinaryFiles verbosity targetDir-  ifVanilla $ copyModuleFiles "hi"-  ifProf    $ copyModuleFiles "p_hi"-  ifShared  $ copyModuleFiles "dyn_hi"+  whenVanilla $ copyModuleFiles "hi"+  whenProf    $ copyModuleFiles "p_hi"+  whenShared  $ 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+  whenVanilla $ mapM_ (copy builtDir targetDir)             vanillaLibNames+  whenProf    $ mapM_ (copy builtDir targetDir)             profileLibNames+  whenGHCi    $ mapM_ (copy builtDir targetDir)             ghciLibNames+  whenShared  $ mapM_ (copyShared builtDir dynlibTargetDir) sharedLibNames    -- run ranlib if necessary:-  ifVanilla $ updateLibArchive verbosity lbi-                               (targetDir </> vanillaLibName)-  ifProf    $ updateLibArchive verbosity lbi-                               (targetDir </> profileLibName)+  whenVanilla $ mapM_ (updateLibArchive verbosity lbi . (targetDir </>))+                      vanillaLibNames+  whenProf    $ mapM_ (updateLibArchive verbosity lbi . (targetDir </>))+                      profileLibNames    where-    vanillaLibName = mkLibName pkgid-    profileLibName = mkProfLibName pkgid-    ghciLibName    = mkGHCiLibName pkgid-    sharedLibName  = mkSharedLibName pkgid (compilerId (compiler lbi))--    pkgid          = packageId pkg+    cid = compilerId (compiler lbi)+    libNames = componentLibraries clbi+    vanillaLibNames = map mkLibName             libNames+    profileLibNames = map mkProfLibName         libNames+    ghciLibNames    = map mkGHCiLibName         libNames+    sharedLibNames  = map (mkSharedLibName cid) libNames      hasLib    = not $ null (libModules lib)                    && null (cSources (libBuildInfo lib))-    ifVanilla = when (hasLib && withVanillaLib lbi)-    ifProf    = when (hasLib && withProfLib    lbi)-    ifGHCi    = when (hasLib && withGHCiLib    lbi)-    ifShared  = when (hasLib && withSharedLib  lbi)+    whenVanilla = when (hasLib && withVanillaLib lbi)+    whenProf    = when (hasLib && withProfLib    lbi)+    whenGHCi    = when (hasLib && withGHCiLib    lbi)+    whenShared  = 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@@ -1104,10 +1313,24 @@     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++-- | Run 'ghc-pkg' using a given package DB stack, directly forwarding the+-- provided command-line arguments to it.+invokeHcPkg :: Verbosity -> ProgramConfiguration -> PackageDBStack -> [String]+               -> IO ()+invokeHcPkg verbosity conf dbStack extraArgs =+    HcPkg.invoke verbosity ghcPkgProg dbStack extraArgs+  where+    Just ghcPkgProg = lookupProgram ghcPkgProgram conf+ registerPackage   :: Verbosity   -> InstalledPackageInfo@@ -1119,3 +1342,20 @@ registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do   let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)   HcPkg.reregister verbosity ghcPkg packageDbs (Right installedPkgInfo)++-- -----------------------------------------------------------------------------+-- Utils++ghcDynamic :: Verbosity -> ConfiguredProgram -> IO Bool+ghcDynamic verbosity ghcProg+    = do xs <- getGhcInfo verbosity ghcProg+         return $ case lookup "GHC Dynamic" xs of+                  Just "YES" -> True+                  _          -> False++ghcSupportsDynamicToo :: Verbosity -> ConfiguredProgram -> IO Bool+ghcSupportsDynamicToo verbosity ghcProg+    = do xs <- getGhcInfo verbosity ghcProg+         return $ case lookup "Support dynamic-too" xs of+                  Just "YES" -> True+                  _          -> False
Distribution/Simple/Haddock.hs view
@@ -52,15 +52,20 @@  -- local import Distribution.Package-         ( PackageIdentifier, Package(..), packageName )+         ( PackageIdentifier(..)+         , Package(..)+         , PackageName(..), packageName ) import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD          ( PackageDescription(..), BuildInfo(..), allExtensions-         , Library(..), hasLibs, Executable(..) )+         , Library(..), hasLibs, Executable(..)+         , TestSuite(..), TestSuiteInterface(..)+         , Benchmark(..), BenchmarkInterface(..) ) import Distribution.Simple.Compiler          ( Compiler(..), compilerVersion ) import Distribution.Simple.GHC ( componentGhcOptions, ghcLibDir )-import Distribution.Simple.Program.GHC ( GhcOptions(..), renderGhcOptions )+import Distribution.Simple.Program.GHC+         ( GhcOptions(..), GhcDynLinkMode(..), renderGhcOptions ) import Distribution.Simple.Program          ( ConfiguredProgram(..), requireProgramVersion          , rawSystemProgram, rawSystemProgramStdout@@ -75,11 +80,10 @@ import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplateEnv, PathTemplate,                                         PathTemplateVariable(..),                                         toPathTemplate, fromPathTemplate,-                                        substPathTemplate,-                                        initialPathTemplateEnv)+                                        substPathTemplate, initialPathTemplateEnv) import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)-         , withComponentsLBI )+         , withAllComponentsInBuildOrder ) import Distribution.Simple.BuildPaths ( haddockName,                                         hscolourPref, autogenModulesDir,                                         )@@ -90,9 +94,11 @@ import Distribution.InstalledPackageInfo          ( InstalledPackageInfo ) import Distribution.Simple.Utils-         ( die, warn, notice, intercalate, setupMessage-         , createDirectoryIfMissingVerbose, withTempFile, copyFileVerbose-         , withTempDirectory+         ( die, copyFileTo, warn, notice, intercalate, setupMessage+         , createDirectoryIfMissingVerbose+         , TempFileOptions(..), defaultTempFileOptions+         , withTempFileEx, copyFileVerbose+         , withTempDirectoryEx, matchFileGlob          , findFileWithExtension, findFile ) import Distribution.Text          ( display, simpleParse )@@ -102,13 +108,13 @@ -- Base import System.Directory(removeFile, doesFileExist, createDirectoryIfMissing) -import Control.Monad ( when, guard )+import Control.Monad ( when, guard, forM_ ) import Control.Exception (assert) import Data.Monoid import Data.Maybe    ( fromMaybe, listToMaybe )  import System.FilePath((</>), (<.>), splitFileName, splitExtension,-                       normalise, splitPath, joinPath)+                       normalise, splitPath, joinPath, isAbsolute ) import System.IO (hClose, hPutStrLn) import Distribution.Version @@ -150,10 +156,13 @@ haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO () haddock pkg_descr _ _ haddockFlags   |    not (hasLibs pkg_descr)-    && not (fromFlag $ haddockExecutables haddockFlags) =+    && not (fromFlag $ haddockExecutables haddockFlags)+    && not (fromFlag $ haddockTestSuites  haddockFlags)+    && not (fromFlag $ haddockBenchmarks  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."+        ++ "a library. Perhaps you want to use the --executables, --tests or"+        ++ " --benchmarks flags."  haddock pkg_descr lbi suffixes flags = do @@ -201,35 +210,49 @@             , fromPackageDescription pkg_descr ]      let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes-    withComponentsLBI pkg_descr lbi $ \comp clbi -> do+    withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do       pre comp+      let+        doExe com = case (compToExe com) of+          Just exe -> do+            withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do+              let bi = buildInfo exe+              exeArgs  <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate+              exeArgs' <- prepareSources verbosity tmp+                            lbi isVersion2 bi (commonArgs `mappend` exeArgs)+              runHaddock verbosity tmpFileOpts confHaddock exeArgs'+          Nothing -> do+           warn (fromFlag $ haddockVerbosity flags)+             "Unsupported component, skipping..."+           return ()       case comp of         CLib lib -> do-          withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do+          withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do             let bi = libBuildInfo lib             libArgs  <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate             libArgs' <- prepareSources verbosity tmp                           lbi 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 ()+            runHaddock verbosity tmpFileOpts confHaddock libArgs'+        CExe   _ -> when (flag haddockExecutables) $ doExe comp+        CTest  _ -> when (flag haddockTestSuites)  $ doExe comp+        CBench _ -> when (flag haddockBenchmarks)  $ doExe comp++    forM_ (extraDocFiles pkg_descr) $ \ fpath -> do+      files <- matchFileGlob fpath+      forM_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)   where-    verbosity = flag haddockVerbosity-    flag f    = fromFlag $ f flags-    htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags+    verbosity     = flag haddockVerbosity+    keepTempFiles = flag haddockKeepTempFiles+    tmpFileOpts   = defaultTempFileOptions { optKeepTempFiles = keepTempFiles }+    flag f        = fromFlag $ f flags+    htmlTemplate  = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags  -- | performs cpp and unlit preprocessing where needed on the files in -- | argTargets, which must have an .hs or .lhs extension. prepareSources :: Verbosity                   -> FilePath                   -> LocalBuildInfo-                  -> Bool            -- haddock == 2.*+                  -> Bool            -- haddock >= 2.0                   -> BuildInfo                   -> HaddockArgs                   -> IO HaddockArgs@@ -277,7 +300,7 @@       argCssFile = haddockCss flags,       argContents = fmap (fromPathTemplate . substPathTemplate env) (haddockContents flags),       argVerbose = maybe mempty (Any . (>= deafening)) . flagToMaybe $ haddockVerbosity flags,-      argOutput = +      argOutput =           Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++                       [ Hoogle | Flag True <- [haddockHoogle flags] ]                  of [] -> [ Html ]@@ -308,17 +331,30 @@ fromLibrary verbosity tmp lbi lib clbi htmlTemplate = do     inFiles <- map snd `fmap` getLibSourceFiles lbi lib     ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate+    let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {+                          -- Noooooooooo!!!!!111+                          -- haddock stomps on our precious .hi+                          -- and .o files. Workaround by telling+                          -- haddock to write them elsewhere.+                          ghcOptObjDir  = toFlag tmp,+                          ghcOptHiDir   = toFlag tmp,+                          ghcOptStubDir = toFlag tmp+                      }+        sharedOpts = vanillaOpts {+                         ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                         ghcOptFPic        = toFlag True,+                         ghcOptHiSuffix    = toFlag "dyn_hi",+                         ghcOptObjSuffix   = toFlag "dyn_o",+                         ghcOptExtra       = ghcSharedOptions bi+                     }+    opts <- if withVanillaLib lbi+            then return vanillaOpts+            else if withSharedLib lbi+            then return sharedOpts+            else die "Must have vanilla or shared libraries enabled in order to run haddock"     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),+      argGhcOptions  = toFlag (opts, ghcVersion),       argTargets     = inFiles     }   where@@ -333,16 +369,29 @@ fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do     inFiles <- map snd `fmap` getExeSourceFiles lbi exe     ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate+    let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {+                          -- Noooooooooo!!!!!111+                          -- haddock stomps on our precious .hi+                          -- and .o files. Workaround by telling+                          -- haddock to write them elsewhere.+                          ghcOptObjDir  = toFlag tmp,+                          ghcOptHiDir   = toFlag tmp,+                          ghcOptStubDir = toFlag tmp+                      }+        sharedOpts = vanillaOpts {+                         ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                         ghcOptFPic        = toFlag True,+                         ghcOptHiSuffix    = toFlag "dyn_hi",+                         ghcOptObjSuffix   = toFlag "dyn_o",+                         ghcOptExtra       = ghcSharedOptions bi+                     }+    opts <- if withVanillaLib lbi+            then return vanillaOpts+            else if withSharedLib lbi+            then return sharedOpts+            else die "Must have vanilla or shared libraries enabled in order to run haddock"     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),+      argGhcOptions = toFlag (opts, ghcVersion),       argOutputDir  = Dir (exeName exe),       argTitle      = Flag (exeName exe),       argTargets    = inFiles@@ -351,6 +400,24 @@     bi = buildInfo exe     ghcVersion = compilerVersion (compiler lbi) +compToExe :: Component -> Maybe Executable+compToExe comp =+  case comp of+    CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } ->+      Just Executable {+        exeName    = testName test,+        modulePath = f,+        buildInfo  = testBuildInfo test+      }+    CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } ->+      Just Executable {+        exeName    = benchmarkName bench,+        modulePath = f,+        buildInfo  = benchmarkBuildInfo bench+      }+    CExe exe -> Just exe+    _ -> Nothing+ getInterfaces :: Verbosity               -> LocalBuildInfo               -> ComponentLocalBuildInfo@@ -376,11 +443,15 @@ ----------------------------------------------------------------------------------------------  -- | Call haddock with the specified arguments.-runHaddock :: Verbosity -> ConfiguredProgram -> HaddockArgs -> IO ()-runHaddock verbosity confHaddock args = do+runHaddock :: Verbosity+              -> TempFileOptions+              -> ConfiguredProgram+              -> HaddockArgs+              -> IO ()+runHaddock verbosity tmpFileOpts confHaddock args = do   let haddockVersion = fromMaybe (error "unable to determine haddock version")                        (programVersion confHaddock)-  renderArgs verbosity haddockVersion args $ \(flags,result)-> do+  renderArgs verbosity tmpFileOpts haddockVersion args $ \(flags,result)-> do        rawSystemProgram verbosity confHaddock flags @@ -388,18 +459,19 @@   renderArgs :: Verbosity+              -> TempFileOptions               -> Version               -> HaddockArgs               -> (([String], FilePath) -> IO a)               -> IO a-renderArgs verbosity version args k = do+renderArgs verbosity tmpFileOpts version args k = do   createDirectoryIfMissingVerbose verbosity True outputDir-  withTempFile outputDir "haddock-prolog.txt" $ \prologFileName h -> do+  withTempFileEx tmpFileOpts 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)+             let pflag = "--prologue=" ++ prologFileName+             k (pflag : renderPureArgs version args, result)     where       isVersion2 = version >= Version [2,0] []       outputDir = (unDir $ argOutputDir args)@@ -420,9 +492,9 @@     [      (:[]) . (\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,+     (\pname ->   if isVersion2+                  then ["--optghc=-package-name", "--optghc=" ++ pname]+                  else ["--package=" ++ pname]) . display . fromFlag . argPackageName $ args,      (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) . argHideModules $ args,      bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args,      maybe [] (\(m,e) -> ["--source-module=" ++ m@@ -442,13 +514,20 @@      argTargets $ args     ]     where-      renderInterfaces = map (\(i,mh) -> "--read-interface=" ++ maybe "" (++",") mh ++ i)+      renderInterfaces =+        map (\(i,mh) -> "--read-interface=" +++          maybe "" ((++",") . mkUrl) 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"+      -- See https://github.com/haskell/cabal/issues/1064+      mkUrl f =+        if isAbsolute f+          then "file://" ++ f+          else f  ----------------------------------------------------------------------------------------------------------- @@ -471,7 +550,9 @@           if exists             then return (Right (interface, html))             else return (Left (packageId ipkg))-    | ipkg <- PackageIndex.allPackages transitiveDeps ]+    | ipkg <- PackageIndex.allPackages transitiveDeps+    , pkgName (packageId ipkg) `notElem` noHaddockWhitelist+    ]    let missing = [ pkgid | Left pkgid <- interfaces ]       warning = "The documentation for the following packages are not "@@ -483,6 +564,7 @@   return (flags, if null missing then Nothing else Just warning)    where+    noHaddockWhitelist = map PackageName [ "rts" ]     interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (FilePath, FilePath)     interfaceAndHtmlPath pkg = do       interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)@@ -497,6 +579,7 @@ haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv haddockTemplateEnv lbi pkg_id = (PrefixVar, prefix (installDirTemplates lbi))                                 : initialPathTemplateEnv pkg_id (compilerId (compiler lbi))+                                  (hostPlatform lbi)  -- -------------------------------------------------------------------------- -- hscolour support@@ -527,16 +610,24 @@     createDirectoryIfMissingVerbose verbosity True $ hscolourPref distPref pkg_descr      let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes-    withComponentsLBI pkg_descr lbi $ \comp _ -> do+    withAllComponentsInBuildOrder pkg_descr lbi $ \comp _ -> do       pre comp+      let+        doExe com = case (compToExe com) of+          Just exe -> do+            let outputDir = hscolourPref distPref pkg_descr </> exeName exe </> "src"+            runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe+          Nothing -> do+           warn (fromFlag $ hscolourVerbosity flags)+             "Unsupported component, skipping..."+           return ()       case comp of         CLib lib -> do           let outputDir = hscolourPref distPref pkg_descr </> "src"           runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib-        CExe exe | fromFlag (hscolourExecutables flags) -> do-          let outputDir = hscolourPref distPref pkg_descr </> exeName exe </> "src"-          runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe-        _ -> return ()+        CExe   _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp+        CTest  _ -> when (fromFlag (hscolourTestSuites  flags)) $ doExe comp+        CBench _ -> when (fromFlag (hscolourBenchmarks  flags)) $ doExe comp   where     stylesheet = flagToMaybe (hscolourCSS flags) @@ -552,7 +643,7 @@                    | otherwise -> return ()            Just s -> copyFileVerbose verbosity s (outputDir </> "hscolour.css") -         flip mapM_ moduleFiles $ \(m, inFile) ->+         forM_ moduleFiles $ \(m, inFile) ->              rawSystemProgram verbosity prog                     ["-css", "-anchor", "-o" ++ outFile m, inFile]         where@@ -563,6 +654,8 @@     HscolourFlags {       hscolourCSS         = haddockHscolourCss flags,       hscolourExecutables = haddockExecutables flags,+      hscolourTestSuites  = haddockTestSuites  flags,+      hscolourBenchmarks  = haddockBenchmarks  flags,       hscolourVerbosity   = haddockVerbosity   flags,       hscolourDistPref    = haddockDistPref    flags     }
Distribution/Simple/Hpc.hs view
@@ -60,9 +60,13 @@     , testModules     ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )-import Distribution.Simple.Program ( hpcProgram, requireProgram )+import Distribution.Simple.Program+    ( hpcProgram+    , requireProgramVersion+    ) import Distribution.Simple.Program.Hpc ( markup, union ) import Distribution.Simple.Utils ( notice )+import Distribution.Version ( anyVersion ) import Distribution.Text import Distribution.Verbosity ( Verbosity() ) import System.Directory ( createDirectoryIfMissing, doesFileExist )@@ -138,14 +142,19 @@ 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 ])+        -- behaviour of 'markup' depends on version, so we need *a* version+        -- but no particular one+        (hpc, hpcVer, _) <- requireProgramVersion verbosity+            hpcProgram anyVersion (withPrograms lbi)+        markup hpc hpcVer verbosity+            (tixFilePath distPref $ testName suite) mixDirs+            (htmlDir distPref $ testName suite)+            (testModules suite ++ [ main ])         notice verbosity $ "Test coverage report written to "                             ++ htmlDir distPref (testName suite)                             </> "hpc_index" <.> "html"+  where+    mixDirs = map (mixDir distPref) [ testName suite, libName ]  -- | Generate the HTML markup for all of a package's test suites. markupPackage :: Verbosity@@ -158,13 +167,17 @@     let tixFiles = map (tixFilePath distPref . testName) suites     tixFilesExist <- mapM doesFileExist tixFiles     when (and tixFilesExist) $ do-        (hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi+        -- behaviour of 'markup' depends on version, so we need *a* version+        -- but no particular one+        (hpc, hpcVer, _) <- requireProgramVersion verbosity+            hpcProgram anyVersion (withPrograms lbi)         let outFile = tixFilePath distPref libName-            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+        markup hpc hpcVer verbosity outFile mixDirs htmlDir' excluded         notice verbosity $ "Package coverage report written to "                            ++ htmlDir' </> "hpc_index.html"+  where+    mixDirs = map (mixDir distPref) $ libName : map testName suites
Distribution/Simple/Hugs.hs view
@@ -118,12 +118,15 @@ import System.Exit          ( ExitCode(ExitSuccess) ) import Distribution.Compat.Exception+import Distribution.System ( Platform ) +import qualified Data.ByteString.Lazy.Char8 as BS.Char8+ -- ----------------------------------------------------------------------------- -- Configuring  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)+          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath _hcPkgPath conf = do    (_ffihugsProg, conf') <- requireProgram verbosity ffihugsProgram@@ -137,7 +140,8 @@         compilerLanguages      = hugsLanguages,         compilerExtensions     = hugsLanguageExtensions       }-  return (comp, conf'')+      compPlatform = Nothing+  return (comp, compPlatform, conf'')    where     hugsProgram' = hugsProgram { programFindVersion = getVersion }@@ -145,6 +149,7 @@ getVersion :: Verbosity -> FilePath -> IO (Maybe Version) getVersion verbosity hugsPath = do   (output, _err, exit) <- rawSystemStdInOut verbosity hugsPath []+                              Nothing Nothing                               (Just (":quit", False)) False   if exit == ExitSuccess     then return $! findVersion output@@ -597,7 +602,7 @@                              let args = hugsOptions ++ [targetName, "\"$@\""]                              in unlines ["#! /bin/sh",                                          unwords ("runhugs" : args)]-        writeFileAtomic exeFile script+        writeFileAtomic exeFile (BS.Char8.pack script)         setFileExecutable exeFile  hugsInstallSuffixes :: [String]
Distribution/Simple/Install.hs view
@@ -51,11 +51,12 @@ import Distribution.Package (Package(..)) import Distribution.Simple.LocalBuildInfo (         LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs,-        substPathTemplate)+        substPathTemplate, withLibLBI) import Distribution.Simple.BuildPaths (haddockName, haddockPref) import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, installDirectoryContents-         , installOrdinaryFile, die, info, notice, matchDirFileGlob )+         ( createDirectoryIfMissingVerbose+         , installDirectoryContents, installOrdinaryFile, isInSearchPath+         , die, info, notice, warn, matchDirFileGlob ) import Distribution.Simple.Compiler          ( CompilerFlavor(..), compilerFlavor ) import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..), fromFlag)@@ -143,19 +144,23 @@   let buildPref = buildDir lbi   when (hasLibs pkg_descr) $     notice verbosity ("Installing library in " ++ libPref)-  when (hasExes pkg_descr) $+  when (hasExes pkg_descr) $ do     notice verbosity ("Installing executable(s) in " ++ binPref)+    inPath <- isInSearchPath binPref+    when (not inPath) $+      warn verbosity ("The directory " ++ binPref+                      ++ " is not in the system search path.")    -- 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  -> do withLibLBI pkg_descr lbi $                   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  -> do withLibLBI pkg_descr lbi $                   LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr                 withExe pkg_descr $                   LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr@@ -167,13 +172,12 @@        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)+     NHC  -> do withLibLBI pkg_descr lbi $ NHC.installLib verbosity libPref buildPref (packageId pkg_descr)                 withExe pkg_descr $ NHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref)      UHC  -> do withLib pkg_descr $ UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr      _    -> 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
Distribution/Simple/InstallDirs.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp -fffi #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.InstallDirs@@ -77,14 +75,12 @@ 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 )+         ( OS(..), buildOS, Platform(..) ) import Distribution.Compiler          ( CompilerId, CompilerFlavor(..) ) import Distribution.Text@@ -120,7 +116,8 @@         docdir       :: dir,         mandir       :: dir,         htmldir      :: dir,-        haddockdir   :: dir+        haddockdir   :: dir,+        sysconfdir   :: dir     } deriving (Read, Show)  instance Functor InstallDirs where@@ -138,7 +135,8 @@     docdir       = f (docdir dirs),     mandir       = f (mandir dirs),     htmldir      = f (htmldir dirs),-    haddockdir   = f (haddockdir dirs)+    haddockdir   = f (haddockdir dirs),+    sysconfdir   = f (sysconfdir dirs)   }  instance Monoid dir => Monoid (InstallDirs dir) where@@ -156,7 +154,8 @@       docdir       = mempty,       mandir       = mempty,       htmldir      = mempty,-      haddockdir   = mempty+      haddockdir   = mempty,+      sysconfdir   = mempty   }   mappend = combineInstallDirs mappend @@ -178,7 +177,8 @@     docdir       = docdir a     `combine` docdir b,     mandir       = mandir a     `combine` mandir b,     htmldir      = htmldir a    `combine` htmldir b,-    haddockdir   = haddockdir a `combine` haddockdir b+    haddockdir   = haddockdir a `combine` haddockdir b,+    sysconfdir   = sysconfdir a `combine` sysconfdir b   }  appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a@@ -240,7 +240,7 @@            JHC    -> "$compiler"            LHC    -> "$compiler"            UHC    -> "$pkgid"-           _other -> "$pkgid" </> "$compiler",+           _other -> "$arch-$os-$compiler" </> "$pkgid",       dynlibdir    = "$libdir",       libexecdir   = case buildOS of         Windows   -> "$prefix" </> "$pkgid"@@ -250,11 +250,12 @@       datadir      = case buildOS of         Windows   -> "$prefix"         _other    -> "$prefix" </> "share",-      datasubdir   = "$pkgid",-      docdir       = "$datadir" </> "doc" </> "$pkgid",+      datasubdir   = "$arch-$os-$compiler" </> "$pkgid",+      docdir       = "$datadir" </> "doc" </> "$arch-$os-$compiler" </> "$pkgid",       mandir       = "$datadir" </> "man",       htmldir      = "$docdir"  </> "html",-      haddockdir   = "$htmldir"+      haddockdir   = "$htmldir",+      sysconfdir   = "$prefix" </> "etc"   }  -- ---------------------------------------------------------------------------@@ -292,7 +293,8 @@       mandir     = subst mandir     (prefixBinLibDataVars ++ [docdirVar]),       htmldir    = subst htmldir    (prefixBinLibDataVars ++ [docdirVar]),       haddockdir = subst haddockdir (prefixBinLibDataVars ++-                                      [docdirVar, htmldirVar])+                                      [docdirVar, htmldirVar]),+      sysconfdir = subst sysconfdir prefixBinLibVars     }     subst dir env' = substPathTemplate (env'++env) (dir dirs) @@ -310,10 +312,10 @@ -- | 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+absoluteInstallDirs :: PackageIdentifier -> CompilerId -> CopyDest -> Platform                     -> InstallDirs PathTemplate                     -> InstallDirs FilePath-absoluteInstallDirs pkgId compilerId copydest dirs =+absoluteInstallDirs pkgId compilerId copydest platform dirs =     (case copydest of        CopyTo destdir -> fmap ((destdir </>) . dropDrive)        _              -> id)@@ -321,7 +323,7 @@   . fmap fromPathTemplate   $ substituteInstallDirTemplates env dirs   where-    env = initialPathTemplateEnv pkgId compilerId+    env = initialPathTemplateEnv pkgId compilerId platform   -- |The location prefix for the /copy/ command.@@ -336,10 +338,10 @@ -- prevents us from making a relocatable package (also known as a \"prefix -- independent\" package). ---prefixRelativeInstallDirs :: PackageIdentifier -> CompilerId+prefixRelativeInstallDirs :: PackageIdentifier -> CompilerId -> Platform                           -> InstallDirTemplates                           -> InstallDirs (Maybe FilePath)-prefixRelativeInstallDirs pkgId compilerId dirs =+prefixRelativeInstallDirs pkgId compilerId platform dirs =     fmap relative   . appendSubdirs combinePathTemplate   $ -- substitute the path template into each other, except that we map@@ -349,7 +351,7 @@       prefix = PathTemplate [Variable PrefixVar]     }   where-    env = initialPathTemplateEnv pkgId compilerId+    env = initialPathTemplateEnv pkgId compilerId platform      -- If it starts with $prefix then it's relative and produce the relative     -- path by stripping off $prefix/ or $prefix@@ -390,7 +392,8 @@      | 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@.+     | TestSuiteResultVar -- ^ The result of the test suite being run, eg+                          -- @pass@, @fail@, or @error@.      | BenchmarkNameVar   -- ^ The name of the benchmark being run   deriving Eq @@ -421,12 +424,12 @@                   Nothing                        -> [component]  -- | The initial environment has all the static stuff but no paths-initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> PathTemplateEnv-initialPathTemplateEnv pkgId compilerId =+initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> Platform+                       -> PathTemplateEnv+initialPathTemplateEnv pkgId compilerId platform =      packageTemplateEnv  pkgId   ++ compilerTemplateEnv compilerId-  ++ platformTemplateEnv buildPlatform -- platform should be param if we want-                                       -- to do cross-platform configuation+  ++ platformTemplateEnv platform  packageTemplateEnv :: PackageIdentifier -> PathTemplateEnv packageTemplateEnv pkgId =@@ -561,9 +564,6 @@ #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)@@ -571,7 +571,6 @@         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@@ -585,20 +584,4 @@                               -> 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
Distribution/Simple/JHC.hs view
@@ -84,17 +84,20 @@          ( Text(parse), display ) import Distribution.Compat.ReadP     ( readP_to_S, string, skipSpaces )+import Distribution.System ( Platform )  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)+          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath _hcPkgPath conf = do    (jhcProg, _, conf') <- requireProgramVersion verbosity@@ -107,7 +110,8 @@         compilerLanguages      = jhcLanguages,         compilerExtensions     = jhcLanguageExtensions       }-  return (comp, conf')+      compPlatform = Nothing+  return (comp, compPlatform, conf')  jhcLanguages :: [(Language, Flag)] jhcLanguages = [(Haskell98, "")]@@ -161,7 +165,7 @@   let pkgid = display (packageId pkg_descr)       pfile = buildDir lbi </> "jhc-pkg.conf"       hlfile= buildDir lbi </> (pkgid ++ ".hl")-  writeFileAtomic pfile $ jhcPkgConf pkg_descr+  writeFileAtomic pfile . BS.Char8.pack $ jhcPkgConf pkg_descr   rawSystemProgram verbosity jhcProg $      ["--build-hl="++pfile, "-o", hlfile] ++      args ++ map display (libModules lib)@@ -218,4 +222,3 @@         out   = (progprefix ++ exe_name ++ progsuffix) </> exeExtension     createDirectoryIfMissingVerbose verb True dest     installExecutableFile verb (build_dir </> src) (dest </> out)-
Distribution/Simple/LHC.hs view
@@ -81,16 +81,18 @@ import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.ParseUtils  ( ParseResult(..) ) import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) )+         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..),+           LibraryName(..) ) import Distribution.Simple.InstallDirs import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package-         ( PackageIdentifier, Package(..) )+         ( Package(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg-         , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf+         ( Program(..), ConfiguredProgram(..), ProgramConfiguration+         , ProgramSearchPath, ProgramLocation(..)+         , rawSystemProgram, rawSystemProgramConf          , rawSystemProgramStdout, rawSystemProgramStdoutConf          , requireProgramVersion          , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram@@ -123,12 +125,13 @@                                   takeDirectory, replaceExtension ) import System.IO (hClose, hPutStrLn) import Distribution.Compat.Exception (catchExit, catchIO)+import Distribution.System ( Platform )  -- ----------------------------------------------------------------------------- -- Configuring  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)+          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath hcPkgPath conf = do    (lhcProg, lhcVersion, conf') <-@@ -155,7 +158,8 @@         compilerExtensions     = extensions       }       conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld-  return (comp, conf''')+      compPlatform = Nothing+  return (comp, compPlatform, conf''')  -- | Adjust the way we find and configure gcc and ld --@@ -178,32 +182,36 @@     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+    findProg :: Program -> FilePath+             -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+    findProg prog location | isWindows = \verbosity searchpath -> 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+                          programFindLocation prog verbosity searchpath       | otherwise = programFindLocation prog -    configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+    configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram     configureGcc       | isWindows = \_ gccProg -> case programLocation gccProg of           -- if it's found on system then it means we're using the result           -- of programFindLocation above rather than a user-supplied path           -- 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 []+          FoundOnSystem {} -> return gccProg {+                                programDefaultArgs = ["-B" ++ libDir,+                                                      "-I" ++ includeDir]+                              }+          UserSpecified {} -> return gccProg+      | otherwise = \_ gccProg -> return gccProg      -- we need to find out if ld supports the -x flag-    configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+    configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram     configureLd verbosity ldProg = do       tempDir <- getTemporaryDirectory       ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->              withTempFile tempDir ".o" $ \testofile testohnd -> do-               hPutStrLn testchnd "int foo() {}"+               hPutStrLn testchnd "int foo() { return 0; }"                hClose testchnd; hClose testohnd                rawSystemProgram verbosity lhcProg ["-c", testcfile,                                                    "-o", testofile]@@ -216,8 +224,8 @@                  `catchIO`   (\_ -> return False)                  `catchExit` (\_ -> return False)       if ldx-        then return ["-x"]-        else return []+        then return ldProg { programDefaultArgs = ["-x"] }+        else return ldProg  getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)] getLanguages _ _ = return [(Haskell98, "")]@@ -332,6 +340,11 @@ buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo                       -> Library            -> ComponentLocalBuildInfo -> IO () buildLib verbosity pkg_descr lbi lib clbi = do+  libName <- case componentLibraries clbi of+             [libName] -> return libName+             [] -> die "No library name found when building library"+             _  -> die "Multiple library names found when building library"+   let pref = buildDir lbi       pkgid = packageId pkg_descr       runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)@@ -385,11 +398,11 @@   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+      cid = compilerId (compiler lbi)+      vanillaLibFilePath = libTargetDir </> mkLibName           libName+      profileLibFilePath = libTargetDir </> mkProfLibName       libName+      sharedLibFilePath  = libTargetDir </> mkSharedLibName cid libName+      ghciLibFilePath    = libTargetDir </> mkGHCiLibName       libName    stubObjs <- fmap catMaybes $ sequence     [ findFileWithExtension [objExtension] [libTargetDir]@@ -695,8 +708,8 @@            _              -> ["-optc-O2"])      ++ ["-odir", odir] -mkGHCiLibName :: PackageIdentifier -> String-mkGHCiLibName lib = "HS" ++ display lib <.> "o"+mkGHCiLibName :: LibraryName -> String+mkGHCiLibName (LibraryName lib) = lib <.> "o"  -- ----------------------------------------------------------------------------- -- Installing@@ -747,8 +760,9 @@               -> FilePath  -- ^Build location               -> PackageDescription               -> Library+              -> ComponentLocalBuildInfo               -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do+installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do   -- copy .hi files over:   let copy src dst n = do         createDirectoryIfMissingVerbose verbosity True dst@@ -762,24 +776,24 @@   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+  ifVanilla $ mapM_ (copy builtDir targetDir)       vanillaLibNames+  ifProf    $ mapM_ (copy builtDir targetDir)       profileLibNames+  ifGHCi    $ mapM_ (copy builtDir targetDir)       ghciLibNames+  ifShared  $ mapM_ (copy builtDir dynlibTargetDir) sharedLibNames    -- run ranlib if necessary:-  ifVanilla $ updateLibArchive verbosity lbi-                               (targetDir </> vanillaLibName)-  ifProf    $ updateLibArchive verbosity lbi-                               (targetDir </> profileLibName)+  ifVanilla $ mapM_ (updateLibArchive verbosity lbi . (targetDir </>))+                    vanillaLibNames+  ifProf    $ mapM_ (updateLibArchive verbosity lbi . (targetDir </>))+                    profileLibNames    where-    vanillaLibName = mkLibName pkgid-    profileLibName = mkProfLibName pkgid-    ghciLibName    = mkGHCiLibName pkgid-    sharedLibName  = mkSharedLibName pkgid (compilerId (compiler lbi))--    pkgid          = packageId pkg+    cid = compilerId (compiler lbi)+    libNames = componentLibraries clbi+    vanillaLibNames = map mkLibName             libNames+    profileLibNames = map mkProfLibName         libNames+    ghciLibNames    = map mkGHCiLibName         libNames+    sharedLibNames  = map (mkSharedLibName cid) libNames      hasLib    = not $ null (libModules lib)                    && null (cSources (libBuildInfo lib))
Distribution/Simple/LocalBuildInfo.hs view
@@ -51,11 +51,27 @@          -- * Buildable package components         Component(..),-        foldComponent,-        componentBuildInfo,-        allComponentsBy,         ComponentName(..),+        showComponentName,         ComponentLocalBuildInfo(..),+        LibraryName(..),+        foldComponent,+        componentName,+        componentBuildInfo,+        componentEnabled,+        componentDisabledReason,+        ComponentDisabledReason(..),+        pkgComponents,+        pkgEnabledComponents,+        lookupComponent,+        getComponent,+        getComponentLocalBuildInfo,+        allComponentsInBuildOrder,+        componentsInBuildOrder,+        checkComponentsCyclic,++        withAllComponentsInBuildOrder,+        withComponentsInBuildOrder,         withComponentsLBI,         withLibLBI,         withExeLBI,@@ -83,14 +99,17 @@          ( Compiler(..), PackageDBStack, OptimisationLevel ) import Distribution.Simple.PackageIndex          ( PackageIndex )-import Distribution.Simple.Utils-         ( die ) import Distribution.Simple.Setup          ( ConfigFlags ) import Distribution.Text          ( display )-+import Distribution.System+          ( Platform ) import Data.List (nub, find)+import Data.Graph+import Data.Tree  (flatten)+import Data.Array ((!))+import Data.Maybe  -- | Data cached after configuration step.  See also -- 'Distribution.Simple.Setup.ConfigFlags'.@@ -107,18 +126,16 @@         --TODO: inplaceDirTemplates :: InstallDirs FilePath         compiler      :: Compiler,                 -- ^ The compiler we're building with+        hostPlatform  :: Platform,+                -- ^ The platform we're building for         buildDir      :: FilePath,                 -- ^ Where to build the package.         --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+        componentsConfigs   :: [(ComponentName, ComponentLocalBuildInfo, [ComponentName])],+                -- ^ All the components to build, ordered by topological sort, and with their dependencies                 -- 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).@@ -145,12 +162,12 @@ -- | 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)+externalPackageDeps lbi =+    -- TODO:  what about non-buildable components?+    nub [ (ipkgid, pkgid)+        | (_,clbi,_)      <- componentsConfigs lbi+        , (ipkgid, pkgid) <- componentPackageDeps clbi+        , not (internal pkgid) ]   where     -- True if this dependency is an internal one (depends on the library     -- defined in the same package).@@ -175,15 +192,32 @@                    | CExeName   String                    | CTestName  String                    | CBenchName String-                   deriving (Show, Eq, Read)+                   deriving (Show, Eq, Ord, Read) -data ComponentLocalBuildInfo = ComponentLocalBuildInfo {+showComponentName :: ComponentName -> String+showComponentName CLibName          = "library"+showComponentName (CExeName   name) = "executable '" ++ name ++ "'"+showComponentName (CTestName  name) = "test suite '" ++ name ++ "'"+showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'"++data ComponentLocalBuildInfo+  = LibComponentLocalBuildInfo {     -- | 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)],+    componentLibraries :: [LibraryName]+  }+  | ExeComponentLocalBuildInfo {     componentPackageDeps :: [(InstalledPackageId, PackageId)]   }+  | TestComponentLocalBuildInfo {+    componentPackageDeps :: [(InstalledPackageId, PackageId)]+  }+  | BenchComponentLocalBuildInfo {+    componentPackageDeps :: [(InstalledPackageId, PackageId)]+  }   deriving (Read, Show)  foldComponent :: (Library -> a)@@ -197,113 +231,180 @@ foldComponent _ _ f _ (CTest  tst) = f tst foldComponent _ _ _ f (CBench bch) = f bch +data LibraryName = LibraryName String+    deriving (Read, Show)+ componentBuildInfo :: Component -> BuildInfo componentBuildInfo =   foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo --- | 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 ]+componentName :: Component -> ComponentName+componentName =+  foldComponent (const CLibName)+                (CExeName . exeName)+                (CTestName . testName)+                (CBenchName . benchmarkName) +-- | All the components in the package (libs, exes, or test suites).+--+pkgComponents :: PackageDescription -> [Component]+pkgComponents pkg =+    [ CLib  lib | Just lib <- [library pkg] ]+ ++ [ CExe  exe | exe <- executables pkg ]+ ++ [ CTest tst | tst <- testSuites  pkg ]+ ++ [ CBench bm | bm  <- benchmarks  pkg ]++-- | All the components in the package that are buildable and enabled.+-- Thus this excludes non-buildable components and test suites or benchmarks+-- that have been disabled.+--+pkgEnabledComponents :: PackageDescription -> [Component]+pkgEnabledComponents = filter componentEnabled . pkgComponents++componentEnabled :: Component -> Bool+componentEnabled = isNothing . componentDisabledReason++data ComponentDisabledReason = DisabledComponent+                             | DisabledAllTests+                             | DisabledAllBenchmarks++componentDisabledReason :: Component -> Maybe ComponentDisabledReason+componentDisabledReason (CLib  lib)+  | not (buildable (libBuildInfo lib))      = Just DisabledComponent+componentDisabledReason (CExe  exe)+  | not (buildable (buildInfo exe))         = Just DisabledComponent+componentDisabledReason (CTest tst)+  | not (buildable (testBuildInfo tst))     = Just DisabledComponent+  | not (testEnabled tst)                   = Just DisabledAllTests+componentDisabledReason (CBench bm)+  | not (buildable (benchmarkBuildInfo bm)) = Just DisabledComponent+  | not (benchmarkEnabled bm)               = Just DisabledAllBenchmarks+componentDisabledReason _                   = Nothing++lookupComponent :: PackageDescription -> ComponentName -> Maybe Component+lookupComponent pkg CLibName =+    fmap CLib $ library pkg+lookupComponent pkg (CExeName name) =+    fmap CExe $ find ((name ==) . exeName) (executables pkg)+lookupComponent pkg (CTestName name) =+    fmap CTest $ find ((name ==) . testName) (testSuites pkg)+lookupComponent pkg (CBenchName name) =+    fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg)++getComponent :: PackageDescription -> ComponentName -> Component+getComponent pkg cname =+    case lookupComponent pkg cname of+      Just cpnt -> cpnt+      Nothing   -> missingComponent+  where+    missingComponent =+      error $ "internal error: the package description contains no "+           ++ "component corresponding to " ++ show cname+++getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo+getComponentLocalBuildInfo lbi cname =+    case [ clbi+         | (cname', clbi, _) <- componentsConfigs lbi+         , cname == cname' ] of+      [clbi] -> clbi+      _      -> missingComponent+  where+    missingComponent =+      error $ "internal error: there is no configuration data "+           ++ "for component " ++ show cname++ -- |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+withLibLBI pkg_descr lbi f =+    withLib pkg_descr $ \lib ->+      f lib (getComponentLocalBuildInfo lbi CLibName)  -- | 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))+withExeLBI pkg_descr lbi f =+    withExe pkg_descr $ \exe ->+      f exe (getComponentLocalBuildInfo lbi (CExeName (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))+withTestLBI pkg_descr lbi f =+    withTest pkg_descr $ \test ->+      f test (getComponentLocalBuildInfo lbi (CTestName (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'+{-# DEPRECATED withComponentsLBI "Use withAllComponentsInBuildOrder" #-} withComponentsLBI :: PackageDescription -> LocalBuildInfo                   -> (Component -> ComponentLocalBuildInfo -> IO ())                   -> IO ()-withComponentsLBI pkg_descr lbi f = mapM_ compF (compBuildOrder lbi)+withComponentsLBI = withAllComponentsInBuildOrder++-- | 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'+withAllComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo+                              -> (Component -> ComponentLocalBuildInfo -> IO ())+                              -> IO ()+withAllComponentsInBuildOrder pkg lbi f =+    sequence_+      [ f (getComponent pkg cname) clbi+      | (cname, clbi) <- allComponentsInBuildOrder lbi ]++withComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo+                                  -> [ComponentName]+                                  -> (Component -> ComponentLocalBuildInfo -> IO ())+                                  -> IO ()+withComponentsInBuildOrder pkg lbi cnames f =+    sequence_+      [ f (getComponent pkg cname') clbi+      | (cname', clbi) <- componentsInBuildOrder lbi cnames ]++allComponentsInBuildOrder :: LocalBuildInfo+                          -> [(ComponentName, ComponentLocalBuildInfo)]+allComponentsInBuildOrder lbi =+    componentsInBuildOrder lbi+      [ cname | (cname, _, _) <- componentsConfigs lbi ]++componentsInBuildOrder :: LocalBuildInfo -> [ComponentName]+                       -> [(ComponentName, ComponentLocalBuildInfo)]+componentsInBuildOrder lbi cnames =+      map ((\(clbi,cname,_) -> (cname,clbi)) . vertexToNode)+    . postOrder graph+    . map (\cname -> fromMaybe (noSuchComp cname) (keyToVertex cname))+    $ cnames   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"+    (graph, vertexToNode, keyToVertex) =+      graphFromEdges (map (\(a,b,c) -> (b,a,c)) (componentsConfigs lbi)) -    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."+    noSuchComp cname = error $ "internal error: componentsInBuildOrder: "+                            ++ "no such component: " ++ show cname -    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."+    postOrder :: Graph -> [Vertex] -> [Vertex]+    postOrder g vs = postorderF (dfs g vs) [] -    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."+    postorderF   :: Forest a -> [a] -> [a]+    postorderF ts = foldr (.) id $ map postorderT ts -missingLibConf :: String-missingExeConf, missingTestConf, missingBenchConf :: String -> String+    postorderT :: Tree a -> [a] -> [a]+    postorderT (Node a ts) = postorderF ts . (a :) -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"+checkComponentsCyclic :: Ord key => [(node, key, [key])]+                      -> Maybe [(node, key, [key])]+checkComponentsCyclic es =+    let (graph, vertexToNode, _) = graphFromEdges es+        cycles                   = [ flatten c | c <- scc graph, isCycle c ]+        isCycle (Node v [])      = selfCyclic v+        isCycle _                = True+        selfCyclic v             = v `elem` graph ! v+     in case cycles of+         []    -> Nothing+         (c:_) -> Just (map vertexToNode c)   -- -----------------------------------------------------------------------------@@ -317,6 +418,7 @@     (packageId pkg)     (compilerId (compiler lbi))     copydest+    (hostPlatform lbi)     (installDirTemplates lbi)  -- |See 'InstallDirs.prefixRelativeInstallDirs'@@ -326,6 +428,7 @@   InstallDirs.prefixRelativeInstallDirs     (packageId pkg_descr)     (compilerId (compiler lbi))+    (hostPlatform lbi)     (installDirTemplates lbi)  substPathTemplate :: PackageId -> LocalBuildInfo@@ -335,3 +438,4 @@     where env = initialPathTemplateEnv                    pkgid                    (compilerId (compiler lbi))+                   (hostPlatform lbi)
Distribution/Simple/NHC.hs view
@@ -52,7 +52,7 @@  import Distribution.Package          ( PackageName, PackageIdentifier(..), InstalledPackageId(..)-         , packageId, packageName )+         , packageName ) import Distribution.InstalledPackageInfo          ( InstalledPackageInfo          , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId@@ -104,12 +104,13 @@ import Data.Monoid   ( Monoid(..) ) import Control.Monad ( when, unless ) import Distribution.Compat.Exception+import Distribution.System ( Platform )  -- ----------------------------------------------------------------------------- -- Configuring  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)+          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath _hcPkgPath conf = do    (_nhcProg, nhcVersion, conf') <-@@ -134,7 +135,8 @@         compilerLanguages  = nhcLanguages,         compilerExtensions     = nhcLanguageExtensions       }-  return (comp, conf'''')+      compPlatform = Nothing+  return (comp, compPlatform,  conf'''')  nhcLanguages :: [(Language, Flag)] nhcLanguages = [(Haskell98, "-98")]@@ -285,6 +287,10 @@ buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo                       -> Library            -> ComponentLocalBuildInfo -> IO () buildLib verbosity pkg_descr lbi lib clbi = do+  libName <- case componentLibraries clbi of+             [libName] -> return libName+             [] -> die "No library name found when building library"+             _  -> die "Multiple library names found when building library"   let conf = withPrograms lbi       Just nhcProg = lookupProgram nhcProgram conf   let bi = libBuildInfo lib@@ -325,7 +331,7 @@   info verbosity "Linking..."   let --cObjs = [ targetDir </> cFile `replaceExtension` objExtension       --        | cFile <- cSources bi ]-      libFilePath = targetDir </> mkLibName (packageId pkg_descr)+      libFilePath = targetDir </> mkLibName libName       hObjs = [ targetDir </> ModuleName.toFilePath m <.> objExtension               | m <- modules ] @@ -414,11 +420,15 @@               -> FilePath  -- ^Build location               -> PackageIdentifier               -> Library+              -> ComponentLocalBuildInfo               -> IO ()-installLib verbosity pref buildPref pkgid lib+installLib verbosity pref buildPref _pkgid lib clbi     = do let bi = libBuildInfo lib              modules = exposedModules lib ++ otherModules bi          findModuleFiles [buildPref] ["hi"] modules            >>= installOrdinaryFiles verbosity pref-         let libName = mkLibName pkgid-         installOrdinaryFile verbosity (buildPref </> libName) (pref </> libName)+         let libNames = map mkLibName (componentLibraries clbi)+             installLib' libName = installOrdinaryFile verbosity+                                                       (buildPref </> libName)+                                                       (pref </> libName)+         mapM_ installLib' libNames
Distribution/Simple/PreProcess.hs view
@@ -51,7 +51,7 @@                                 ppSuffixes, PPSuffixHandler, PreProcessor(..),                                 mkSimplePreProcessor, runSimplePreProcessor,                                 ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs,-                                ppHappy, ppAlex, ppUnlit+                                ppHappy, ppAlex, ppUnlit, platformDefines                                )     where @@ -71,14 +71,16 @@ import qualified Distribution.InstalledPackageInfo as Installed          ( InstalledPackageInfo_(..) ) import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.CCompiler+         ( cSourceExtensions ) import Distribution.Simple.Compiler-         ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion )+         ( CompilerFlavor(..), 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+         , die, setupMessage, intercalate, copyFileVerbose, moreRecentFile          , findFileWithExtension, findFileWithExtension' ) import Distribution.Simple.Program          ( Program(..), ConfiguredProgram(..), programPath@@ -88,7 +90,7 @@          , happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram ) import Distribution.Simple.Test ( writeSimpleTestStub, stubFilePath, stubName ) import Distribution.System-         ( OS(OSX, Windows), buildOS )+         ( OS(..), buildOS, Arch(..), Platform(..) ) import Distribution.Text import Distribution.Version          ( Version(..), anyVersion, orLaterVersion )@@ -96,7 +98,7 @@  import Data.Maybe (fromMaybe) import Data.List (nub)-import System.Directory (getModificationTime, doesFileExist)+import System.Directory (doesFileExist) import System.Info (os, arch) import System.FilePath (splitExtension, dropExtensions, (</>), (<.>),                         takeDirectory, normalise, replaceExtension)@@ -219,9 +221,11 @@       BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark "                                  ++ "type " ++ display tt   where-    builtinSuffixes+    builtinHaskellSuffixes       | NHC == compilerFlavor (compiler lbi) = ["hs", "lhs", "gc"]       | otherwise                            = ["hs", "lhs"]+    builtinCSuffixes = cSourceExtensions+    builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes     localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers]     pre dirs dir lhndlrs fp =       preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs@@ -232,7 +236,7 @@     preProcessComponent bi modules exePath dir = do         let biHandlers = localHandlers bi             sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ]-        sequence_ [ preprocessFile sourceDirs (buildDir lbi) isSrcDist+        sequence_ [ preprocessFile sourceDirs dir isSrcDist                 (ModuleName.toFilePath modu) verbosity builtinSuffixes                 biHandlers                 | modu <- modules ]@@ -294,10 +298,8 @@               ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile               recomp <- case ppsrcFiles of                           Nothing -> return True-                          Just ppsrcFile -> do-                              btime <- getModificationTime ppsrcFile-                              ptime <- getModificationTime psrcFile-                              return (btime < ptime)+                          Just ppsrcFile ->+                              psrcFile `moreRecentFile` ppsrcFile               when recomp $ do                 let destDir = buildLoc </> dirName srcStem                 createDirectoryIfMissingVerbose verbosity True destDir@@ -445,8 +447,7 @@           -- 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 ]+       ++ [ "--cflag="   ++ opt | opt <- platformDefines lbi ]            -- Options from the current package:        ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs  bi ]@@ -530,43 +531,74 @@ --TODO: remove cc-options from cpphs for cabal-version: >= 1.10 getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] getCppOptions bi lbi-    = hcDefines (compiler lbi)-   ++ sysDefines+    = platformDefines lbi    ++ 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 =+platformDefines :: LocalBuildInfo -> [String]+platformDefines lbi =   case compilerFlavor comp of-    GHC  -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version]+    GHC  ->+        let ghcOS = case hostOS of+                    Linux     -> ["linux"]+                    Windows   -> ["mingw32"]+                    OSX       -> ["darwin"]+                    FreeBSD   -> ["freebsd"]+                    OpenBSD   -> ["openbsd"]+                    NetBSD    -> ["netbsd"]+                    Solaris   -> ["solaris2"]+                    AIX       -> ["aix"]+                    HPUX      -> ["hpux"]+                    IRIX      -> ["irix"]+                    HaLVM     -> []+                    IOS       -> ["ios"]+                    OtherOS _ -> []+            ghcArch = case hostArch 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] +++           ["-D" ++ os   ++ "_BUILD_OS=1"] +++           ["-D" ++ arch ++ "_BUILD_ARCH=1"] +++           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+  where+    comp = compiler lbi+    Platform hostArch hostOS = hostPlatform lbi+    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 }
Distribution/Simple/Program.hs view
@@ -35,6 +35,8 @@ module Distribution.Simple.Program (     -- * Program and functions for constructing them       Program(..)+    , ProgramSearchPath+    , ProgramSearchPathEntry(..)     , simpleProgram     , findProgramLocation     , findProgramVersion@@ -46,6 +48,7 @@     , ProgramLocation(..)     , runProgram     , getProgramOutput+    , suppressOverrideArgs      -- * Program invocations     , ProgramInvocation(..)@@ -67,6 +70,8 @@     , addKnownPrograms     , lookupKnownProgram     , knownPrograms+    , getProgramSearchPath+    , setProgramSearchPath     , userSpecifyPath     , userSpecifyPaths     , userMaybeSpecifyPath
Distribution/Simple/Program/Builtin.hs view
@@ -47,8 +47,10 @@  import Distribution.Simple.Program.Types          ( Program(..), simpleProgram )+import Distribution.Simple.Program.Find+         ( findProgramOnSearchPath ) import Distribution.Simple.Utils-         ( findProgramLocation, findProgramVersion )+         ( findProgramVersion )  -- ------------------------------------------------------------ -- * Known programs@@ -233,7 +235,7 @@  hscolourProgram :: Program hscolourProgram = (simpleProgram "hscolour") {-    programFindLocation = \v -> findProgramLocation v "HsColour",+    programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour",     programFindVersion  = findProgramVersion "-version" $ \str ->       -- Invoking "HsColour -version" gives a string like "HsColour 1.7"       case words str of
Distribution/Simple/Program/Db.hs view
@@ -32,6 +32,8 @@     addKnownPrograms,     lookupKnownProgram,     knownPrograms,+    getProgramSearchPath,+    setProgramSearchPath,     userSpecifyPath,     userSpecifyPaths,     userMaybeSpecifyPath,@@ -52,10 +54,13 @@  import Distribution.Simple.Program.Types          ( Program(..), ProgArg, ConfiguredProgram(..), ProgramLocation(..) )+import Distribution.Simple.Program.Find+         ( ProgramSearchPath, defaultProgramSearchPath+         , findProgramOnSearchPath, programSearchPathAsPATHVar ) import Distribution.Simple.Program.Builtin          ( builtinPrograms ) import Distribution.Simple.Utils-         ( die, findProgramLocation )+         ( die ) import Distribution.Version          ( Version, VersionRange, isAnyVersion, withinRange ) import Distribution.Text@@ -88,6 +93,7 @@ -- 'Program' but also any user-provided arguments and location for the program. data ProgramDb = ProgramDb {         unconfiguredProgs :: UnconfiguredProgs,+        progSearchPath    :: ProgramSearchPath,         configuredProgs   :: ConfiguredProgs     } @@ -97,8 +103,7 @@   emptyProgramDb :: ProgramDb-emptyProgramDb = ProgramDb Map.empty Map.empty-+emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty  defaultProgramDb :: ProgramDb defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb@@ -166,7 +171,22 @@   [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf)            , let p' = Map.lookup (programName p) (configuredProgs conf) ] +-- | Get the current 'ProgramSearchPath' used by the 'ProgramDb'.+-- This is the default list of locations where programs are looked for when+-- configuring them. This can be overriden for specific programs (with+-- 'userSpecifyPath'), and specific known programs can modify or ignore this+-- search path in their own configuration code.+--+getProgramSearchPath :: ProgramDb -> ProgramSearchPath+getProgramSearchPath = progSearchPath +-- | Change the current 'ProgramSearchPath' used by the 'ProgramDb'.+-- This will affect programs that are configured from here on, so you+-- should usually set it before configuring any programs.+--+setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb+setProgramSearchPath searchpath db = db { progSearchPath = searchpath }+ -- |User-specify this path.  Basically override any path information -- for this program in the configuration. If it's not a known -- program ignore it.@@ -272,13 +292,13 @@ configureProgram verbosity prog conf = do   let name = programName prog   maybeLocation <- case userSpecifiedPath prog conf of-    Nothing   -> programFindLocation prog verbosity+    Nothing   -> programFindLocation prog verbosity (progSearchPath conf)              >>= return . fmap FoundOnSystem     Just path -> do       absolute <- doesFileExist path       if absolute         then return (Just (UserSpecified path))-        else findProgramLocation verbosity path+        else findProgramOnSearchPath verbosity (progSearchPath conf) path          >>= maybe (die notFound) (return . Just . UserSpecified)       where notFound = "Cannot find the program '" ++ name ++ "' at '"                      ++ path ++ "' or on the path"@@ -286,17 +306,16 @@     Nothing -> return conf     Just location -> do       version <- programFindVersion prog verbosity (locationPath location)+      newPath <- programSearchPathAsPATHVar (progSearchPath conf)       let configuredProg        = ConfiguredProgram {             programId           = name,             programVersion      = version,             programDefaultArgs  = [],             programOverrideArgs = userSpecifiedArgs prog conf,+            programOverrideEnv  = [("PATH", Just newPath)],             programLocation     = location           }-      extraArgs <- programPostConf prog verbosity configuredProg-      let configuredProg'       = configuredProg {-            programDefaultArgs  = extraArgs-          }+      configuredProg' <- programPostConf prog verbosity configuredProg       return (updateConfiguredProgs (Map.insert name configuredProg') conf)
+ Distribution/Simple/Program/Find.hs view
@@ -0,0 +1,119 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Program.Types+-- Copyright   :  Duncan Coutts 2013+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- A somewhat extended notion of the normal program search path concept.+--+-- Usually when finding executables we just want to look in the usual places+-- using the OS's usual method for doing so. In Haskell the normal OS-specific+-- method is captured by 'findExecutable'. On all common OSs that makes use of+-- a @PATH@ environment variable, (though on Windows it is not just the @PATH@).+--+-- However it is sometimes useful to be able to look in additional locations+-- without having to change the process-global @PATH@ environment variable.+-- So we need an extension of the usual 'findExecutable' that can look in+-- additional locations, either before, after or instead of the normal OS+-- locations.+--+module Distribution.Simple.Program.Find (+    -- * Program search path+    ProgramSearchPath,+    ProgramSearchPathEntry(..),+    defaultProgramSearchPath,+    findProgramOnSearchPath,+    programSearchPathAsPATHVar,+  ) where++import Distribution.Verbosity+         ( Verbosity )+import Distribution.Simple.Utils+         ( debug )+import Distribution.System+         ( OS(..), buildOS )+import System.Directory+         ( findExecutable, doesFileExist, Permissions(..), getPermissions )+import Distribution.Compat.Environment+         ( getEnvironment )+import System.FilePath+         ( (</>), (<.>), splitSearchPath, searchPathSeparator )+import Data.List+         ( intercalate )+++-- | A search path to use when locating executables. This is analogous+-- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use+-- the system default method for finding executables ('findExecutable' which+-- on unix is simply looking on the @$PATH@ but on win32 is a bit more+-- complicated).+--+-- The default to use is @[ProgSearchPathDefault]@ but you can add extra dirs+-- either before, after or instead of the default, e.g. here we add an extra+-- dir to search after the usual ones.+--+-- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir]+--+type ProgramSearchPath = [ProgramSearchPathEntry]+data ProgramSearchPathEntry =+         ProgramSearchPathDir FilePath  -- ^ A specific dir+       | ProgramSearchPathDefault       -- ^ The system default++defaultProgramSearchPath :: ProgramSearchPath+defaultProgramSearchPath = [ProgramSearchPathDefault]++findProgramOnSearchPath :: Verbosity -> ProgramSearchPath+                        -> FilePath -> IO (Maybe FilePath)+findProgramOnSearchPath verbosity searchpath prog = do+    debug verbosity $ "Searching for " ++ prog ++ " in path."+    res <- tryPathElems searchpath+    case res of+      Nothing   -> debug verbosity ("Cannot find " ++ prog ++ " on the path")+      Just path -> debug verbosity ("Found " ++ prog ++ " at "++ path)+    return res+  where+    tryPathElems []       = return Nothing+    tryPathElems (pe:pes) = do+      res <- tryPathElem pe+      case res of+        Nothing -> tryPathElems pes+        Just _  -> return res++    tryPathElem (ProgramSearchPathDir dir) =+        findFirstExe [ dir </> prog <.> ext | ext <- extensions ]+      where+        -- Possible improvement: on Windows, read the list of extensions from+        -- the PATHEXT environment variable. By default PATHEXT is ".com; .exe;+        -- .bat; .cmd".+        extensions = case buildOS of+                       Windows -> ["", "exe"]+                       _       -> [""]++    tryPathElem ProgramSearchPathDefault =+      findExecutable prog++    findFirstExe []     = return Nothing+    findFirstExe (f:fs) = do+      exists <- doesFileExist f+      if exists+        then do perms <- getPermissions f+                if executable perms+                  then return (Just f)+                  else findFirstExe fs+        else findFirstExe fs+++-- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var.+-- Note that this is close but not perfect because on Windows the search+-- algorithm looks at more than just the @%PATH%@.+programSearchPathAsPATHVar :: ProgramSearchPath -> IO String+programSearchPathAsPATHVar searchpath = do+    ess <- mapM getEntries searchpath+    return (intercalate [searchPathSeparator] (concat ess))+  where+    getEntries (ProgramSearchPathDir dir) = return [dir]+    getEntries ProgramSearchPathDefault   = do+      env <- getEnvironment+      return (maybe [] splitSearchPath (lookup "PATH" env))
Distribution/Simple/Program/GHC.hs view
@@ -2,6 +2,7 @@     GhcOptions(..),     GhcMode(..),     GhcOptimisation(..),+    GhcDynLinkMode(..),      ghcInvocation,     renderGhcOptions,@@ -52,6 +53,10 @@   -- | Location for output file; the @ghc -o@ flag.   ghcOptOutputFile    :: Flag FilePath, +  -- | Location for dynamic output file in 'GhcStaticAndDynamic' mode;+  -- the @ghc -dyno@ flag.+  ghcOptOutputDynFile :: 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,@@ -97,6 +102,9 @@   -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag.   ghcOptNoLink :: Flag Bool, +  -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ flag.+  ghcOptLinkNoHsMain :: Flag Bool,+   --------------------   -- C and CPP stuff @@ -151,14 +159,17 @@    ghcOptHiSuffix      :: Flag String,   ghcOptObjSuffix     :: Flag String,+  ghcOptDynHiSuffix   :: Flag String,   -- ^ only in 'GhcStaticAndDynamic' mode+  ghcOptDynObjSuffix  :: Flag String,   -- ^ only in 'GhcStaticAndDynamic' mode   ghcOptHiDir         :: Flag FilePath,   ghcOptObjDir        :: Flag FilePath,+  ghcOptOutputDir     :: Flag FilePath,   ghcOptStubDir       :: Flag FilePath,    --------------------   -- Dynamic linking -  ghcOptDynamic       :: Flag Bool,+  ghcOptDynLinkMode   :: Flag GhcDynLinkMode,   ghcOptShared        :: Flag Bool,   ghcOptFPic          :: Flag Bool,   ghcOptDylibName     :: Flag String,@@ -191,7 +202,12 @@                      | GhcSpecialOptimisation String -- ^ e.g. @-Odph@  deriving (Show, Eq) +data GhcDynLinkMode = GhcStaticOnly       -- ^ @-static@+                    | GhcDynamicOnly      -- ^ @-dynamic@+                    | GhcStaticAndDynamic -- ^ @-static -dynamic-too@+ deriving (Show, Eq) + runGHC :: Verbosity -> ConfiguredProgram -> GhcOptions -> IO () runGHC verbosity ghcProg opts = do   runProgramInvocation verbosity (ghcInvocation ghcProg opts)@@ -246,7 +262,11 @@   -- Dynamic linking    , [ "-shared"  | flagBool ghcOptShared  ]-  , [ "-dynamic" | flagBool ghcOptDynamic ]+  , case flagToMaybe (ghcOptDynLinkMode opts) of+      Nothing                  -> []+      Just GhcStaticOnly       -> ["-static"]+      Just GhcDynamicOnly      -> ["-dynamic"]+      Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"]   , [ "-fPIC"    | flagBool ghcOptFPic ]    , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ]@@ -256,6 +276,9 @@    , concat [ ["-osuf",    suf] | suf <- flag ghcOptObjSuffix ]   , concat [ ["-hisuf",   suf] | suf <- flag ghcOptHiSuffix  ]+  , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ]+  , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix  ]+  , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir, ver >= [6,10] ]   , concat [ ["-odir",    dir] | dir <- flag ghcOptObjDir ]   , concat [ ["-hidir",   dir] | dir <- flag ghcOptHiDir  ]   , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir, ver >= [6,8] ]@@ -282,6 +305,7 @@   , ["-l" ++ lib     | lib <- flags ghcOptLinkLibs ]   , ["-L" ++ dir     | dir <- flags ghcOptLinkLibPath ]   , concat [ ["-framework", fmwk] | fmwk <- flags ghcOptLinkFrameworks ]+  , [ "-no-hs-main"  | flagBool ghcOptLinkNoHsMain ]    -------------   -- Packages@@ -322,7 +346,8 @@   , [ display modu | modu <- flags ghcOptInputModules ]   , ghcOptInputFiles opts -  , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ]+  , concat [ [ "-o",    out] | out <- flag ghcOptOutputFile ]+  , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ]    ---------------   -- Extra@@ -375,6 +400,7 @@     ghcOptInputFiles         = mempty,     ghcOptInputModules       = mempty,     ghcOptOutputFile         = mempty,+    ghcOptOutputDynFile      = mempty,     ghcOptSourcePathClear    = mempty,     ghcOptSourcePath         = mempty,     ghcOptPackageName        = mempty,@@ -387,6 +413,7 @@     ghcOptLinkOptions        = mempty,     ghcOptLinkFrameworks     = mempty,     ghcOptNoLink             = mempty,+    ghcOptLinkNoHsMain       = mempty,     ghcOptCcOptions          = mempty,     ghcOptCppOptions         = mempty,     ghcOptCppIncludePath     = mempty,@@ -401,10 +428,13 @@     ghcOptGHCiScripts        = mempty,     ghcOptHiSuffix           = mempty,     ghcOptObjSuffix          = mempty,+    ghcOptDynHiSuffix        = mempty,+    ghcOptDynObjSuffix       = mempty,     ghcOptHiDir              = mempty,     ghcOptObjDir             = mempty,+    ghcOptOutputDir          = mempty,     ghcOptStubDir            = mempty,-    ghcOptDynamic            = mempty,+    ghcOptDynLinkMode        = mempty,     ghcOptShared             = mempty,     ghcOptFPic               = mempty,     ghcOptDylibName          = mempty,@@ -418,6 +448,7 @@     ghcOptInputFiles         = combine ghcOptInputFiles,     ghcOptInputModules       = combine ghcOptInputModules,     ghcOptOutputFile         = combine ghcOptOutputFile,+    ghcOptOutputDynFile      = combine ghcOptOutputDynFile,     ghcOptSourcePathClear    = combine ghcOptSourcePathClear,     ghcOptSourcePath         = combine ghcOptSourcePath,     ghcOptPackageName        = combine ghcOptPackageName,@@ -430,6 +461,7 @@     ghcOptLinkOptions        = combine ghcOptLinkOptions,     ghcOptLinkFrameworks     = combine ghcOptLinkFrameworks,     ghcOptNoLink             = combine ghcOptNoLink,+    ghcOptLinkNoHsMain       = combine ghcOptLinkNoHsMain,     ghcOptCcOptions          = combine ghcOptCcOptions,     ghcOptCppOptions         = combine ghcOptCppOptions,     ghcOptCppIncludePath     = combine ghcOptCppIncludePath,@@ -444,10 +476,13 @@     ghcOptGHCiScripts        = combine ghcOptGHCiScripts,     ghcOptHiSuffix           = combine ghcOptHiSuffix,     ghcOptObjSuffix          = combine ghcOptObjSuffix,+    ghcOptDynHiSuffix        = combine ghcOptDynHiSuffix,+    ghcOptDynObjSuffix       = combine ghcOptDynObjSuffix,     ghcOptHiDir              = combine ghcOptHiDir,     ghcOptObjDir             = combine ghcOptObjDir,+    ghcOptOutputDir          = combine ghcOptOutputDir,     ghcOptStubDir            = combine ghcOptStubDir,-    ghcOptDynamic            = combine ghcOptDynamic,+    ghcOptDynLinkMode        = combine ghcOptDynLinkMode,     ghcOptShared             = combine ghcOptShared,     ghcOptFPic               = combine ghcOptFPic,     ghcOptDylibName          = combine ghcOptDylibName,
Distribution/Simple/Program/HcPkg.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Program.HcPkg--- Copyright   :  Duncan Coutts 2009+-- Copyright   :  Duncan Coutts 2009, 2013 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -10,22 +10,28 @@ -- Currently only GHC and LHC have hc-pkg programs.  module Distribution.Simple.Program.HcPkg (+    init,+    invoke,     register,     reregister,     unregister,     expose,     hide,     dump,+    list,      -- * Program invocations+    initInvocation,     registerInvocation,     reregisterInvocation,     unregisterInvocation,     exposeInvocation,     hideInvocation,     dumpInvocation,+    listInvocation,   ) where +import Prelude hiding (init) import Distribution.Package          ( PackageId, InstalledPackageId(..) ) import Distribution.InstalledPackageInfo@@ -43,7 +49,7 @@ import Distribution.Version          ( Version(..) ) import Distribution.Text-         ( display )+         ( display, simpleParse ) import Distribution.Simple.Utils          ( die ) import Distribution.Verbosity@@ -62,6 +68,24 @@ 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)++-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the+-- provided command-line arguments to it.+invoke :: Verbosity -> ConfiguredProgram -> PackageDBStack -> [String] -> IO ()+invoke verbosity hcPkg dbStack extraArgs =+  runProgramInvocation verbosity invocation+  where+    args       = packageDbStackOpts hcPkg dbStack ++ extraArgs+    invocation = programInvocation hcPkg args+ -- | Call @hc-pkg@ to register a package. -- -- > hc-pkg register {filename | -} [--user | --global | --package-db]@@ -118,7 +142,8 @@     (hideInvocation hcPkg verbosity packagedb pkgid)  --- | Call @hc-pkg@ to get all the installed packages.+-- | Call @hc-pkg@ to get all the details of all the packages in the given+-- package database. -- dump :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [InstalledPackageInfo] dump verbosity hcPkg packagedb = do@@ -224,10 +249,45 @@ setInstalledPackageId pkginfo = pkginfo  +-- | Call @hc-pkg@ to get the source package Id of all the packages in the+-- given package database.+--+-- This is much less information than with 'dump', but also rather quicker.+-- Note in particular that it does not include the 'InstalledPackageId', just+-- the source 'PackageId' which is not necessarily unique in any package db.+--+list :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [PackageId]+list verbosity hcPkg packagedb = do++  output <- getProgramInvocationOutput verbosity+              (listInvocation hcPkg verbosity packagedb)+    `catchExit` \_ -> die $ programId hcPkg ++ " list failed"++  case parsePackageIds output of+    Just ok -> return ok+    _       -> die $ "failed to parse output of '"+                  ++ programId hcPkg ++ " list'"++  where+    parsePackageIds str =+      let parsed = map simpleParse (words str)+       in case [ () | Nothing <- parsed ] of+            [] -> Just [ pkgid | Just pkgid <- parsed ]+            _  -> Nothing++ -------------------------- -- 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@@ -295,6 +355,18 @@     }   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.++listInvocation :: ConfiguredProgram+               -> Verbosity -> PackageDB -> ProgramInvocation+listInvocation hcPkg _verbosity packagedb =+    (programInvocation hcPkg args) {+      progInvokeOutputEncoding = IOEncodingUTF8+    }+  where+    args = ["list", "--simple-output", 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.
Distribution/Simple/Program/Hpc.hs view
@@ -16,34 +16,61 @@ import Distribution.ModuleName ( ModuleName ) import Distribution.Simple.Program.Run          ( ProgramInvocation, programInvocation, runProgramInvocation )-import Distribution.Simple.Program.Types ( ConfiguredProgram )+import Distribution.Simple.Program.Types ( ConfiguredProgram(..) ) import Distribution.Text ( display )+import Distribution.Simple.Utils ( warn ) import Distribution.Verbosity ( Verbosity )+import Distribution.Version ( Version(..), orLaterVersion, withinRange ) +-- | Invoke hpc with the given parameters.+--+-- Prior to HPC version 0.7 (packaged with GHC 7.8), hpc did not handle+-- multiple .mix paths correctly, so we print a warning, and only pass it the+-- first path in the list. This means that e.g. test suites that import their+-- library as a dependency can still work, but those that include the library+-- modules directly (in other-modules) don't. markup :: ConfiguredProgram+       -> Version        -> Verbosity        -> FilePath            -- ^ Path to .tix file-       -> FilePath            -- ^ Path to directory with .mix files+       -> [FilePath]          -- ^ Paths to .mix file directories        -> FilePath            -- ^ Path where html output should be located        -> [ModuleName]        -- ^ List of modules to exclude from report        -> IO ()-markup hpc verbosity tixFile hpcDir destDir excluded =+markup hpc hpcVer verbosity tixFile hpcDirs destDir excluded = do+    hpcDirs' <- if withinRange hpcVer (orLaterVersion version07)+        then return hpcDirs+        else do+            warn verbosity $ "Your version of HPC (" ++ display hpcVer+                ++ ") does not properly handle multiple search paths. "+                ++ "Coverage report generation may fail unexpectedly. These "+                ++ "issues are addressed in version 0.7 or later (GHC 7.8 or "+                ++ "later)."+                ++ if null droppedDirs+                    then ""+                    else " The following search paths have been abandoned: "+                        ++ show droppedDirs+            return passedDirs+     runProgramInvocation verbosity-      (markupInvocation hpc tixFile hpcDir destDir excluded)+      (markupInvocation hpc tixFile hpcDirs' destDir excluded)+  where+    version07 = Version { versionBranch = [0, 7], versionTags = [] }+    (passedDirs, droppedDirs) = splitAt 1 hpcDirs  markupInvocation :: ConfiguredProgram                  -> FilePath            -- ^ Path to .tix file-                 -> FilePath            -- ^ Path to directory with .mix files+                 -> [FilePath]          -- ^ Paths to .mix file directories                  -> FilePath            -- ^ Path where html output should be                                         -- located                  -> [ModuleName]        -- ^ List of modules to exclude from                                         -- report                  -> ProgramInvocation-markupInvocation hpc tixFile hpcDir destDir excluded =+markupInvocation hpc tixFile hpcDirs destDir excluded =     let args = [ "markup", tixFile-               , "--hpcdir=" ++ hpcDir                , "--destdir=" ++ destDir                ]+            ++ map ("--hpcdir=" ++) hpcDirs             ++ ["--exclude=" ++ display moduleName                | moduleName <- excluded ]     in programInvocation hpc args
Distribution/Simple/Program/Run.hs view
@@ -20,22 +20,26 @@     runProgramInvocation,     getProgramInvocationOutput, +    getEffectiveEnvironment,   ) where  import Distribution.Simple.Program.Types          ( ConfiguredProgram(..), programPath ) import Distribution.Simple.Utils-         ( die, rawSystemExit, rawSystemStdInOut+         ( die, rawSystemExit, rawSystemIOWithEnv, rawSystemStdInOut          , toUTF8, fromUTF8, normaliseLineEndings ) import Distribution.Verbosity          ( Verbosity )  import Data.List          ( foldl', unfoldr )+import qualified Data.Map as Map import Control.Monad          ( when ) import System.Exit-         ( ExitCode(..) )+         ( ExitCode(..), exitWith )+import Distribution.Compat.Environment+         ( getEnvironment )  -- | Represents a specific invocation of a specific program. --@@ -47,7 +51,7 @@ data ProgramInvocation = ProgramInvocation {        progInvokePath  :: FilePath,        progInvokeArgs  :: [String],-       progInvokeEnv   :: [(String, String)],+       progInvokeEnv   :: [(String, Maybe String)],        progInvokeCwd   :: Maybe FilePath,        progInvokeInput :: Maybe String,        progInvokeInputEncoding  :: IOEncoding,@@ -82,7 +86,8 @@     progInvokePath = programPath prog,     progInvokeArgs = programDefaultArgs prog                   ++ args-                  ++ programOverrideArgs prog+                  ++ programOverrideArgs prog,+    progInvokeEnv  = programOverrideEnv prog   }  @@ -101,23 +106,39 @@   ProgramInvocation {     progInvokePath  = path,     progInvokeArgs  = args,-    progInvokeEnv   = [],-    progInvokeCwd   = Nothing,+    progInvokeEnv   = envOverrides,+    progInvokeCwd   = mcwd,+    progInvokeInput = Nothing+  } = do+    menv <- getEffectiveEnvironment envOverrides+    exitCode <- rawSystemIOWithEnv verbosity+                                   path args+                                   mcwd menv+                                   Nothing Nothing Nothing+    when (exitCode /= ExitSuccess) $+      exitWith exitCode++runProgramInvocation verbosity+  ProgramInvocation {+    progInvokePath  = path,+    progInvokeArgs  = args,+    progInvokeEnv   = envOverrides,+    progInvokeCwd   = mcwd,     progInvokeInput = Just inputStr,     progInvokeInputEncoding = encoding   } = do+    menv <- getEffectiveEnvironment envOverrides     (_, errors, exitCode) <- rawSystemStdInOut verbosity                                     path args-                                    (Just input) False+                                    mcwd menv+                                    (Just input) True     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"+              IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for+                                                        -- utf8   getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String@@ -125,25 +146,43 @@   ProgramInvocation {     progInvokePath  = path,     progInvokeArgs  = args,-    progInvokeEnv   = [],-    progInvokeCwd   = Nothing,-    progInvokeInput = Nothing,+    progInvokeEnv   = envOverrides,+    progInvokeCwd   = mcwd,+    progInvokeInput = minputStr,     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)+    let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False+        decode | utf8      = fromUTF8 . normaliseLineEndings+               | otherwise = id+    menv <- getEffectiveEnvironment envOverrides+    (output, errors, exitCode) <- rawSystemStdInOut verbosity+                                    path args+                                    mcwd menv+                                    input utf8+    when (exitCode /= ExitSuccess) $+      die errors+    return (decode output)+  where+    input =+      case minputStr of+        Nothing       -> Nothing+        Just inputStr -> Just $+          case encoding of+            IOEncodingText -> (inputStr, False)+            IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8  -getProgramInvocationOutput _ _ =-   die "getProgramInvocationOutput: not yet implemented for this form of invocation"-+-- | Return the current environment extended with the given overrides.+--+getEffectiveEnvironment :: [(String, Maybe String)]+                        -> IO (Maybe [(String, String)])+getEffectiveEnvironment []        = return Nothing+getEffectiveEnvironment overrides =+    fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment+  where+    apply os env = foldl' (flip update) env os+    update (var, Nothing)  = Map.delete var+    update (var, Just val) = Map.insert var val  -- | 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
Distribution/Simple/Program/Script.hs view
@@ -44,8 +44,7 @@     progInvokeInput = minput   } = unlines $           [ "#!/bin/sh" ]-       ++ [ "export " ++ var ++ "=" ++ quote val-          | (var,val) <- envExtra ]+       ++ concatMap setEnv envExtra        ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ]        ++ [ (case minput of               Nothing    -> ""@@ -53,6 +52,9 @@          ++ unwords (map quote $ path : args) ++ " \"$@\""]    where+    setEnv (var, Nothing)  = ["unset " ++ var, "export " ++ var]+    setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val]+     quote :: String -> String     quote s = "'" ++ escape s ++ "'" @@ -73,7 +75,7 @@     progInvokeInput = minput   } = unlines $           [ "@echo off" ]-       ++ [ "set " ++ var ++ "=" ++ escape val | (var,val) <- envExtra ]+       ++ map setEnv envExtra        ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ]        ++ case minput of             Nothing    ->@@ -87,6 +89,9 @@                ++ concatMap (\arg -> ' ':quote arg) args ]    where+    setEnv (var, Nothing)  = "set " ++ var ++ "="+    setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val+     quote :: String -> String     quote s = "\"" ++ escapeQ s ++ "\""
Distribution/Simple/Program/Types.hs view
@@ -17,18 +17,22 @@ module Distribution.Simple.Program.Types (     -- * Program and functions for constructing them     Program(..),+    ProgramSearchPath,+    ProgramSearchPathEntry(..),     simpleProgram,      -- * Configured program and related functions     ConfiguredProgram(..),     programPath,+    suppressOverrideArgs,     ProgArg,     ProgramLocation(..),     simpleConfiguredProgram,   ) where -import Distribution.Simple.Utils-         ( findProgramLocation )+import Distribution.Simple.Program.Find+         ( ProgramSearchPath, ProgramSearchPathEntry(..)+         , findProgramOnSearchPath ) import Distribution.Version          ( Version ) import Distribution.Verbosity@@ -43,19 +47,23 @@        -- | 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),+       -- | A function to search for the program if its location was not+       -- specified by the user. Usually this will just be a call to+       -- 'findProgramOnSearchPath'.+       --+       -- It is supplied with the prevailing search path which will typically+       -- just be used as-is, but can be extended or ignored as needed.+       programFindLocation :: Verbosity -> ProgramSearchPath+                              -> 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]+       -- located the program (and perhaps identified its version). For example+       -- it could add args, or environment vars.+       programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram      }  type ProgArg = String@@ -83,6 +91,11 @@        -- all earlier flags.        programOverrideArgs :: [String], +       -- | Override environment variables for this program.+       -- These env vars will extend\/override the prevailing environment of+       -- the current to form the environment for the new process.+       programOverrideEnv :: [(String, Maybe String)],+        -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@        programLocation :: ProgramLocation      } deriving (Read, Show, Eq)@@ -101,6 +114,10 @@ programPath :: ConfiguredProgram -> FilePath programPath = locationPath . programLocation +-- | Suppress any extra arguments added by the user.+suppressOverrideArgs :: ConfiguredProgram -> ConfiguredProgram+suppressOverrideArgs prog = prog { programOverrideArgs = [] }+ -- | Make a simple named program. -- -- By default we'll just search for it in the path and not try to find the@@ -111,9 +128,9 @@ simpleProgram :: String -> Program simpleProgram name = Program {     programName         = name,-    programFindLocation = \v   -> findProgramLocation v name,+    programFindLocation = \v p -> findProgramOnSearchPath v p name,     programFindVersion  = \_ _ -> return Nothing,-    programPostConf     = \_ _ -> return []+    programPostConf     = \_ p -> return p   }  -- | Make a simple 'ConfiguredProgram'.@@ -126,5 +143,6 @@      programVersion      = Nothing,      programDefaultArgs  = [],      programOverrideArgs = [],+     programOverrideEnv  = [],      programLocation     = loc   }
Distribution/Simple/Register.hs view
@@ -57,6 +57,8 @@     register,     unregister, +    initPackageDB,+    invokeHcPkg,     registerPackage,     generateRegistrationInfo,     inplaceInstalledPackageInfo,@@ -66,6 +68,8 @@  import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)+         , ComponentName(..), getComponentLocalBuildInfo+         , LibraryName(..)          , InstallDirs(..), absoluteInstallDirs ) import Distribution.Simple.BuildPaths (haddockName) import qualified Distribution.Simple.GHC  as GHC@@ -73,11 +77,12 @@ import qualified Distribution.Simple.Hugs as Hugs import qualified Distribution.Simple.UHC  as UHC import Distribution.Simple.Compiler-         ( compilerVersion, CompilerFlavor(..), compilerFlavor+         ( compilerVersion, Compiler, CompilerFlavor(..), compilerFlavor          , PackageDBStack, registrationPackageDB ) import Distribution.Simple.Program-         ( ConfiguredProgram, runProgramInvocation-         , requireProgram, lookupProgram, ghcPkgProgram, lhcPkgProgram )+         ( ProgramConfiguration, ConfiguredProgram+         , runProgramInvocation, requireProgram, lookupProgram+         , ghcPkgProgram, lhcPkgProgram ) import Distribution.Simple.Program.Script          ( invocationAsSystemScript ) import qualified Distribution.Simple.Program.HcPkg as HcPkg@@ -113,7 +118,7 @@          ( isJust, fromMaybe, maybeToList ) import Data.List          ( partition, nub )-+import qualified Data.ByteString.Lazy.Char8 as BS.Char8  -- ----------------------------------------------------------------------------- -- Registration@@ -121,10 +126,9 @@ register :: PackageDescription -> LocalBuildInfo          -> RegisterFlags -- ^Install in the user's database?; verbose          -> IO ()-register pkg@PackageDescription { library       = Just lib  }-         lbi@LocalBuildInfo     { libraryConfig = Just clbi } regFlags+register pkg@PackageDescription { library       = Just lib  } lbi regFlags   = do-+    let clbi = getComponentLocalBuildInfo lbi CLibName     installedPkgInfo <- generateRegistrationInfo                            verbosity pkg lib lbi clbi inplace distPref @@ -204,6 +208,25 @@   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 "Distribution.Simple.Register.initPackageDB: \+               \not implemented for this compiler"++-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the+-- provided command-line arguments to it.+invokeHcPkg :: Verbosity -> Compiler -> ProgramConfiguration -> PackageDBStack+                -> [String] -> IO ()+invokeHcPkg verbosity comp conf dbStack extraArgs =+    case (compilerFlavor comp) of+      GHC -> GHC.invokeHcPkg verbosity conf dbStack extraArgs+      _   -> die "Distribution.Simple.Register.invokeHcPkg: \+                 \not implemented for this compiler"+ registerPackage :: Verbosity                 -> InstalledPackageInfo                 -> PackageDescription@@ -283,7 +306,9 @@     IPI.libraryDirs        = if hasLibrary                                then libdir installDirs : extraLibDirs bi                                else                      extraLibDirs bi,-    IPI.hsLibraries        = [ "HS" ++ display (packageId pkg) | hasLibrary ],+    IPI.hsLibraries        = [ libname+                             | LibraryName libname <- componentLibraries clbi+                             , hasLibrary ],     IPI.extraLibraries     = extraLibs bi,     IPI.extraGHCiLibraries = [],     IPI.includeDirs        = absinc ++ adjustRelIncDirs relinc,@@ -377,7 +402,7 @@                          packageDb pkgid       in if genScript            then writeFileAtomic unregScriptFileName-                  (invocationAsSystemScript buildOS invocation)+                  (BS.Char8.pack $ invocationAsSystemScript buildOS invocation)             else runProgramInvocation verbosity invocation     Hugs -> do         _ <- tryIO $ removeDirectoryRecursive (libdir installDirs)
Distribution/Simple/Setup.hs view
@@ -60,22 +60,26 @@    GlobalFlags(..),   emptyGlobalFlags,   defaultGlobalFlags,   globalCommand,   ConfigFlags(..),   emptyConfigFlags,   defaultConfigFlags,   configureCommand,+  configAbsolutePaths,   CopyFlags(..),     emptyCopyFlags,     defaultCopyFlags,     copyCommand,   InstallFlags(..),  emptyInstallFlags,  defaultInstallFlags,  installCommand,   HaddockFlags(..),  emptyHaddockFlags,  defaultHaddockFlags,  haddockCommand,   HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand,   BuildFlags(..),    emptyBuildFlags,    defaultBuildFlags,    buildCommand,   buildVerbose,+  ReplFlags(..),                         defaultReplFlags,     replCommand,   CleanFlags(..),    emptyCleanFlags,    defaultCleanFlags,    cleanCommand,   RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand,                                                                unregisterCommand,   SDistFlags(..),    emptySDistFlags,    defaultSDistFlags,    sdistCommand,   TestFlags(..),     emptyTestFlags,     defaultTestFlags,     testCommand,   TestShowDetails(..),-  BenchmarkFlags(..), emptyBenchmarkFlags, defaultBenchmarkFlags, benchmarkCommand,+  BenchmarkFlags(..), emptyBenchmarkFlags,+  defaultBenchmarkFlags, benchmarkCommand,   CopyDest(..),   configureArgs, configureOptions, configureCCompiler, configureLinker,-  installDirsOptions,+  buildOptions, installDirsOptions,+  programConfigurationOptions, programConfigurationPaths',    defaultDistPref, @@ -100,7 +104,8 @@ import qualified Distribution.Simple.Command as Command import Distribution.Simple.Compiler          ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..)-         , OptimisationLevel(..), flagToOptimisationLevel )+         , OptimisationLevel(..), flagToOptimisationLevel+         , absolutePackageDBPath ) import Distribution.Simple.Utils          ( wrapLine, lowercase, intercalate ) import Distribution.Simple.Program (Program(..), ProgramConfiguration,@@ -114,6 +119,7 @@            PathTemplate, toPathTemplate, fromPathTemplate ) import Distribution.Verbosity +import Control.Monad (liftM) import Data.List   ( sort ) import Data.Char   ( isSpace, isAlpha ) import Data.Monoid ( Monoid(..) )@@ -189,6 +195,9 @@ flagToList (Flag x) = [x] flagToList NoFlag   = [] +allFlags :: [Flag Bool] -> Flag Bool+allFlags flags = toFlag $ all (\f -> fromFlagOrDefault False f) flags+ -- ------------------------------------------------------------ -- * Global flags -- ------------------------------------------------------------@@ -261,23 +270,30 @@     -- 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+    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.+    configProgramPathExtra :: [FilePath],        -- ^Extend the $PATH+    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.+    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+    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@@ -298,13 +314,19 @@   }   deriving (Read,Show) +configAbsolutePaths :: ConfigFlags -> IO ConfigFlags+configAbsolutePaths f =+  (\v -> f { configPackageDBs = v })+  `liftM` mapM (maybe (return Nothing) (liftM Just . absolutePackageDBPath))+  (configPackageDBs f)+ defaultConfigFlags :: ProgramConfiguration -> ConfigFlags defaultConfigFlags progConf = emptyConfigFlags {     configPrograms     = progConf,     configHcFlavor     = maybe NoFlag Flag defaultCompilerFlavor,     configVanillaLib   = Flag True,     configProfLib      = Flag False,-    configSharedLib    = Flag False,+    configSharedLib    = NoFlag,     configDynExe       = Flag False,     configProfExe      = Flag False,     configOptimization = Flag NormalOptimisation,@@ -313,16 +335,17 @@     configDistPref     = Flag defaultDistPref,     configVerbosity    = Flag normal,     configUserInstall  = Flag False,           --TODO: reverse this-    configGHCiLib      = Flag True,+    configGHCiLib      = Flag False,     configSplitObjs    = Flag False, -- takes longer, so turn off by default     configStripExes    = Flag True,-    configTests  = Flag False,+    configTests        = Flag False,     configBenchmarks   = Flag False,-    configLibCoverage = Flag False+    configLibCoverage  = Flag False   }  configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags-configureCommand progConf = makeCommand name shortDesc longDesc defaultFlags options+configureCommand progConf = makeCommand name shortDesc+                            longDesc defaultFlags options   where     name       = "configure"     shortDesc  = "Prepare to build the package."@@ -332,13 +355,15 @@          configureOptions showOrParseArgs       ++ programConfigurationPaths   progConf showOrParseArgs            configProgramPaths (\v fs -> fs { configProgramPaths = v })+      ++ programConfigurationOption progConf showOrParseArgs+           configProgramArgs (\v fs -> fs { configProgramArgs = v })       ++ programConfigurationOptions progConf showOrParseArgs            configProgramArgs (\v fs -> fs { configProgramArgs = v }) - configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] configureOptions showOrParseArgs =-      [optionVerbosity configVerbosity (\v flags -> flags { configVerbosity = v })+      [optionVerbosity configVerbosity+       (\v flags -> flags { configVerbosity = v })       ,optionDistPref          configDistPref (\d flags -> flags { configDistPref = d })          showOrParseArgs@@ -464,6 +489,12 @@          "A list of directories to search for external libraries"          configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v})          (reqArg' "PATH" (\x -> [x]) id)++      ,option "" ["extra-prog-path"]+         "A list of directories to search for required programs (in addition to the normal search locations)"+         configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v})+         (reqArg' "PATH" (\x -> [x]) id)+       ,option "" ["constraint"]          "A list of additional constraints on the dependencies."          configConstraints (\v flags -> flags { configConstraints = v})@@ -565,6 +596,11 @@       "installation directory for haddock interfaces"       haddockdir (\v flags -> flags { haddockdir = v })       installDirArg++  , option "" ["sysconfdir"]+      "installation directory for configuration files"+      sysconfdir (\v flags -> flags { sysconfdir = v })+      installDirArg   ]   where     installDirArg _sf _lf d get set =@@ -579,6 +615,7 @@     configPrograms      = error "FIXME: remove configPrograms",     configProgramPaths  = mempty,     configProgramArgs   = mempty,+    configProgramPathExtra = mempty,     configHcFlavor      = mempty,     configHcPath        = mempty,     configHcPkg         = mempty,@@ -612,6 +649,7 @@     configPrograms      = configPrograms b,     configProgramPaths  = combine configProgramPaths,     configProgramArgs   = combine configProgramArgs,+    configProgramPathExtra = combine configProgramPathExtra,     configHcFlavor      = combine configHcFlavor,     configHcPath        = combine configHcPath,     configHcPkg         = combine configHcPkg,@@ -782,19 +820,21 @@  -- | Flags to @sdist@: (snapshot, verbosity) data SDistFlags = SDistFlags {-    sDistSnapshot  :: Flag Bool,-    sDistDirectory :: Flag FilePath,-    sDistDistPref  :: Flag FilePath,-    sDistVerbosity :: Flag Verbosity+    sDistSnapshot    :: Flag Bool,+    sDistDirectory   :: Flag FilePath,+    sDistDistPref    :: Flag FilePath,+    sDistListSources :: Flag FilePath,+    sDistVerbosity   :: Flag Verbosity   }   deriving Show  defaultSDistFlags :: SDistFlags defaultSDistFlags = SDistFlags {-    sDistSnapshot  = Flag False,-    sDistDirectory = mempty,-    sDistDistPref  = Flag defaultDistPref,-    sDistVerbosity = Flag normal+    sDistSnapshot    = Flag False,+    sDistDirectory   = mempty,+    sDistDistPref    = Flag defaultDistPref,+    sDistListSources = mempty,+    sDistVerbosity   = Flag normal   }  sdistCommand :: CommandUI SDistFlags@@ -809,13 +849,19 @@          sDistDistPref (\d flags -> flags { sDistDistPref = d })          showOrParseArgs +     ,option "" ["list-sources"]+         "Just write a list of the package's sources to a file"+         sDistListSources (\v flags -> flags { sDistListSources = v })+         (reqArgFlag "FILE")+       ,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"+       ("Generate a source distribution in the given directory, "+        ++ "without creating a tarball")          sDistDirectory (\v flags -> flags { sDistDirectory = v })          (reqArgFlag "DIR")       ]@@ -825,16 +871,18 @@  instance Monoid SDistFlags where   mempty = SDistFlags {-    sDistSnapshot  = mempty,-    sDistDirectory = mempty,-    sDistDistPref  = mempty,-    sDistVerbosity = mempty+    sDistSnapshot    = mempty,+    sDistDirectory   = mempty,+    sDistDistPref    = mempty,+    sDistListSources = mempty,+    sDistVerbosity   = mempty   }   mappend a b = SDistFlags {-    sDistSnapshot  = combine sDistSnapshot,-    sDistDirectory = combine sDistDirectory,-    sDistDistPref  = combine sDistDistPref,-    sDistVerbosity = combine sDistVerbosity+    sDistSnapshot    = combine sDistSnapshot,+    sDistDirectory   = combine sDistDirectory,+    sDistDistPref    = combine sDistDistPref,+    sDistListSources = combine sDistListSources,+    sDistVerbosity   = combine sDistVerbosity   }     where combine field = field a `mappend` field b @@ -865,7 +913,8 @@   }  registerCommand :: CommandUI RegisterFlags-registerCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options+registerCommand = makeCommand name shortDesc longDesc+                  defaultRegisterFlags options   where     name       = "register"     shortDesc  = "Register this package with the compiler."@@ -900,7 +949,8 @@       ]  unregisterCommand :: CommandUI RegisterFlags-unregisterCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options+unregisterCommand = makeCommand name shortDesc+                    longDesc defaultRegisterFlags options   where     name       = "unregister"     shortDesc  = "Unregister this package with the compiler."@@ -953,6 +1003,8 @@ data HscolourFlags = HscolourFlags {     hscolourCSS         :: Flag FilePath,     hscolourExecutables :: Flag Bool,+    hscolourTestSuites  :: Flag Bool,+    hscolourBenchmarks  :: Flag Bool,     hscolourDistPref    :: Flag FilePath,     hscolourVerbosity   :: Flag Verbosity   }@@ -965,6 +1017,8 @@ defaultHscolourFlags = HscolourFlags {     hscolourCSS         = NoFlag,     hscolourExecutables = Flag False,+    hscolourTestSuites  = Flag False,+    hscolourBenchmarks  = Flag False,     hscolourDistPref    = Flag defaultDistPref,     hscolourVerbosity   = Flag normal   }@@ -973,25 +1027,31 @@   mempty = HscolourFlags {     hscolourCSS         = mempty,     hscolourExecutables = mempty,+    hscolourTestSuites  = mempty,+    hscolourBenchmarks  = mempty,     hscolourDistPref    = mempty,     hscolourVerbosity   = mempty   }   mappend a b = HscolourFlags {     hscolourCSS         = combine hscolourCSS,     hscolourExecutables = combine hscolourExecutables,+    hscolourTestSuites  = combine hscolourTestSuites,+    hscolourBenchmarks  = combine hscolourBenchmarks,     hscolourDistPref    = combine hscolourDistPref,     hscolourVerbosity   = combine hscolourVerbosity   }     where combine field = field a `mappend` field b  hscolourCommand :: CommandUI HscolourFlags-hscolourCommand = makeCommand name shortDesc longDesc defaultHscolourFlags options+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 })+      [optionVerbosity hscolourVerbosity+       (\v flags -> flags { hscolourVerbosity = v })       ,optionDistPref          hscolourDistPref (\d flags -> flags { hscolourDistPref = d })          showOrParseArgs@@ -1001,6 +1061,26 @@          hscolourExecutables (\v flags -> flags { hscolourExecutables = v })          trueArg +      ,option "" ["tests"]+         "Run hscolour for Test Suite targets"+         hscolourTestSuites (\v flags -> flags { hscolourTestSuites = v })+         trueArg++      ,option "" ["benchmarks"]+         "Run hscolour for Benchmark targets"+         hscolourBenchmarks (\v flags -> flags { hscolourBenchmarks = v })+         trueArg++      ,option "" ["all"]+         "Run hscolour for all targets"+         (\f -> allFlags [ hscolourExecutables f+                         , hscolourTestSuites  f+                         , hscolourBenchmarks  f])+         (\v flags -> flags { hscolourExecutables = v+                            , hscolourTestSuites  = v+                            , hscolourBenchmarks  = v })+         trueArg+       ,option "" ["css"]          "Use a cascading style sheet"          hscolourCSS (\v flags -> flags { hscolourCSS = v })@@ -1018,12 +1098,15 @@     haddockHtml         :: Flag Bool,     haddockHtmlLocation :: Flag String,     haddockExecutables  :: Flag Bool,+    haddockTestSuites   :: Flag Bool,+    haddockBenchmarks   :: Flag Bool,     haddockInternal     :: Flag Bool,     haddockCss          :: Flag FilePath,     haddockHscolour     :: Flag Bool,     haddockHscolourCss  :: Flag FilePath,     haddockContents     :: Flag PathTemplate,     haddockDistPref     :: Flag FilePath,+    haddockKeepTempFiles:: Flag Bool,     haddockVerbosity    :: Flag Verbosity   }   deriving Show@@ -1036,12 +1119,15 @@     haddockHtml         = Flag False,     haddockHtmlLocation = NoFlag,     haddockExecutables  = Flag False,+    haddockTestSuites   = Flag False,+    haddockBenchmarks   = Flag False,     haddockInternal     = Flag False,     haddockCss          = NoFlag,     haddockHscolour     = Flag False,     haddockHscolourCss  = NoFlag,     haddockContents     = NoFlag,     haddockDistPref     = Flag defaultDistPref,+    haddockKeepTempFiles= Flag False,     haddockVerbosity    = Flag normal   } @@ -1052,11 +1138,17 @@     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 })+      [optionVerbosity haddockVerbosity+       (\v flags -> flags { haddockVerbosity = v })       ,optionDistPref          haddockDistPref (\d flags -> flags { haddockDistPref = d })          showOrParseArgs +      ,option "" ["keep-temp-files"]+         "Keep temporary files"+         haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b })+         trueArg+       ,option "" ["hoogle"]          "Generate a hoogle database"          haddockHoogle (\v flags -> flags { haddockHoogle = v })@@ -1077,6 +1169,26 @@          haddockExecutables (\v flags -> flags { haddockExecutables = v })          trueArg +      ,option "" ["tests"]+         "Run haddock for Test Suite targets"+         haddockTestSuites (\v flags -> flags { haddockTestSuites = v })+         trueArg++      ,option "" ["benchmarks"]+         "Run haddock for Benchmark targets"+         haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v })+         trueArg++      ,option "" ["all"]+         "Run haddock for all targets"+         (\f -> allFlags [ haddockExecutables f+                         , haddockTestSuites  f+                         , haddockBenchmarks  f])+         (\v flags -> flags { haddockExecutables = v+                            , haddockTestSuites  = v+                            , haddockBenchmarks  = v })+         trueArg+       ,option "" ["internal"]          "Run haddock for internal modules and include all symbols"          haddockInternal (\v flags -> flags { haddockInternal = v })@@ -1096,7 +1208,7 @@          "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 })@@ -1106,6 +1218,8 @@       ]       ++ programConfigurationPaths   progConf ParseArgs              haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v})+      ++ programConfigurationOption  progConf showOrParseArgs+             haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v })       ++ programConfigurationOptions progConf ParseArgs              haddockProgramArgs  (\v flags -> flags { haddockProgramArgs = v})     progConf = addKnownProgram haddockProgram@@ -1123,12 +1237,15 @@     haddockHtml         = mempty,     haddockHtmlLocation = mempty,     haddockExecutables  = mempty,+    haddockTestSuites   = mempty,+    haddockBenchmarks   = mempty,     haddockInternal     = mempty,     haddockCss          = mempty,     haddockHscolour     = mempty,     haddockHscolourCss  = mempty,     haddockContents     = mempty,     haddockDistPref     = mempty,+    haddockKeepTempFiles= mempty,     haddockVerbosity    = mempty   }   mappend a b = HaddockFlags {@@ -1138,12 +1255,15 @@     haddockHtml         = combine haddockHoogle,     haddockHtmlLocation = combine haddockHtmlLocation,     haddockExecutables  = combine haddockExecutables,+    haddockTestSuites   = combine haddockTestSuites,+    haddockBenchmarks   = combine haddockBenchmarks,     haddockInternal     = combine haddockInternal,     haddockCss          = combine haddockCss,     haddockHscolour     = combine haddockHscolour,     haddockHscolourCss  = combine haddockHscolourCss,     haddockContents     = combine haddockContents,     haddockDistPref     = combine haddockDistPref,+    haddockKeepTempFiles= combine haddockKeepTempFiles,     haddockVerbosity    = combine haddockVerbosity   }     where combine field = field a `mappend` field b@@ -1208,7 +1328,10 @@     buildProgramPaths :: [(String, FilePath)],     buildProgramArgs :: [(String, [String])],     buildDistPref    :: Flag FilePath,-    buildVerbosity   :: Flag Verbosity+    buildVerbosity   :: Flag Verbosity,+    -- TODO: this one should not be here, it's just that the silly+    -- UserHooks stop us from passing extra info in other ways+    buildArgs :: [String]   }   deriving Show @@ -1221,27 +1344,49 @@     buildProgramPaths = mempty,     buildProgramArgs = [],     buildDistPref    = Flag defaultDistPref,-    buildVerbosity   = Flag normal+    buildVerbosity   = Flag normal,+    buildArgs        = []   }  buildCommand :: ProgramConfiguration -> CommandUI BuildFlags-buildCommand progConf = makeCommand name shortDesc longDesc defaultBuildFlags options+buildCommand progConf = makeCommand name shortDesc longDesc+                        defaultBuildFlags (buildOptions progConf)   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+    shortDesc  = "Compile all targets or specific targets."+    longDesc   = Just $ \pname ->+       "Examples:\n"+        ++ "  " ++ pname ++ " build           "+        ++ "    All the components in the package\n"+        ++ "  " ++ pname ++ " build foo       "+        ++ "    A component (i.e. lib, exe, test suite)\n"+--TODO: re-enable once we have support for module/file targets+--        ++ "  " ++ pname ++ " build Foo.Bar   "+--        ++ "    A module\n"+--        ++ "  " ++ pname ++ " build Foo/Bar.hs"+--        ++ "    A file\n\n"+--        ++ "If a target is ambigious it can be qualified with the component "+--        ++ "name, e.g.\n"+--        ++ "  " ++ pname ++ " build foo:Foo.Bar\n"+--        ++ "  " ++ pname ++ " build testsuite1:Foo/Bar.hs\n" -      : programConfigurationPaths   progConf showOrParseArgs-          buildProgramPaths (\v flags -> flags { buildProgramPaths = v})+buildOptions :: ProgramConfiguration -> ShowOrParseArgs+                -> [OptionField BuildFlags]+buildOptions progConf showOrParseArgs =+  optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v })+  : optionDistPref+  buildDistPref (\d flags -> flags { buildDistPref = d })+  showOrParseArgs -     ++ programConfigurationOptions progConf showOrParseArgs-          buildProgramArgs (\v flags -> flags { buildProgramArgs = v})+  : programConfigurationPaths   progConf showOrParseArgs+  buildProgramPaths (\v flags -> flags { buildProgramPaths = v}) +  ++ programConfigurationOption progConf showOrParseArgs+  buildProgramArgs (\v fs -> fs { buildProgramArgs = v })++  ++ programConfigurationOptions progConf showOrParseArgs+  buildProgramArgs (\v flags -> flags { buildProgramArgs = v})+ emptyBuildFlags :: BuildFlags emptyBuildFlags = mempty @@ -1250,17 +1395,105 @@     buildProgramPaths = mempty,     buildProgramArgs = mempty,     buildVerbosity   = mempty,-    buildDistPref    = mempty+    buildDistPref    = mempty,+    buildArgs        = mempty   }   mappend a b = BuildFlags {     buildProgramPaths = combine buildProgramPaths,     buildProgramArgs = combine buildProgramArgs,     buildVerbosity   = combine buildVerbosity,-    buildDistPref    = combine buildDistPref+    buildDistPref    = combine buildDistPref,+    buildArgs        = combine buildArgs   }     where combine field = field a `mappend` field b  -- ------------------------------------------------------------+-- * Repl Flags+-- ------------------------------------------------------------++data ReplFlags = ReplFlags {+    replProgramPaths :: [(String, FilePath)],+    replProgramArgs :: [(String, [String])],+    replDistPref    :: Flag FilePath,+    replVerbosity   :: Flag Verbosity,+    replReload      :: Flag Bool+  }+  deriving Show++defaultReplFlags :: ReplFlags+defaultReplFlags  = ReplFlags {+    replProgramPaths = mempty,+    replProgramArgs = [],+    replDistPref    = Flag defaultDistPref,+    replVerbosity   = Flag normal,+    replReload      = Flag False+  }++instance Monoid ReplFlags where+  mempty = ReplFlags {+    replProgramPaths = mempty,+    replProgramArgs = mempty,+    replVerbosity   = mempty,+    replDistPref    = mempty,+    replReload      = mempty+  }+  mappend a b = ReplFlags {+    replProgramPaths = combine replProgramPaths,+    replProgramArgs = combine replProgramArgs,+    replVerbosity   = combine replVerbosity,+    replDistPref    = combine replDistPref,+    replReload      = combine replReload+  }+    where combine field = field a `mappend` field b++replCommand :: ProgramConfiguration -> CommandUI ReplFlags+replCommand progConf = CommandUI {+    commandName         = "repl",+    commandSynopsis     = "Open an interpreter session for the given target.",+    commandDescription  = Just $ \pname ->+       "Examples:\n"+        ++ "  " ++ pname ++ " repl           "+        ++ "    The first component in the package\n"+        ++ "  " ++ pname ++ " repl foo       "+        ++ "    A named component (i.e. lib, exe, test suite)\n",+--TODO: re-enable once we have support for module/file targets+--        ++ "  " ++ pname ++ " repl Foo.Bar   "+--        ++ "    A module\n"+--        ++ "  " ++ pname ++ " repl Foo/Bar.hs"+--        ++ "    A file\n\n"+--        ++ "If a target is ambigious it can be qualified with the component "+--        ++ "name, e.g.\n"+--        ++ "  " ++ pname ++ " repl foo:Foo.Bar\n"+--        ++ "  " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n"++    commandUsage =  \pname -> "Usage: " ++ pname ++ " repl [FILENAME] [FLAGS]\n",+    commandDefaultFlags = defaultReplFlags,+    commandOptions = \showOrParseArgs ->+      optionVerbosity replVerbosity (\v flags -> flags { replVerbosity = v })+      : optionDistPref+          replDistPref (\d flags -> flags { replDistPref = d })+          showOrParseArgs++      : programConfigurationPaths   progConf showOrParseArgs+          replProgramPaths (\v flags -> flags { replProgramPaths = v})++     ++ programConfigurationOption progConf showOrParseArgs+          replProgramArgs (\v flags -> flags { replProgramArgs = v})++     ++ programConfigurationOptions progConf showOrParseArgs+          replProgramArgs (\v flags -> flags { replProgramArgs = v})++     ++ case showOrParseArgs of+          ParseArgs ->+            [ option "" ["reload"]+              "Used from within an interpreter to update files."+              replReload (\v flags -> flags { replReload = v })+              trueArg+            ]+          _ -> []+    }++-- ------------------------------------------------------------ -- * Test flags -- ------------------------------------------------------------ @@ -1287,28 +1520,29 @@     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,+    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],+    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]+    testOptions     :: [PathTemplate]   }  defaultTestFlags :: TestFlags defaultTestFlags  = TestFlags {-    testDistPref  = Flag defaultDistPref,-    testVerbosity = Flag normal,-    testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log",-    testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log",+    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 = []+    testKeepTix     = toFlag False,+    testList        = Flag [],+    testOptions     = []   }  testCommand :: CommandUI TestFlags@@ -1373,24 +1607,24 @@  instance Monoid TestFlags where   mempty = TestFlags {-    testDistPref  = mempty,-    testVerbosity = mempty,-    testHumanLog = mempty,-    testMachineLog = mempty,+    testDistPref    = mempty,+    testVerbosity   = mempty,+    testHumanLog    = mempty,+    testMachineLog  = mempty,     testShowDetails = mempty,-    testKeepTix = mempty,-    testList = mempty,-    testOptions = mempty+    testKeepTix     = mempty,+    testList        = mempty,+    testOptions     = mempty   }   mappend a b = TestFlags {-    testDistPref  = combine testDistPref,-    testVerbosity = combine testVerbosity,-    testHumanLog = combine testHumanLog,-    testMachineLog = combine testMachineLog,+    testDistPref    = combine testDistPref,+    testVerbosity   = combine testVerbosity,+    testHumanLog    = combine testHumanLog,+    testMachineLog  = combine testMachineLog,     testShowDetails = combine testShowDetails,-    testKeepTix = combine testKeepTix,-    testList = combine testList,-    testOptions = combine testOptions+    testKeepTix     = combine testKeepTix,+    testList        = combine testList,+    testOptions     = combine testOptions   }     where combine field = field a `mappend` field b @@ -1401,24 +1635,26 @@ data BenchmarkFlags = BenchmarkFlags {     benchmarkDistPref  :: Flag FilePath,     benchmarkVerbosity :: Flag Verbosity,-    benchmarkOptions :: [PathTemplate]+    benchmarkOptions   :: [PathTemplate]   }  defaultBenchmarkFlags :: BenchmarkFlags defaultBenchmarkFlags  = BenchmarkFlags {     benchmarkDistPref  = Flag defaultDistPref,     benchmarkVerbosity = Flag normal,-    benchmarkOptions = []+    benchmarkOptions   = []   }  benchmarkCommand :: CommandUI BenchmarkFlags-benchmarkCommand = makeCommand name shortDesc longDesc defaultBenchmarkFlags options+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 })+      [ optionVerbosity benchmarkVerbosity+        (\v flags -> flags { benchmarkVerbosity = v })       , optionDistPref             benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d })             showOrParseArgs@@ -1446,12 +1682,12 @@   mempty = BenchmarkFlags {     benchmarkDistPref  = mempty,     benchmarkVerbosity = mempty,-    benchmarkOptions = mempty+    benchmarkOptions   = mempty   }   mappend a b = BenchmarkFlags {     benchmarkDistPref  = combine benchmarkDistPref,     benchmarkVerbosity = combine benchmarkVerbosity,-    benchmarkOptions = combine benchmarkOptions+    benchmarkOptions   = combine benchmarkOptions   }     where combine field = field a `mappend` field b @@ -1467,6 +1703,8 @@      [ programName prog | (prog, _) <- knownPrograms progConf ]   ++ "\n" +-- | For each known program @PROG@ in 'progConf', produce a @with-PROG@+-- 'OptionField'. programConfigurationPaths   :: ProgramConfiguration   -> ShowOrParseArgs@@ -1474,54 +1712,85 @@   -> ([(String, FilePath)] -> (flags -> flags))   -> [OptionField flags] programConfigurationPaths progConf showOrParseArgs get set =+  programConfigurationPaths' ("with-" ++) progConf showOrParseArgs get set++-- | Like 'programConfigurationPaths', but allows to customise the option name.+programConfigurationPaths'+  :: (String -> String)+  -> ProgramConfiguration+  -> ShowOrParseArgs+  -> (flags -> [(String, FilePath)])+  -> ([(String, FilePath)] -> (flags -> flags))+  -> [OptionField flags]+programConfigurationPaths' mkName 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)+    ParseArgs -> map (withProgramPath . programName . fst)+                 (knownPrograms progConf)   where     withProgramPath prog =-      option "" ["with-" ++ prog]+      option "" [mkName prog]         ("give the path to " ++ prog)         get set         (reqArg' "PATH" (\path -> [(prog, path)])           (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) -programConfigurationOptions+-- | For each known program @PROG@ in 'progConf', produce a @PROG-option@+-- 'OptionField'.+programConfigurationOption   :: ProgramConfiguration   -> ShowOrParseArgs   -> (flags -> [(String, [String])])   -> ([(String, [String])] -> (flags -> flags))   -> [OptionField flags]-programConfigurationOptions progConf showOrParseArgs get set =+programConfigurationOption 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)+    ShowArgs  -> [programOption "PROG"]+    ParseArgs -> 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' ]))+           (\progArgs -> concat [ args+                                | (prog', args) <- progArgs, prog==prog' ])) +-- | For each known program @PROG@ in 'progConf', produce a @PROG-options@+-- 'OptionField'.+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"]+    ParseArgs -> map (programOptions . programName . fst)+                 (knownPrograms progConf)+  where+    programOptions prog =+      option "" [prog ++ "-options"]+        ("give extra options to " ++ prog)+        get set+        (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const []))  -- ------------------------------------------------------------ -- * GetOpt Utils -- ------------------------------------------------------------ -boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a+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' :: OptFlags -> OptFlags+            -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a boolOpt' = Command.boolOpt' flagToMaybe Flag  trueArg, falseArg :: SFlags -> LFlags -> Description -> (b -> Flag Bool) ->@@ -1573,6 +1842,7 @@  ++ optFlag' "libdir"      libdir  ++ optFlag' "libexecdir"  libexecdir  ++ optFlag' "datadir"     datadir+ ++ optFlag' "sysconfdir"  sysconfdir  ++ configConfigureArgs flags   where         hc_flag = case (configHcFlavor flags, configHcPath flags) of@@ -1590,13 +1860,15 @@                                                  . config_field                                                  . configInstallDirs) -configureCCompiler :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String])+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 -> ProgramConfiguration -> Program+                 -> IO (FilePath, [String]) configureProg verbosity programConfig prog = do     (p, _) <- requireProgram verbosity prog programConfig     let pInv = programInvocation p []
Distribution/Simple/SrcDist.hs view
@@ -64,6 +64,10 @@   snapshotPackage,   snapshotVersion,   dateToSnapshotNumber,++  -- * Extracting the source files+  listPackageSources+   )  where  import Distribution.PackageDescription@@ -80,67 +84,80 @@          ( Version(versionBranch) ) import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File-         , installOrdinaryFile, installOrdinaryFiles, setFileExecutable+         , installOrdinaryFiles, installMaybeExecutableFiles          , 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.Setup ( Flag(..), SDistFlags(..)+                                 , fromFlag, flagToMaybe)+import Distribution.Simple.PreProcess ( PPSuffixHandler, ppSuffixes+                                      , preprocessComponent )+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(..), withAllComponentsInBuildOrder ) import Distribution.Simple.BuildPaths ( autogenModuleName ) import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram,                               rawSystemProgram, tarProgram ) import Distribution.Text          ( display ) -import Control.Monad(when, unless)+import Control.Monad(when, unless, forM) 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 Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay)+import System.Directory ( doesFileExist )+import System.IO (IOMode(WriteMode), hPutStrLn, withFile) import Distribution.Verbosity (Verbosity) import System.FilePath-         ( (</>), (<.>), takeDirectory, dropExtension, isAbsolute )+         ( (</>), (<.>), dropExtension, isAbsolute )  -- |Create a source distribution.-sdist :: PackageDescription -- ^information from the tarball-      -> Maybe LocalBuildInfo -- ^Information from configure-      -> SDistFlags -- ^verbosity & snapshot+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)+      -> [PPSuffixHandler]      -- ^ extra preprocessors (includes suffixes)       -> IO ()-sdist pkg mb_lbi flags mkTmpDir pps = do+sdist pkg mb_lbi flags mkTmpDir pps = -  -- do some QA-  printPackageProblems verbosity pkg+  -- When given --list-sources, just output the list of sources to a file.+  case (sDistListSources flags) of+    Flag path -> withFile path WriteMode $ \outHandle -> do+      (ordinary, maybeExecutable) <- listPackageSources verbosity pkg pps+                                     DontCreateDefaultSetupScript+      mapM_ (hPutStrLn outHandle) ordinary+      mapM_ (hPutStrLn outHandle) maybeExecutable+      notice verbosity $ "List of package sources written to file '"+                         ++ path ++ "'"+    NoFlag    -> do+      -- do some QA+      printPackageProblems verbosity pkg -  when (isNothing mb_lbi) $-    warn verbosity "Cannot run preprocessors. Run 'configure' command first."+      when (isNothing mb_lbi) $+        warn verbosity "Cannot run preprocessors. Run 'configure' command first." -  date <- toCalendarTime =<< getClockTime-  let pkg' | snapshot  = snapshotPackage date pkg-           | otherwise = pkg+      date <- getCurrentTime+      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+      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+        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+      prepareTree verbosity pkg' mb_lbi targetDir pps       when snapshot $         overwriteSnapshotPackageDesc verbosity pkg' targetDir @@ -151,136 +168,205 @@     targetPref   = distPref     tmpTargetDir = mkTmpDir distPref +-- | Should a default @Setup.hs@ be created if none exists? We do this in+-- @sdist@, but not in @sdist --list-sources@.+data CreateDefaultSetupScript = CreateDefaultSetupScript+                              | DontCreateDefaultSetupScript --- |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+-- | List all source files of a package. Returns a tuple of lists: first+-- component is a list of ordinary files, second one is a list of those files+-- that may be executable.+listPackageSources :: Verbosity          -- ^ verbosity+                   -> PackageDescription -- ^ info from the cabal file+                   -> [PPSuffixHandler]  -- ^ extra preprocessors (include+                                         -- suffixes)+                   -> CreateDefaultSetupScript   -- ^ create a default+                                                 -- @Setup.hs@ ?+                   -> IO ([FilePath], [FilePath])+listPackageSources verbosity pkg_descr0 pps createSetup = do+  -- Call helpers that actually do all work.+  ordinary        <- listPackageSourcesOrdinary        verbosity pkg_descr pps+                                                       createSetup+  maybeExecutable <- listPackageSourcesMaybeExecutable pkg_descr+  return (ordinary, maybeExecutable)+  where+    pkg_descr = filterAutogenModule pkg_descr0 -  -- maybe move the library files into place-  withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->-    prepareDir verbosity pkg_descr distPref targetDir pps modules libBi+-- | List those source files that may be executable (e.g. the configure script).+listPackageSourcesMaybeExecutable :: PackageDescription -> IO [FilePath]+listPackageSourcesMaybeExecutable pkg_descr =+  -- Extra source files.+  fmap concat . forM (extraSrcFiles pkg_descr) $ \fpath -> matchFileGlob fpath -  -- 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+-- | List those source files that should be copied with ordinary permissions.+listPackageSourcesOrdinary :: Verbosity+                           -> PackageDescription+                           -> [PPSuffixHandler]+                           -> CreateDefaultSetupScript+                           -> IO [FilePath]+listPackageSourcesOrdinary verbosity pkg_descr pps createSetup =+  fmap concat . sequence $+  [+    -- Library sources.+    withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->+     allSourcesBuildInfo libBi pps modules -  -- 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+    -- Executables sources.+  , fmap concat+    . withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do+       biSrcs  <- allSourcesBuildInfo exeBi pps []+       mainSrc <- findMainExeFile exeBi pps mainPath+       return (mainSrc:biSrcs) -  -- 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+    -- Test suites sources.+  , fmap concat+    . withTest $ \t -> do+       let bi  = testBuildInfo t+       case testInterface t of+         TestSuiteExeV10 _ mainPath -> do+           biSrcs <- allSourcesBuildInfo bi pps []+           srcMainFile <- do+             ppFile <- findFileWithExtension (ppSuffixes pps)+                       (hsSourceDirs bi) (dropExtension mainPath)+             case ppFile of+               Nothing -> findFile (hsSourceDirs bi) mainPath+               Just pp -> return pp+           return (srcMainFile:biSrcs)+         TestSuiteLibV09 _ m ->+           allSourcesBuildInfo bi pps [m]+         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 ]+    -- Benchmarks sources.+  , fmap concat+    . withBenchmark $ \bm -> do+       let  bi = benchmarkBuildInfo bm+       case benchmarkInterface bm of+         BenchmarkExeV10 _ mainPath -> do+           biSrcs <- allSourcesBuildInfo bi pps []+           srcMainFile <- do+             ppFile <- findFileWithExtension (ppSuffixes pps)+                       (hsSourceDirs bi) (dropExtension mainPath)+             case ppFile of+               Nothing -> findFile (hsSourceDirs bi) mainPath+               Just pp -> return pp+           return (srcMainFile:biSrcs)+         BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: "+                                    ++ show tp -  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 ]+    -- Data files.+  , fmap concat+    . forM (dataFiles pkg_descr) $ \filename ->+       matchFileGlob (dataDir pkg_descr </> filename) -  -- 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+    -- License file.+  , return $ case [licenseFile pkg_descr]+             of [[]] -> []+                l    -> l+    -- Install-include files.+  , withLib $ \ l -> do+       let lbi = libBuildInfo l+           relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)+       mapM (fmap snd . findIncludeFile relincdirs) (installIncludes lbi) -  -- if the package was configured then we can run platform independent-  -- pre-processors and include those generated files+    -- Setup script.+  , do mSetupFile <- findSetupFile+       case mSetupFile of+         Just setupFile -> return [setupFile]+         Nothing        -> case createSetup of+           DontCreateDefaultSetupScript -> return []+           CreateDefaultSetupScript     -> do+             writeUTF8File "Setup.hs" $ unlines [+               "import Distribution.Simple",+               "main = defaultMain"]+             return ["Setup.hs"]++    -- The .cabal file itself.+  , fmap (\d -> [d]) (defaultPackageDesc verbosity)++  ]+  where+    -- 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.+prepareTree :: Verbosity          -- ^verbosity+            -> PackageDescription -- ^info from the cabal file+            -> Maybe LocalBuildInfo+            -> FilePath           -- ^source tree to populate+            -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)+            -> IO ()+prepareTree verbosity pkg_descr0 mb_lbi targetDir pps = do+  -- If the package was configured then we can run platform independent+  -- 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 _ ->+      let lbi' = lbi{ buildDir = targetDir </> buildDir lbi }+      withAllComponentsInBuildOrder 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)+  (ordinary, mExecutable)  <- listPackageSources verbosity pkg_descr0 pps+                              CreateDefaultSetupScript+  installOrdinaryFiles        verbosity targetDir (zip (repeat []) ordinary)+  installMaybeExecutableFiles verbosity targetDir (zip (repeat []) mExecutable)    where-    pkg_descr = mapAllBuildInfo filterAutogenModule pkg_descr0-    filterAutogenModule bi = bi {-      otherModules = filter (/=autogenModule) (otherModules bi)-    }-    autogenModule = autogenModuleName pkg_descr0+    pkg_descr = filterAutogenModule 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+-- | Find the setup script file, if it exists.+findSetupFile :: IO (Maybe FilePath)+findSetupFile = do+  hsExists <- doesFileExist setupHs+  lhsExists <- doesFileExist setupLhs+  if hsExists+    then return (Just setupHs)+    else if lhsExists+         then return (Just setupLhs)+         else return Nothing+    where+      setupHs  = "Setup.hs"+      setupLhs = "Setup.lhs" -    -- 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)+-- | Find the main executable file.+findMainExeFile :: BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath+findMainExeFile exeBi pps mainPath = do+  ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi)+            (dropExtension mainPath)+  case ppFile of+    Nothing -> findFile (hsSourceDirs exeBi) mainPath+    Just pp -> return pp +-- | Given a list of include paths, try to find the include file named+-- @f@. Return the name of the file and the full path, or exit with error if+-- there's no such file.+findIncludeFile :: [FilePath] -> String -> IO (String, FilePath)+findIncludeFile [] f = die ("can't find include file " ++ f)+findIncludeFile (d:ds) f = do+  let path = (d </> f)+  b <- doesFileExist path+  if b then return (f,path) else findIncludeFile ds f++-- | Remove the auto-generated module ('Paths_*') from 'exposed-modules' and+-- 'other-modules'.+filterAutogenModule :: PackageDescription -> PackageDescription+filterAutogenModule pkg_descr0 = mapLib filterAutogenModuleLib $+                                 mapAllBuildInfo filterAutogenModuleBI pkg_descr0+  where+    mapLib f pkg = pkg { library = fmap f (library pkg) }+    filterAutogenModuleLib lib = lib {+      exposedModules = filter (/=autogenModule) (exposedModules lib)+    }+    filterAutogenModuleBI bi = bi {+      otherModules   = filter (/=autogenModule) (otherModules bi)+    }+    autogenModule = autogenModuleName pkg_descr0+ -- | 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'.@@ -288,12 +374,12 @@ prepareSnapshotTree :: Verbosity          -- ^verbosity                     -> PackageDescription -- ^info from the cabal file                     -> Maybe LocalBuildInfo-                    -> FilePath           -- ^dist dir                     -> FilePath           -- ^source tree to populate-                    -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)+                    -> [PPSuffixHandler]  -- ^extra preprocessors (includes+                                          -- suffixes)                     -> IO ()-prepareSnapshotTree verbosity pkg mb_lbi distPref targetDir pps = do-  prepareTree verbosity pkg mb_lbi distPref targetDir pps+prepareSnapshotTree verbosity pkg mb_lbi targetDir pps = do+  prepareTree verbosity pkg mb_lbi targetDir pps   overwriteSnapshotPackageDesc verbosity pkg targetDir  overwriteSnapshotPackageDesc :: Verbosity          -- ^verbosity@@ -318,7 +404,7 @@ -- | Modifies a 'PackageDescription' by appending a snapshot number -- corresponding to the given date. ---snapshotPackage :: CalendarTime -> PackageDescription -> PackageDescription+snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription snapshotPackage date pkg =   pkg {     package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) }@@ -328,7 +414,7 @@ -- | Modifies a 'Version' by appending a snapshot number corresponding -- to the given date. ---snapshotVersion :: CalendarTime -> Version -> Version+snapshotVersion :: UTCTime -> Version -> Version snapshotVersion date version = version {     versionBranch = versionBranch version                  ++ [dateToSnapshotNumber date]@@ -337,70 +423,62 @@ -- | 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+dateToSnapshotNumber :: UTCTime -> Int+dateToSnapshotNumber date = case toGregorian (utctDay date) of+                            (year, month, day) ->+                                fromIntegral year * 10000+                              + month             * 100+                              + day --- |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+-- | Callback type for use by sdistWith.+type CreateArchiveFun = 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 +-- | Create an archive from a tree of source files, and clean up the tree.+createArchive :: CreateArchiveFun 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.]+   -- 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 ]+-- | Given a buildinfo, return the names of all source files.+allSourcesBuildInfo :: BuildInfo+                       -> [PPSuffixHandler] -- ^ Extra preprocessors+                       -> [ModuleName]      -- ^ Exposed modules+                       -> IO [FilePath]+allSourcesBuildInfo bi pps modules = 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)+  return $ sources ++ catMaybes bootFiles ++ cSources bi -    where suffixes = ppSuffixes pps ++ ["hs", "lhs"]-          notFound m = die $ "Error: Could not find module: " ++ display m-                          ++ " with any suffix: " ++ show suffixes+  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
Distribution/Simple/Test.hs view
@@ -71,13 +71,13 @@ import qualified Distribution.Simple.LocalBuildInfo as LBI     ( LocalBuildInfo(..) ) import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag )-import Distribution.Simple.Utils ( die, notice )+import Distribution.Simple.Utils ( die, notice, rawSystemIOWithEnv ) import Distribution.TestSuite     ( OptionDescr(..), Options, Progress(..), Result(..), TestInstance(..)     , Test(..) ) import Distribution.Text import Distribution.Verbosity ( normal, Verbosity )-import Distribution.System ( buildPlatform, Platform )+import Distribution.System ( Platform )  import Control.Exception ( bracket ) import Control.Monad ( when, unless, filterM )@@ -86,12 +86,11 @@ import System.Directory     ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist     , getCurrentDirectory, getDirectoryContents, removeDirectoryRecursive-    , removeFile )-import System.Environment ( getEnvironment )+    , removeFile, setCurrentDirectory )+import Distribution.Compat.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.@@ -108,7 +107,7 @@ localPackageLog pkg_descr lbi = PackageLog     { package = PD.package pkg_descr     , compiler = compilerId $ LBI.compiler lbi-    , platform = buildPlatform+    , platform = LBI.hostPlatform lbi     , testSuites = []     } @@ -191,10 +190,10 @@     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+        shellEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)+                   : ("HPCTIXFILE", (</>) pwd+                       $ tixFilePath distPref $ PD.testName suite)+                   : existingEnv      bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog ->         bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do@@ -223,10 +222,9 @@             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+              -- these handles get closed by rawSystemIOWithEnv+              rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv)+                                 (Just hIn) (Just hLog) (Just hLog)              -- Generate TestSuiteLog from executable exit code and a machine-             -- readable test log@@ -432,6 +430,7 @@     where         env = initialPathTemplateEnv                 (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)+                (LBI.hostPlatform lbi)                 ++  [ (TestSuiteNameVar, toPathTemplate $ testSuiteName testLog)                     , (TestSuiteResultVar, result)                     ]@@ -448,7 +447,8 @@     fromPathTemplate $ substPathTemplate env template   where     env = initialPathTemplateEnv-          (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) +++          (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)+          (LBI.hostPlatform lbi) ++           [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]  packageLogPath :: PathTemplate@@ -460,6 +460,7 @@     where         env = initialPathTemplateEnv                 (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)+                (LBI.hostPlatform lbi)  -- | The filename of the source file for the stub executable associated with a -- library 'TestSuite'.@@ -498,7 +499,10 @@ stubMain :: IO [Test] -> IO () stubMain tests = do     (f, n) <- fmap read getContents-    tests >>= stubRunTests >>= stubWriteLog f n+    dir <- getCurrentDirectory+    results <- tests >>= stubRunTests+    setCurrentDirectory dir+    stubWriteLog f n results  -- | The test runner used in library "TestSuite" stub executables.  Runs a list -- of 'Test's.  An executable calling this function is meant to be invoked as@@ -541,4 +545,3 @@     when (suiteError testLog) $ exitWith $ ExitFailure 2     when (suiteFailed testLog) $ exitWith $ ExitFailure 1     exitWith ExitSuccess-
Distribution/Simple/UHC.hs view
@@ -69,12 +69,13 @@ import Language.Haskell.Extension import System.Directory import System.FilePath+import Distribution.System ( Platform )  -- ----------------------------------------------------------------------------- -- Configuring  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)+          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath _hcPkgPath conf = do    (_uhcProg, uhcVersion, conf') <-@@ -83,11 +84,12 @@     (userMaybeSpecifyPath "uhc" hcPath conf)    let comp = Compiler {-               compilerId          =  CompilerId UHC uhcVersion,-               compilerLanguages   =  uhcLanguages,-               compilerExtensions  =  uhcLanguageExtensions+               compilerId         =  CompilerId UHC uhcVersion,+               compilerLanguages  =  uhcLanguages,+               compilerExtensions =  uhcLanguageExtensions              }-  return (comp, conf')+      compPlatform = Nothing+  return (comp, compPlatform, conf')  uhcLanguages :: [(Language, C.Flag)] uhcLanguages = [(Haskell98, "")]
Distribution/Simple/UserHooks.hs view
@@ -64,7 +64,7 @@ import Distribution.Simple.Command    (noExtraFlags) import Distribution.Simple.PreProcess (PPSuffixHandler) import Distribution.Simple.Setup-         (ConfigFlags, BuildFlags, CleanFlags, CopyFlags,+         (ConfigFlags, BuildFlags, ReplFlags, CleanFlags, CopyFlags,           InstallFlags, SDistFlags, RegisterFlags, HscolourFlags,           HaddockFlags, TestFlags, BenchmarkFlags) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo)@@ -105,6 +105,13 @@     -- |Hook to run after build command.  Second arg indicates verbosity level.     postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (), +    -- |Hook to run before repl command.  Second arg indicates verbosity level.+    preRepl  :: Args -> ReplFlags -> IO HookedBuildInfo,+    -- |Over-ride this hook to get different behavior during interpretation.+    replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO (),+    -- |Hook to run after repl command.  Second arg indicates verbosity level.+    postRepl :: Args -> ReplFlags -> 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.@@ -144,7 +151,7 @@      -- |Hook to run before unregister command     preUnreg  :: Args -> RegisterFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during registration.+    -- |Over-ride this hook to get different behavior during unregistration.     unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (),     -- |Hook to run after unregister command     postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (),@@ -191,9 +198,12 @@       preConf   = rn,       confHook  = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")),       postConf  = ru,-      preBuild  = rn,+      preBuild  = rn',       buildHook = ru,       postBuild = ru,+      preRepl   = \_ _ -> return emptyHookedBuildInfo,+      replHook  = \_ _ _ _ _ -> return (),+      postRepl  = ru,       preClean  = rn,       cleanHook = ru,       postClean = ru,@@ -218,14 +228,13 @@       preHaddock   = rn,       haddockHook  = ru,       postHaddock  = ru,-      preTest = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without-                                                     -- noExtraFlags+      preTest  = rn',       testHook = ru,       postTest = ru,-      preBench = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without-                                                      -- noExtraFlags+      preBench = rn',       benchHook = \_ -> ru,       postBench = ru     }-    where rn args  _ = noExtraFlags args >> return emptyHookedBuildInfo+    where rn  args _ = noExtraFlags args >> return emptyHookedBuildInfo+          rn' _    _ = return emptyHookedBuildInfo           ru _ _ _ _ = return ()
Distribution/Simple/Utils.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp -fffi #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Utils@@ -52,9 +50,9 @@         -- * logging and errors         die,         dieWithLocation,-        topHandler,+        topHandler, topHandlerWith,         warn, notice, setupMessage, info, debug,-        chattyTry,+        debugNoWrap, chattyTry,          -- * running programs         rawSystemExit,@@ -62,6 +60,7 @@         rawSystemExitWithEnv,         rawSystemStdout,         rawSystemStdInOut,+        rawSystemIOWithEnv,         maybeExit,         xargs,         findProgramLocation,@@ -73,11 +72,15 @@         copyFileVerbose,         copyDirectoryRecursiveVerbose,         copyFiles,+        copyFileTo,          -- * installing files         installOrdinaryFile,         installExecutableFile,+        installMaybeExecutableFile,         installOrdinaryFiles,+        installExecutableFiles,+        installMaybeExecutableFiles,         installDirectoryContents,          -- * File permissions@@ -96,15 +99,22 @@         findModuleFiles,         getDirectoryContentsRecursive, +        -- * environment variables+        isInSearchPath,+         -- * simple file globbing         matchFileGlob,         matchDirFileGlob,         parseFileGlob,         FileGlob(..), +        -- * modification time+        moreRecentFile,+         -- * temp files and dirs-        withTempFile,-        withTempDirectory,+        TempFileOptions(..), defaultTempFileOptions,+        withTempFile, withTempFileEx,+        withTempDirectory, withTempDirectoryEx,          -- * .cabal and .buildinfo files         defaultPackageDesc,@@ -137,41 +147,40 @@  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 )+  ( nub, unfoldr, isPrefixOf, tails, intercalate ) 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 )+    ( Permissions(executable), getDirectoryContents, getPermissions+    , doesDirectoryExist, doesFileExist, removeFile, findExecutable+    , getModificationTime ) import System.Environment     ( getProgName )-import System.Cmd-    ( rawSystem ) import System.Exit     ( exitWith, ExitCode(..) ) import System.FilePath-    ( normalise, (</>), (<.>), takeDirectory, splitFileName+    ( normalise, (</>), (<.>)+    , getSearchPath, takeDirectory, splitFileName     , splitExtension, splitExtensions, splitDirectories ) import System.Directory     ( createDirectory, renameFile, removeDirectoryRecursive ) import System.IO-    ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode+    ( 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@@ -185,24 +194,22 @@ import Distribution.Version     (Version(..)) -import Control.Exception (evaluate)-import System.Process (runProcess)+import Control.Exception (IOException, evaluate, throwIO)+import System.Process (rawSystem, runProcess) -#ifdef __GLASGOW_HASKELL__ import Control.Concurrent (forkIO) import System.Process (runInteractiveProcess, waitForProcess)-#else-import System.Cmd (system)-import System.Directory (getTemporaryDirectory)+#if __GLASGOW_HASKELL__ >= 702+import System.Process (showCommandForUser) #endif  import Distribution.Compat.CopyFile          ( copyFile, copyOrdinaryFile, copyExecutableFile          , setFileOrdinary, setFileExecutable, setDirOrdinary ) import Distribution.Compat.TempFile-         ( openTempFile, openNewBinaryFile, createTempDirectory )+         ( openTempFile, createTempDirectory ) import Distribution.Compat.Exception-         ( IOException, throwIOIO, tryIO, catchIO, catchExit, onException )+         ( tryIO, catchIO, catchExit ) import Distribution.Verbosity  #ifdef VERSION_base@@ -228,38 +235,33 @@           . 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+topHandlerWith :: (Exception.IOException -> IO a) -> IO a -> IO a+topHandlerWith cont prog = catchIO prog handle   where     handle ioe = do       hFlush stdout       pname <- getProgName       hPutStr stderr (mesage pname)-      exitWith (ExitFailure 1)+      cont ioe       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 +topHandler :: IO a -> IO a+topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog+ -- | Non fatal conditions that may be indicative of an error or problem. -- -- We display these at the 'normal' verbosity level.@@ -305,6 +307,14 @@     putStr (wrapText msg)     hFlush stdout +-- | A variant of 'debug' that doesn't perform the automatic line+-- wrapping. Produces better output in some cases.+debugNoWrap :: Verbosity -> String -> IO ()+debugNoWrap verbosity msg =+  when (verbosity >= deafening) $ do+    putStrLn 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@@ -320,9 +330,10 @@ -- | Wraps text to the default line width. Existing newlines are preserved. wrapText :: String -> String wrapText = unlines-         . concatMap (map unwords-                    . wrapLine 79-                    . words)+         . map (intercalate "\n"+              . map unwords+              . wrapLine 79+              . words)          . lines  -- | Wraps a list of words to a list of lines of words of a particular width.@@ -351,7 +362,12 @@ printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () printRawCommandAndArgs verbosity path args  | verbosity >= deafening = print (path, args)- | verbosity >= verbose   = putStrLn $ unwords (path : args)+ | verbosity >= verbose   =+#if __GLASGOW_HASKELL__ >= 702+                            putStrLn $ showCommandForUser path args+#else+                            putStrLn $ unwords (path : args)+#endif  | otherwise              = return ()  printRawCommandAndArgsAndEnv :: Verbosity@@ -398,6 +414,26 @@         debug verbosity $ path ++ " returned " ++ show exitcode         exitWith exitcode +-- Closes the passed in handles before returning.+rawSystemIOWithEnv :: Verbosity+                   -> FilePath+                   -> [String]+                   -> Maybe FilePath           -- ^ New working dir or inherit+                   -> Maybe [(String, String)] -- ^ New environment or inherit+                   -> Maybe Handle  -- ^ stdin+                   -> Maybe Handle  -- ^ stdout+                   -> Maybe Handle  -- ^ stderr+                   -> IO ExitCode+rawSystemIOWithEnv verbosity path args mcwd menv inp out err = do+    maybe (printRawCommandAndArgs       verbosity path args)+          (printRawCommandAndArgsAndEnv verbosity path args) menv+    hFlush stdout+    ph <- runProcess path args mcwd menv inp out err+    exitcode <- waitForProcess ph+    unless (exitcode == ExitSuccess) $ do+      debug verbosity $ path ++ " returned " ++ show exitcode+    return exitcode+ -- | Run a command and return its output. -- -- The output is assumed to be text in the locale encoding.@@ -405,6 +441,7 @@ rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String rawSystemStdout verbosity path args = do   (output, errors, exitCode) <- rawSystemStdInOut verbosity path args+                                                  Nothing Nothing                                                   Nothing False   when (exitCode /= ExitSuccess) $     die errors@@ -415,16 +452,18 @@ -- mode of the input and output. -- rawSystemStdInOut :: Verbosity-                  -> FilePath -> [String]-                  -> Maybe (String, Bool) -- ^ input text and binary mode-                  -> Bool                 -- ^ output in binary mode+                  -> FilePath                 -- ^ Program location+                  -> [String]                 -- ^ Arguments+                  -> Maybe FilePath           -- ^ New working dir or inherit+                  -> Maybe [(String, String)] -- ^ New environment or inherit+                  -> 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+rawSystemStdInOut verbosity path args mcwd menv input outputBinary = do   printRawCommandAndArgs verbosity path args -#ifdef __GLASGOW_HASKELL__   Exception.bracket-     (runInteractiveProcess path args Nothing Nothing)+     (runInteractiveProcess path args mcwd menv)      (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)     $ \(inh,outh,errh,pid) -> do @@ -467,37 +506,14 @@         debug verbosity $ path ++ " returned " ++ show exitcode                        ++ if null err then "" else                           " with error message:\n" ++ err+                       ++ case input of+                            Nothing       -> ""+                            Just ("",  _) -> ""+                            Just (inp, _) -> "\nstdin input:\n" ++ inp        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@@ -670,6 +686,13 @@         ignore ['.', '.'] = True         ignore _          = False +------------------------+-- Environment variables++-- | Is this directory in the system search path?+isInSearchPath :: FilePath -> IO Bool+isInSearchPath path = fmap (elem path) getSearchPath+ ---------------- -- File globbing @@ -712,6 +735,23 @@                     ++ "' does not match any files."       matches -> return matches +--------------------+-- Modification time++-- | Compare the modification times of two files to see if the first is newer+-- than the second. The first file must exist but the second need not.+-- The expected use case is when the second file is generated using the first.+-- In this use case, if the result is True then the second file is out of date.+--+moreRecentFile :: FilePath -> FilePath -> IO Bool+moreRecentFile a b = do+  exists <- doesFileExist b+  if not exists+    then return True+    else do tb <- getModificationTime b+            ta <- getModificationTime a+            return (ta > tb)+ ---------------------------------------- -- Copying and installing files and dirs @@ -728,11 +768,11 @@     parents = reverse . scanl1 (</>) . splitDirectories . normalise      createDirs []         = return ()-    createDirs (dir:[])   = createDir dir throwIOIO+    createDirs (dir:[])   = createDir dir throwIO     createDirs (dir:dirs) =       createDir dir $ \_ -> do         createDirs dirs-        createDir dir throwIOIO+        createDir dir throwIO      createDir :: FilePath -> (IOException -> IO ()) -> IO ()     createDir dir notExistHandler = do@@ -751,9 +791,9 @@           | isAlreadyExistsError e -> (do               isDir <- doesDirectoryExist dir               if isDir then return ()-                       else throwIOIO e+                       else throwIO e               ) `catchIO` ((\_ -> return ()) :: IOException -> IO ())-          | otherwise              -> throwIOIO e+          | otherwise              -> throwIO e  createDirectoryVerbose :: Verbosity -> FilePath -> IO () createDirectoryVerbose verbosity dir = do@@ -789,6 +829,38 @@   info verbosity ("Installing executable " ++ src ++ " to " ++ dest)   copyExecutableFile src dest +-- | Install a file that may or not be executable, preserving permissions.+installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()+installMaybeExecutableFile verbosity src dest = do+  perms <- getPermissions src+  if (executable perms) --only checks user x bit+    then installExecutableFile verbosity src dest+    else installOrdinaryFile   verbosity src dest++-- | Given a relative path to a file, copy it to the given directory, preserving+-- the relative path and creating the parent directories if needed.+copyFileTo :: Verbosity -> FilePath -> FilePath -> IO ()+copyFileTo verbosity dir file = do+  let targetFile = dir </> file+  createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)+  installOrdinaryFile verbosity file targetFile++-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',+-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.+copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ())+              -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()+copyFilesWith doCopy 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 doCopy verbosity src dest+            | (srcBase, srcFile) <- srcFiles ]+ -- | 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.@@ -811,32 +883,24 @@ -- 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 ]+copyFiles = copyFilesWith copyFileVerbose  -- | This is like 'copyFiles' but uses 'installOrdinaryFile'. -- installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()-installOrdinaryFiles verbosity targetDir srcFiles = do+installOrdinaryFiles = copyFilesWith installOrdinaryFile -  -- Create parent directories for everything-  let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles-  mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs+-- | This is like 'copyFiles' but uses 'installExecutableFile'.+--+installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]+                          -> IO ()+installExecutableFiles = copyFilesWith installExecutableFile -  -- Copy all the files-  sequence_ [ let src  = srcBase   </> srcFile-                  dest = targetDir </> srcFile-               in installOrdinaryFile verbosity src dest-            | (srcBase, srcFile) <- srcFiles ]+-- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'.+--+installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]+                               -> IO ()+installMaybeExecutableFiles = copyFilesWith installMaybeExecutableFile  -- | This installs all the files in a directory to a target location, -- preserving the directory layout. All the files are assumed to be ordinary@@ -870,15 +934,33 @@ --------------------------- -- Temporary files and dirs +-- | Advanced options for 'withTempFile' and 'withTempDirectory'.+data TempFileOptions = TempFileOptions {+  optKeepTempFiles :: Bool  -- ^ Keep temporary files?+  }++defaultTempFileOptions :: TempFileOptions+defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False }+ -- | 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 :: FilePath    -- ^ Temp dir to create the file in+                -> String   -- ^ File name template. See 'openTempFile'.+                -> (FilePath -> Handle -> IO a) -> IO a withTempFile tmpDir template action =+  withTempFileEx defaultTempFileOptions tmpDir template action++-- | A version of 'withTempFile' that additionally takes a 'TempFileOptions'+-- argument.+withTempFileEx :: TempFileOptions+                 -> FilePath -- ^ Temp dir to create the file in+                 -> String   -- ^ File name template. See 'openTempFile'.+                 -> (FilePath -> Handle -> IO a) -> IO a+withTempFileEx opts tmpDir template action =   Exception.bracket     (openTempFile tmpDir template)-    (\(name, handle) -> hClose handle >> removeFile name)+    (\(name, handle) -> do hClose handle+                           unless (optKeepTempFiles opts) $ removeFile name)     (uncurry action)  -- | Create and use a temporary directory.@@ -891,11 +973,20 @@ -- The @tmpDir@ will be a new subdirectory of the given directory, e.g. -- @src/sdist.342@. ---withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a-withTempDirectory _verbosity targetDir template =+withTempDirectory :: Verbosity+                     -> FilePath -> String -> (FilePath -> IO a) -> IO a+withTempDirectory verbosity targetDir template =+  withTempDirectoryEx verbosity defaultTempFileOptions targetDir template++-- | A version of 'withTempDirectory' that additionally takes a+-- 'TempFileOptions' argument.+withTempDirectoryEx :: Verbosity+                       -> TempFileOptions+                       -> FilePath -> String -> (FilePath -> IO a) -> IO a+withTempDirectoryEx _verbosity opts targetDir template =   Exception.bracket     (createTempDirectory targetDir template)-    (removeDirectoryRecursive)+    (unless (optKeepTempFiles opts) . removeDirectoryRecursive)  ----------------------------------- -- Safely reading and writing files@@ -918,21 +1009,16 @@ -- 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+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@@ -944,9 +1030,10 @@     existingContent <- readFile path     _ <- evaluate (length existingContent)     unless (existingContent == newContent) $-      writeFileAtomic path newContent+      writeFileAtomic path (BS.Char8.pack newContent)   where-    mightNotExist e | isDoesNotExistError e = writeFileAtomic path newContent+    mightNotExist e | isDoesNotExistError e = writeFileAtomic path+                                              (BS.Char8.pack newContent)                     | otherwise             = ioError e  -- | The path name that represents the current directory.@@ -1112,7 +1199,7 @@ -- Uses 'writeFileAtomic', so provides the same guarantees. -- writeUTF8File :: FilePath -> String -> IO ()-writeUTF8File path = writeFileAtomic path . toUTF8+writeUTF8File path = writeFileAtomic path . BS.Char8.pack . toUTF8  -- | Fix different systems silly line ending conventions normaliseLineEndings :: String -> String@@ -1133,9 +1220,6 @@  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
Distribution/System.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.System@@ -25,11 +26,15 @@   -- * Platform is a pair of arch and OS   Platform(..),   buildPlatform,+  platformFromTriple   ) where  import qualified System.Info (os, arch) import qualified Data.Char as Char (toLower, isAlphaNum) +import Data.Data (Data)+import Data.Typeable (Typeable)+import Data.Maybe (fromMaybe, listToMaybe) import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp@@ -58,12 +63,13 @@ -- * Operating System -- ------------------------------------------------------------ -data OS = Linux | Windows | OSX        -- teir 1 desktop OSs+data OS = Linux | Windows | OSX        -- tier 1 desktop OSs         | FreeBSD | OpenBSD | NetBSD   -- other free unix OSs         | Solaris | AIX | HPUX | IRIX  -- ageing Unix OSs         | HaLVM                        -- bare metal / VMs / hypervisors+        | IOS                          -- iOS         | OtherOS String-  deriving (Eq, Ord, Show, Read)+  deriving (Eq, Ord, Show, Read, Typeable, Data)  --TODO: decide how to handle Android and iOS. -- They are like Linux and OSX but with some differences.@@ -74,12 +80,14 @@ knownOSs = [Linux, Windows, OSX            ,FreeBSD, OpenBSD, NetBSD            ,Solaris, AIX, HPUX, IRIX-           ,HaLVM]+           ,HaLVM+           ,IOS]  osAliases :: ClassificationStrictness -> OS -> [String] osAliases Permissive Windows = ["mingw32", "cygwin32"] osAliases Compat     Windows = ["mingw32", "win32"] osAliases _          OSX     = ["darwin"]+osAliases _          IOS     = ["ios"] osAliases Permissive FreeBSD = ["kfreebsdgnu"] osAliases Permissive Solaris = ["solaris2"] osAliases _          _       = []@@ -92,9 +100,7 @@  classifyOS :: ClassificationStrictness -> String -> OS classifyOS strictness s =-  case lookup (lowercase s) osMap of-    Just os -> os-    Nothing -> OtherOS s+  fromMaybe (OtherOS s) $ lookup (lowercase s) osMap   where     osMap = [ (name, os)             | os <- knownOSs@@ -113,7 +119,7 @@           | Alpha | Hppa   | Rs6000           | M68k  | Vax           | OtherArch String-  deriving (Eq, Ord, Show, Read)+  deriving (Eq, Ord, Show, Read, Typeable, Data)  knownArches :: [Arch] knownArches = [I386, X86_64, PPC, PPC64, Sparc@@ -140,9 +146,7 @@  classifyArch :: ClassificationStrictness -> String -> Arch classifyArch strictness s =-  case lookup (lowercase s) archMap of-    Just arch -> arch-    Nothing   -> OtherArch s+  fromMaybe (OtherArch s) $ lookup (lowercase s) archMap   where     archMap = [ (name, arch)               | arch <- knownArches@@ -156,7 +160,7 @@ -- ------------------------------------------------------------  data Platform = Platform Arch OS-  deriving (Eq, Ord, Show, Read)+  deriving (Eq, Ord, Show, Read, Typeable, Data)  instance Text Platform where   disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os@@ -166,6 +170,9 @@     os   <- parse     return (Platform arch os) +-- | The platform Cabal was compiled on. In most cases,+-- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're+-- targeting). buildPlatform :: Platform buildPlatform = Platform buildArch buildOS @@ -177,3 +184,16 @@  lowercase :: String -> String lowercase = map Char.toLower++platformFromTriple :: String -> Maybe Platform+platformFromTriple triple =+  fmap fst (listToMaybe $ Parse.readP_to_S parseTriple triple)+  where parseWord = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_')+        parseTriple = do+          arch <- fmap (classifyArch Strict) parseWord+          _ <- Parse.char '-'+          _ <- parseWord -- Skip vendor+          _ <- Parse.char '-'+          os <- fmap (classifyOS Compat) ident -- OS may have hyphens, like+                                               -- 'nto-qnx'+          return $ Platform arch os
Distribution/Version.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Version@@ -91,6 +92,8 @@   ) where +import Data.Data        ( Data )+import Data.Typeable    ( Typeable ) import Data.Version     ( Version(..) )  import Distribution.Text ( Text(..) )@@ -116,8 +119,11 @@   | UnionVersionRanges     VersionRange VersionRange   | IntersectVersionRanges VersionRange VersionRange   | VersionRangeParens     VersionRange -- just '(exp)' parentheses syntax-  deriving (Show,Read,Eq)+  deriving (Show,Read,Eq,Typeable,Data) +-- TODO orphan+deriving instance Data Version+ {-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} {-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} {-# DEPRECATED LaterVersion "use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}@@ -408,7 +414,7 @@ --  wildcardUpperBound :: Version -> Version-wildcardUpperBound (Version lowerBound ts) = (Version upperBound ts)+wildcardUpperBound (Version lowerBound ts) = Version upperBound ts   where     upperBound = init lowerBound ++ [last lowerBound + 1]
Language/Haskell/Extension.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Language.Haskell.Extension@@ -53,6 +54,8 @@ import qualified Text.PrettyPrint as Disp import qualified Data.Char as Char (isAlphaNum) import Data.Array (Array, accumArray, bounds, Ix(inRange), (!))+import Data.Data (Data)+import Data.Typeable (Typeable)  -- ------------------------------------------------------------ -- * Language@@ -75,7 +78,7 @@    -- | An unknown language, identified by its name.   | UnknownLanguage String-  deriving (Show, Read, Eq)+  deriving (Show, Read, Eq, Typeable, Data)  knownLanguages :: [Language] knownLanguages = [Haskell98, Haskell2010]@@ -110,8 +113,7 @@ -- 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.+-- official documentation.  data Extension =   -- | Enable a known extension@@ -124,261 +126,399 @@   -- pragma.   | UnknownExtension String -  deriving (Show, Read, Eq)+  deriving (Show, Read, Eq, Typeable, Data)  data KnownExtension = -  -- | [GHC &#xa7; 7.6.3.4] Allow overlapping class instances,-  -- provided there is a unique most specific instance for each use.+  -- | Allow overlapping class instances, provided there is a unique+  -- most specific instance for each use.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-overlap>     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.+  -- | 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.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#undecidable-instances>   | 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.+  -- | 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.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-overlap>   | IncoherentInstances -  -- | [GHC &#xa7; 7.3.8] Allows recursive bindings in @do@ blocks,-  -- using the @rec@ keyword.+  -- | /(deprecated)/ Allows recursive bindings in @do@ blocks, using the @rec@+  -- keyword. See also 'RecursiveDo'.   | 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.+  -- | Allows recursive bindings using @mdo@, a variant of @do@.+  -- @DoRec@ provides a different, preferred syntax.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#recursive-do-notation>   | RecursiveDo -  -- | [GHC &#xa7; 7.3.9] Provide syntax for writing list-  -- comprehensions which iterate over several lists together, like-  -- the 'zipWith' family of functions.+  -- | Provide syntax for writing list comprehensions which iterate+  -- over several lists together, like the 'zipWith' family of+  -- functions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#parallel-list-comprehensions>   | ParallelListComp -  -- | [GHC &#xa7; 7.6.1.1] Allow multiple parameters in a type class.+  -- | Allow multiple parameters in a type class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#multi-param-type-classes>   | MultiParamTypeClasses -  -- | [GHC &#xa7; 7.17] Enable the dreaded monomorphism restriction.+  -- | Enable the dreaded monomorphism restriction.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/monomorphism.html>   | 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.+  -- | 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.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#functional-dependencies>   | 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.+  -- | Like 'RankNTypes' but does not allow a higher-rank type to+  -- itself appear on the left of a function arrow.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#universal-quantification>   | Rank2Types -  -- | [GHC &#xa7; 7.8.5] Allow a universally-quantified type to occur on-  -- the left of a function arrow.+  -- | Allow a universally-quantified type to occur on the left of a+  -- function arrow.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#universal-quantification>   | RankNTypes -  -- | [GHC &#xa7; 7.8.5] Allow data constructors to have polymorphic-  -- arguments.  Unlike 'RankNTypes', does not allow this for ordinary-  -- functions.+  -- | Allow data constructors to have polymorphic arguments.  Unlike+  -- 'RankNTypes', does not allow this for ordinary functions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#universal-quantification>   | PolymorphicComponents -  -- | [GHC &#xa7; 7.4.4] Allow existentially-quantified data constructors.+  -- | Allow existentially-quantified data constructors.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#existential-quantification>   | 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+  -- | Cause a type variable in a signature, which has an explicit+  -- @forall@ quantifier, to scope over the definition of the   -- accompanying value declaration.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#scoped-type-variables>   | ScopedTypeVariables    -- | Deprecated, use 'ScopedTypeVariables' instead.   | PatternSignatures -  -- | [GHC &#xa7; 7.8.3] Enable implicit function parameters with dynamic-  -- scope.+  -- | Enable implicit function parameters with dynamic scope.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#implicit-parameters>   | ImplicitParams -  -- | [GHC &#xa7; 7.8.2] Relax some restrictions on the form of the context-  -- of a type signature.+  -- | Relax some restrictions on the form of the context of a type+  -- signature.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#flexible-contexts>   | FlexibleContexts -  -- | [GHC &#xa7; 7.6.3.2] Relax some restrictions on the form of the-  -- context of an instance declaration.+  -- | Relax some restrictions on the form of the context of an+  -- instance declaration.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-rules>   | FlexibleInstances -  -- | [GHC &#xa7; 7.4.1] Allow data type declarations with no constructors.+  -- | Allow data type declarations with no constructors.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#nullary-types>   | EmptyDataDecls -  -- | [GHC &#xa7; 4.10.3] Run the C preprocessor on Haskell source code.+  -- | Run the C preprocessor on Haskell source code.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/options-phases.html#c-pre-processor>   | CPP -  -- | [GHC &#xa7; 7.8.4] Allow an explicit kind signature giving the kind of-  -- types over which a type variable ranges.+  -- | Allow an explicit kind signature giving the kind of types over+  -- which a type variable ranges.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#kinding>   | 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.+  -- | Enable a form of pattern which forces evaluation before an+  -- attempted match, and a form of strict @let@/@where@ binding.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/bang-patterns.html>   | BangPatterns -  -- | [GHC &#xa7; 7.6.3.1] Allow type synonyms in instance heads.+  -- | Allow type synonyms in instance heads.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#flexible-instance-head>   | TypeSynonymInstances -  -- | [GHC &#xa7; 7.9] Enable Template Haskell, a system for compile-time+  -- | Enable Template Haskell, a system for compile-time   -- metaprogramming.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/template-haskell.html>   | 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.+  -- | Enable the Foreign Function Interface.  In GHC, implements the+  -- standard Haskell 98 Foreign Function Interface Addendum, plus+  -- some GHC-specific extensions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html>   | ForeignFunctionInterface -  -- | [GHC &#xa7; 7.10] Enable arrow notation.+  -- | Enable arrow notation.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/arrow-notation.html>   | Arrows -  -- | [GHC &#xa7; 7.16] Enable generic type classes, with default instances-  -- defined in terms of the algebraic structure of a type.+  -- | /(deprecated)/ Enable generic type classes, with default instances defined in+  -- terms of the algebraic structure of a type.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/generic-classes.html>   | 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.+  -- | 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.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#rebindable-syntax>   | 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'.+  -- | Enable syntax for implicitly binding local names corresponding+  -- to the field names of a record.  Puns bind specific names, unlike+  -- 'RecordWildCards'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#record-puns>   | NamedFieldPuns -  -- | [GHC &#xa7; 7.3.5] Enable a form of guard which matches a pattern and-  -- binds variables.+  -- | Enable a form of guard which matches a pattern and binds+  -- variables.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#pattern-guards>   | 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.+  -- | Allow a type declared with @newtype@ to use @deriving@ for any+  -- class with an instance for the underlying type.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#newtype-deriving>   | GeneralizedNewtypeDeriving -  -- | [Hugs &#xa7; 7.1] Enable the \"Trex\" extensible records system.+  -- | Enable the \"Trex\" extensible records system.+  --+  -- * <http://cvs.haskell.org/Hugs/pages/users_guide/hugs-only.html#TREX>   | ExtensibleRecords -  -- | [Hugs &#xa7; 7.2] Enable type synonyms which are transparent in-  -- some definitions and opaque elsewhere, as a way of implementing -  -- abstract datatypes.+  -- | Enable type synonyms which are transparent in some definitions+  -- and opaque elsewhere, as a way of implementing abstract+  -- datatypes.+  --+  -- * <http://cvs.haskell.org/Hugs/pages/users_guide/restricted-synonyms.html>   | RestrictedTypeSynonyms -  -- | [Hugs &#xa7; 7.3] Enable an alternate syntax for string literals,+  -- | Enable an alternate syntax for string literals,   -- with string templating.+  --+  -- * <http://cvs.haskell.org/Hugs/pages/users_guide/here-documents.html>   | HereDocuments -  -- | [GHC &#xa7; 7.3.2] Allow the character @#@ as a postfix modifier on-  -- identifiers.  Also enables literal syntax for unboxed values.+  -- | Allow the character @#@ as a postfix modifier on identifiers.+  -- Also enables literal syntax for unboxed values.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#magic-hash>   | MagicHash -  -- | [GHC &#xa7; 7.7] Allow data types and type synonyms which are-  -- indexed by types, i.e. ad-hoc polymorphism for types.+  -- | Allow data types and type synonyms which are indexed by types,+  -- i.e. ad-hoc polymorphism for types.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-families.html>   | TypeFamilies -  -- | [GHC &#xa7; 7.5.2] Allow a standalone declaration which invokes the-  -- type class @deriving@ mechanism.+  -- | Allow a standalone declaration which invokes the type class+  -- @deriving@ mechanism.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#stand-alone-deriving>   | StandaloneDeriving -  -- | [GHC &#xa7; 7.3.1] Allow certain Unicode characters to stand for-  -- certain ASCII character sequences, e.g. keywords and punctuation.+  -- | Allow certain Unicode characters to stand for certain ASCII+  -- character sequences, e.g. keywords and punctuation.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#unicode-syntax>   | UnicodeSyntax -  -- | [GHC &#xa7; 8.1.1] Allow the use of unboxed types as foreign types,-  -- e.g. in @foreign import@ and @foreign export@.+  -- | Allow the use of unboxed types as foreign types, e.g. in+  -- @foreign import@ and @foreign export@.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html#id681687>   | 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.+  -- | Enable interruptible FFI.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html#ffi-interruptible>+  | InterruptibleFFI++  -- | Allow use of CAPI FFI calling convention (@foreign import capi@).+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html#ffi-capi>+  | CApiFFI++  -- | Defer validity checking of types until after expanding type+  -- synonyms, relaxing the constraints on how synonyms may be used.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#type-synonyms>   | LiberalTypeSynonyms -  -- | [GHC &#xa7; 7.4.2] Allow the name of a type constructor, type class,-  -- or type variable to be an infix operator.+  -- | 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'.+  -- | Enable syntax for implicitly binding local names corresponding+  -- to the field names of a record.  A wildcard binds all unmentioned+  -- names, unlike 'NamedFieldPuns'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#record-wildcards>   | 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.+  -- | Allow a record field name to be disambiguated by the type of+  -- the record it's in.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#disambiguate-fields>   | DisambiguateRecordFields -  -- | [GHC &#xa7; 7.6.4] Enable overloading of string literals using a-  -- type class, much like integer literals.+  -- | Enable traditional record syntax (as supported by Haskell 98)+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#traditional-record-syntax>+  | TraditionalRecordSyntax++  -- | Enable overloading of string literals using a type class, much+  -- like integer literals.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#overloaded-strings>   | 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.+  -- | Enable generalized algebraic data types, in which type+  -- variables may be instantiated on a per-constructor basis. Implies+  -- 'GADTSyntax'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#gadt>   | GADTs    -- | Enable GADT syntax for declaring ordinary algebraic datatypes.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#gadt-style>   | GADTSyntax -  -- | [GHC &#xa7; 7.17.2] Make pattern bindings monomorphic.+  -- | Make pattern bindings monomorphic.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/monomorphism.html#id630981>   | MonoPatBinds -  -- | [GHC &#xa7; 7.8.8] Relax the requirements on mutually-recursive-  -- polymorphic functions.+  -- | Relax the requirements on mutually-recursive polymorphic+  -- functions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#typing-binds>   | RelaxedPolyRec -  -- | [GHC &#xa7; 2.4.5] Allow default instantiation of polymorphic-  -- types in more situations.+  -- | Allow default instantiation of polymorphic types in more+  -- situations.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/interactive-evaluation.html#extended-default-rules>   | ExtendedDefaultRules -  -- | [GHC &#xa7; 7.2.2] Enable unboxed tuples.+  -- | Enable unboxed tuples.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/primitives.html#unboxed-tuples>   | UnboxedTuples -  -- | [GHC &#xa7; 7.5.3] Enable @deriving@ for classes-  -- @Data.Typeable.Typeable@ and @Data.Generics.Data@.+  -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and+  -- 'Data.Generics.Data'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>   | DeriveDataTypeable -  -- | [GHC &#xa7; 7.6.1.3] Allow a class method's type to place-  -- additional constraints on a class type variable.+  -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>+  | DeriveGeneric++  -- | Enable support for default signatures.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#class-default-signatures>+  | DefaultSignatures++  -- | Allow type signatures to be specified in instance declarations.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-sigs>+  | InstanceSigs++  -- | Allow a class method's type to place additional constraints on+  -- a class type variable.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#class-method-types>   | 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.+  -- | Allow imports to be qualified by the package name the module is+  -- intended to be imported from, e.g.   --   -- > import "network" Network.Socket+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#package-imports>   | 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+  -- | /(deprecated)/ Allow a type variable to be instantiated at a   -- polymorphic type.+  --+  -- * <http://www.haskell.org/ghc/docs/6.12.3/html/users_guide/other-type-extensions.html#impredicative-polymorphism>   | ImpredicativeTypes -  -- | [GHC &#xa7; 7.3.3] Change the syntax for qualified infix-  -- operators.+  -- | /(deprecated)/ Change the syntax for qualified infix operators.+  --+  -- * <http://www.haskell.org/ghc/docs/6.12.3/html/users_guide/syntax-extns.html#new-qualified-operators>   | NewQualifiedOperators -  -- | [GHC &#xa7; 7.3.12] Relax the interpretation of left operator-  -- sections to allow unary postfix operators.+  -- | Relax the interpretation of left operator sections to allow+  -- unary postfix operators.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#postfix-operators>   | PostfixOperators -  -- | [GHC &#xa7; 7.9.5] Enable quasi-quotation, a mechanism for defining-  -- new concrete syntax for expressions and patterns.+  -- | Enable quasi-quotation, a mechanism for defining new concrete+  -- syntax for expressions and patterns.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/template-haskell.html#th-quasiquotation>   | QuasiQuotes -  -- | [GHC &#xa7; 7.3.10] Enable generalized list comprehensions,-  -- supporting operations such as sorting and grouping.+  -- | Enable generalized list comprehensions, supporting operations+  -- such as sorting and grouping.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#generalised-list-comprehensions>   | TransformListComp -  -- | [GHC &#xa7; 7.3.6] Enable view patterns, which match a value by-  -- applying a function and matching on the result.+  -- | Enable monad comprehensions, which generalise the list+  -- comprehension syntax to work for any monad.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#monad-comprehensions>+  | MonadComprehensions++  -- | Enable view patterns, which match a value by applying a+  -- function and matching on the result.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#view-patterns>   | ViewPatterns    -- | Allow concrete XML syntax to be used in expressions and patterns,@@ -395,6 +535,8 @@    -- | Enables the use of tuple sections, e.g. @(, True)@ desugars into   -- @\x -> (x, True)@.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#tuple-sections>   | TupleSections    -- | Allows GHC primops, written in C--, to be imported into a Haskell@@ -403,65 +545,167 @@    -- | Support for patterns of the form @n + k@, where @k@ is an   -- integer literal.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#n-k-patterns>   | NPlusKPatterns    -- | Improve the layout rule when @if@ expressions are used in a @do@   -- block.   | DoAndIfThenElse +  -- | Enable support for multi-way @if@-expressions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#multi-way-if>+  | MultiWayIf++  -- | Enable support lambda-@case@ expressions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#lambda-case>+  | LambdaCase+   -- | Makes much of the Haskell sugar be desugared into calls to the   -- function with a particular name that is in scope.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#rebindable-syntax>   | RebindableSyntax    -- | Make @forall@ a keyword in types, which can be used to give the   -- generalisation explicitly.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#explicit-foralls>   | ExplicitForAll    -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in   -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#datatype-contexts>   | DatatypeContexts    -- | Local (@let@ and @where@) bindings are monomorphic.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#mono-local-binds>   | MonoLocalBinds -  -- | Enable @deriving@ for the @Data.Functor.Functor@ class.+  -- | Enable @deriving@ for the 'Data.Functor.Functor' class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>   | DeriveFunctor -  -- | Enable @deriving@ for the @Data.Traversable.Traversable@ class.+  -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>   | DeriveTraversable -  -- | Enable @deriving@ for the @Data.Foldable.Foldable@ class.+  -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>   | DeriveFoldable -  -- | Enable non-decreasing indentation for 'do' blocks.+  -- | Enable non-decreasing indentation for @do@ blocks.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/bugs-and-infelicities.html#infelicities-syntax>   | 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.+  -- | 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+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-imports>   | 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.+  -- | Compile a module in the Safe, Safe Haskell mode -- a restricted+  -- form of the Haskell language to ensure type safety.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-trust>   | 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.+  -- | 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.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-trust>   | 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.+  -- | Compile a module in the Unsafe, Safe Haskell mode so that+  -- modules compiled using Safe, Safe Haskell mode can't import it.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-trust>+  | Unsafe++  -- | 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.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/constraint-kind.html>   | ConstraintKinds -  deriving (Show, Read, Eq, Enum, Bounded)+  -- | Enable kind polymorphism.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/kind-polymorphism.html>+  | PolyKinds +  -- | Enable datatype promotion.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/promotion.html>+  | DataKinds++  -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/.+  --+  -- * <http://www.haskell.org/haskellwiki/GHC/Data_Parallel_Haskell>+  | ParallelArrays++  -- | Enable explicit role annotations, like in (@data T a\@R@).+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/roles.html>+  | RoleAnnotations++  -- | Enable overloading of list literals, arithmetic sequences and+  -- list patterns using the 'IsList' type class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#overloaded-lists>+  | OverloadedLists++  -- | Enables case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#empty-case>+  | EmptyCase++  -- | Triggers the generation of derived 'Typeable' instances for every+  -- datatype and type class declaration.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#auto-derive-typeable>+  | AutoDeriveTypeable++  -- | Desugars negative literals directly (without using negate).+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#negative-literals>+  | NegativeLiterals++  -- | Allows the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#num-decimals>+  | NumDecimals++  -- | Enables support for type classes with no type parameter.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#nullary-type-classes>+  | NullaryTypeClasses++  -- | Enable explicit namespaces in module import/export lists.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#explicit-namespaces>+  | ExplicitNamespaces++  -- | Allow the user to write ambiguous types, and the type inference engine to infer them.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#ambiguity>+  | AllowAmbiguousTypes++  deriving (Show, Read, Eq, Enum, Bounded, Typeable, Data)+ {-# DEPRECATED knownExtensions    "KnownExtension is an instance of Enum and Bounded, use those instead." #-} knownExtensions :: [KnownExtension]@@ -537,4 +781,3 @@     [ (head str, (str, extension))     | extension <- [toEnum 0 ..]     , let str = show extension ]-
README view
@@ -21,8 +21,8 @@ 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)----------------------------------------------------+Installing as a user (no root or administrator access)+------------------------------------------------------      ghc --make Setup     ./Setup configure --user@@ -120,7 +120,7 @@  Please report bugs and wish-list items in our [bug tracker]. -[bug tracker]: http://hackage.haskell.org/trac/hackage/+[bug tracker]: https://github.com/haskell/cabal/issues   Your Help
changelog view
@@ -216,7 +216,7 @@ 	* New field "build-tools" for tool dependencies 	* Improved c2hs support 	* Preprocessor output no longer clutters source dirs-	* Seperate "includes" and "install-includes" fields+	* Separate "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
+ tests/Distribution/Compat/CreatePipe.hsc view
@@ -0,0 +1,55 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+module Distribution.Compat.CreatePipe (createPipe) where++import System.IO (Handle)++#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32))+import System.Posix.IO (fdToHandle)+import qualified System.Posix.IO as Posix+#else+# include <io.h>        /* for _close and _pipe */+# include <fcntl.h>     /* for _O_BINARY */+import Control.Exception (onException)+import Foreign.C.Error (throwErrnoIfMinus1_)+import Foreign.C.Types (CInt(..), CUInt(..))+import Foreign.Ptr (Ptr)+import Foreign.Marshal.Array (allocaArray)+import Foreign.Storable (peek, peekElemOff)+import GHC.IO.FD (mkFD)+import GHC.IO.Device (IODeviceType(Stream))+import GHC.IO.Handle.FD (mkHandleFromFD)+import System.IO (IOMode(ReadMode, WriteMode))+#endif++createPipe :: IO (Handle, Handle)+#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32))+createPipe = do+    (readfd, writefd) <- Posix.createPipe+    readh <- fdToHandle readfd+    writeh <- fdToHandle writefd+    return (readh, writeh)+#else+createPipe = do+    (readfd, writefd) <- allocaArray 2 $ \ pfds -> do+        throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 (#const _O_BINARY)+        readfd <- peek pfds+        writefd <- peekElemOff pfds 1+        return (readfd, writefd)+    (do readh <- fdToHandle readfd ReadMode+        writeh <- fdToHandle writefd WriteMode+        return (readh, writeh)) `onException` (close readfd >> close writefd)++fdToHandle :: CInt -> IOMode -> IO Handle+fdToHandle fd mode = do+    (fd', deviceType) <- mkFD fd mode (Just (Stream, 0, 0)) False False+    mkHandleFromFD fd' deviceType "" mode False Nothing++close :: CInt -> IO ()+close = throwErrnoIfMinus1_ "_close" . c__close++foreign import ccall "io.h _pipe" c__pipe ::+    Ptr CInt -> CUInt -> CInt -> IO CInt++foreign import ccall "io.h _close" c__close ::+    CInt -> IO CInt+#endif
+ tests/PackageTests.hs view
@@ -0,0 +1,158 @@+-- 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 Data.Version (Version(Version))+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))+import Distribution.Simple.Program.Types (programPath)+import Distribution.Simple.Program.Builtin (ghcProgram, ghcPkgProgram)+import Distribution.Simple.Program.Db (requireProgram)+import Distribution.Simple.Utils (cabalVersion, die, withFileContents)+import Distribution.Text (display)+import Distribution.Verbosity (normal)+import System.Directory (doesFileExist, getCurrentDirectory,+                         setCurrentDirectory)+import System.FilePath ((</>))+import Test.Framework (Test, TestName, defaultMain, testGroup)+import Test.Framework.Providers.HUnit (hUnitTestToTests)+import qualified Test.HUnit as HUnit++import PackageTests.BenchmarkExeV10.Check+import PackageTests.BenchmarkOptions.Check+import PackageTests.BenchmarkStanza.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.BuildDeps.SameDepsAllRound.Check+import PackageTests.BuildDeps.TargetSpecificDeps1.Check+import PackageTests.BuildDeps.TargetSpecificDeps2.Check+import PackageTests.BuildDeps.TargetSpecificDeps3.Check+import PackageTests.BuildTestSuiteDetailedV09.Check+import PackageTests.PackageTester (PackageSpec(..), compileSetup)+import PackageTests.PathsModule.Executable.Check+import PackageTests.PathsModule.Library.Check+import PackageTests.PreProcess.Check+import PackageTests.TemplateHaskell.Check+import PackageTests.CMain.Check+import PackageTests.EmptyLib.Check+import PackageTests.TestOptions.Check+import PackageTests.TestStanza.Check+import PackageTests.TestSuiteExeV10.Check+import PackageTests.OrderFlags.Check++hunit :: TestName -> HUnit.Test -> Test+hunit name test = testGroup name $ hUnitTestToTests test++tests :: Version -> PackageSpec -> FilePath -> FilePath -> [Test]+tests version inplaceSpec ghcPath ghcPkgPath =+    [ hunit "BuildDeps/SameDepsAllRound"+      (PackageTests.BuildDeps.SameDepsAllRound.Check.suite ghcPath)+      -- The two following tests were disabled by Johan Tibell as+      -- they have been failing for a long time:+      -- , hunit "BuildDeps/GlobalBuildDepsNotAdditive1/"+      --   (PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check.suite ghcPath)+      -- , hunit "BuildDeps/GlobalBuildDepsNotAdditive2/"+      --   (PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check.suite ghcPath)+    , hunit "BuildDeps/InternalLibrary0"+      (PackageTests.BuildDeps.InternalLibrary0.Check.suite version ghcPath)+    , hunit "PreProcess" (PackageTests.PreProcess.Check.suite ghcPath)+    , hunit "TestStanza" (PackageTests.TestStanza.Check.suite ghcPath)+      -- ^ The Test stanza test will eventually be required+      -- only for higher versions.+    , hunit "TestSuiteExeV10/Test" (PackageTests.TestSuiteExeV10.Check.checkTest ghcPath)+    , hunit "TestSuiteExeV10/TestWithHpc"+      (PackageTests.TestSuiteExeV10.Check.checkTestWithHpc ghcPath)+    , hunit "TestOptions" (PackageTests.TestOptions.Check.suite ghcPath)+    , hunit "BenchmarkStanza" (PackageTests.BenchmarkStanza.Check.suite ghcPath)+      -- ^ The benchmark stanza test will eventually be required+      -- only for higher versions.+    , hunit "BenchmarkExeV10/Test"+      (PackageTests.BenchmarkExeV10.Check.checkBenchmark ghcPath)+    , hunit "BenchmarkOptions" (PackageTests.BenchmarkOptions.Check.suite ghcPath)+    , hunit "TemplateHaskell/vanilla"+      (PackageTests.TemplateHaskell.Check.vanilla ghcPath)+    , hunit "TemplateHaskell/profiling"+      (PackageTests.TemplateHaskell.Check.profiling ghcPath)+    , hunit "TemplateHaskell/dynamic"+      (PackageTests.TemplateHaskell.Check.dynamic ghcPath)+    , hunit "PathsModule/Executable"+      (PackageTests.PathsModule.Executable.Check.suite ghcPath)+    , hunit "PathsModule/Library" (PackageTests.PathsModule.Library.Check.suite ghcPath)+    , hunit "EmptyLib/emptyLib"+      (PackageTests.EmptyLib.Check.emptyLib ghcPath)+    , hunit "BuildTestSuiteDetailedV09"+      (PackageTests.BuildTestSuiteDetailedV09.Check.suite inplaceSpec ghcPath)+    , hunit "OrderFlags"+      (PackageTests.OrderFlags.Check.suite ghcPath)+    ] +++    -- These tests are only required to pass on cabal version >= 1.7+    (if version >= Version [1, 7] []+     then [ hunit "BuildDeps/TargetSpecificDeps1"+            (PackageTests.BuildDeps.TargetSpecificDeps1.Check.suite ghcPath)+          , hunit "BuildDeps/TargetSpecificDeps2"+            (PackageTests.BuildDeps.TargetSpecificDeps2.Check.suite ghcPath)+          , hunit "BuildDeps/TargetSpecificDeps3"+            (PackageTests.BuildDeps.TargetSpecificDeps3.Check.suite ghcPath)+          , hunit "BuildDeps/InternalLibrary1"+            (PackageTests.BuildDeps.InternalLibrary1.Check.suite ghcPath)+          , hunit "BuildDeps/InternalLibrary2"+            (PackageTests.BuildDeps.InternalLibrary2.Check.suite ghcPath ghcPkgPath)+          , hunit "BuildDeps/InternalLibrary3"+            (PackageTests.BuildDeps.InternalLibrary3.Check.suite ghcPath ghcPkgPath)+          , hunit "BuildDeps/InternalLibrary4"+            (PackageTests.BuildDeps.InternalLibrary4.Check.suite ghcPath ghcPkgPath)+          , hunit "PackageTests/CMain"+            (PackageTests.CMain.Check.checkBuild ghcPath)+          ]+     else [])++main :: IO ()+main = do+    wd <- getCurrentDirectory+    let dbFile = wd </> "dist/package.conf.inplace"+        inplaceSpec = PackageSpec+            { directory = []+            , configOpts = [ "--package-db=" ++ dbFile+                           , "--constraint=Cabal == " ++ display cabalVersion+                           ]+            }+    putStrLn $ "Cabal test suite - testing cabal version " +++        display cabalVersion+    lbi <- getPersistBuildConfig_ ("dist" </> "setup-config")+    (ghc, _) <- requireProgram normal ghcProgram (withPrograms lbi)+    (ghcPkg, _) <- requireProgram normal ghcPkgProgram (withPrograms lbi)+    let ghcPath = programPath ghc+        ghcPkgPath = programPath ghcPkg+    putStrLn $ "Using ghc: " ++ ghcPath+    putStrLn $ "Using ghc-pkg: " ++ ghcPkgPath+    setCurrentDirectory "tests"+    -- Create a shared Setup executable to speed up Simple tests+    compileSetup "." ghcPath+    defaultMain (tests cabalVersion inplaceSpec ghcPath ghcPkgPath)++-- Like Distribution.Simple.Configure.getPersistBuildConfig but+-- doesn't check that the Cabal version matches, which it doesn't when+-- we run Cabal's own test suite, due to bootstrapping issues.+getPersistBuildConfig_ :: FilePath -> IO LocalBuildInfo+getPersistBuildConfig_ filename = do+  exists <- doesFileExist filename+  if not exists+    then die missing+    else withFileContents filename $ \str ->+      case lines str of+        [_header, rest] -> case reads rest of+          [(bi,_)] -> return bi+          _        -> die cantParse+        _            -> die cantParse+  where+    missing   = "Run the 'configure' command first."+    cantParse = "Saved package config file seems to be corrupt. "+             ++ "Try re-running the 'configure' command."
tests/PackageTests/BenchmarkExeV10/Check.hs view
@@ -2,20 +2,15 @@        ( 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+import System.FilePath+import Test.HUnit  dir :: FilePath dir = "PackageTests" </> "BenchmarkExeV10" -checkBenchmark :: Version -> Test-checkBenchmark cabalVersion = TestCase $ do+checkBenchmark :: FilePath -> Test+checkBenchmark ghcPath = TestCase $ do     let spec = PackageSpec dir ["--enable-benchmarks"]-    buildResult <- cabal_build spec-    let buildMessage = "\'setup build\' should succeed"-    assertEqual buildMessage True $ successful buildResult+    buildResult <- cabal_build spec ghcPath+    assertBuildSucceeded buildResult
+ tests/PackageTests/BenchmarkExeV10/Foo.hs view
@@ -0,0 +1,4 @@+module Foo where++fooTest :: [String] -> Bool+fooTest _ = True
+ 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
+ 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
+ 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
tests/PackageTests/BenchmarkOptions/Check.hs view
@@ -1,16 +1,15 @@ module PackageTests.BenchmarkOptions.Check where -import Test.HUnit-import System.FilePath import PackageTests.PackageTester+import System.FilePath+import Test.HUnit -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"]+suite :: FilePath -> Test+suite ghcPath = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BenchmarkOptions")+               ["--enable-benchmarks"]+    _ <- cabal_build spec ghcPath+    result <- cabal_bench spec ["--benchmark-options=1 2 3"] ghcPath     let message = "\"cabal bench\" did not pass the correct options to the "                   ++ "benchmark executable with \"--benchmark-options\""     assertEqual message True $ successful result@@ -18,6 +17,7 @@                                 , "--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'+               ghcPath+    let message' = "\"cabal bench\" did not pass the correct options to the "+                   ++ "benchmark executable with \"--benchmark-option\""+    assertEqual message' True $ successful result'
+ 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
tests/PackageTests/BenchmarkStanza/Check.hs view
@@ -3,41 +3,33 @@ 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(..) )+        ( PackageName(..), Dependency(..) ) import Distribution.PackageDescription-        ( PackageDescription(..), BuildInfo(..), Benchmark(..), Library(..)+        ( PackageDescription(..), BuildInfo(..), Benchmark(..)         , BenchmarkInterface(..)-        , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary-        , emptyBenchmark, BuildType(..) )+        , emptyBuildInfo+        , emptyBenchmark ) 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+suite :: FilePath -> Test+suite ghcPath = TestCase $ do+    let dir = "PackageTests" </> "BenchmarkStanza"+        pdFile = dir </> "my" <.> "cabal"+        spec = PackageSpec dir []+    result <- cabal_configure spec ghcPath+    assertOutputDoesNotContain "unknown section type" result     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"
+ 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
tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs view
@@ -8,10 +8,10 @@ import Prelude hiding (catch)  -suite :: Test-suite = TestCase $ do+suite :: FilePath -> Test+suite ghcPath = TestCase $ do     let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "GlobalBuildDepsNotAdditive1") []-    result <- cabal_build spec+    result <- cabal_build spec ghcPath     do         assertEqual "cabal build should fail - see test-log.txt" False (successful result)         let sb = "Could not find module `Prelude'"
+ tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal view
@@ -0,0 +1,20 @@+name: GlobalBuildDepsNotAdditive1+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    If you specify 'base' in the global build dependencies, then define+    a library without base, it fails to find 'base' for the library.++---------------------------------------++build-depends: base++Library+    exposed-modules: MyLibrary+    build-depends: bytestring, old-time
+ 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
tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs view
@@ -8,10 +8,10 @@ import Prelude hiding (catch)  -suite :: Test-suite = TestCase $ do+suite :: FilePath -> Test+suite ghcPath = TestCase $ do     let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "GlobalBuildDepsNotAdditive2") []-    result <- cabal_build spec+    result <- cabal_build spec ghcPath     do         assertEqual "cabal build should fail - see test-log.txt" False (successful result)         let sb = "Could not find module `Prelude'"
+ tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal view
@@ -0,0 +1,20 @@+name: GlobalBuildDepsNotAdditive1+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    If you specify 'base' in the global build dependencies, then define+    an executable without base, it fails to find 'base' for the executable++---------------------------------------++build-depends: base++Executable lemon+    main-is: lemon.hs+    build-depends: bytestring, old-time
+ 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
tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs view
@@ -1,26 +1,18 @@ 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)+import PackageTests.PackageTester+import System.FilePath+import Test.HUnit  -suite :: Version -> Test-suite cabalVersion = TestCase $ do+suite :: Version -> FilePath -> Test+suite cabalVersion ghcPath = 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)+    result <- cabal_build spec ghcPath+    assertBuildFailed 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.+        assertOutputContains sb result
+ 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
+ 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
+ tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs view
@@ -1,18 +1,12 @@ module PackageTests.BuildDeps.InternalLibrary1.Check where -import Test.HUnit import PackageTests.PackageTester import System.FilePath-import Control.Exception-import Prelude hiding (catch)+import Test.HUnit  -suite :: Test-suite = TestCase $ do+suite :: FilePath -> Test+suite ghcPath = 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)+    result <- cabal_build spec ghcPath+    assertBuildSucceeded result
+ 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
+ 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
+ tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs view
@@ -1,34 +1,24 @@ module PackageTests.BuildDeps.InternalLibrary2.Check where -import Test.HUnit+import qualified Data.ByteString.Char8 as C import PackageTests.PackageTester import System.FilePath-import qualified Data.ByteString.Char8 as C-import Control.Exception-import Prelude hiding (catch)+import Test.HUnit  -suite :: Test-suite = TestCase $ do+suite :: FilePath -> FilePath -> Test+suite ghcPath ghcPkgPath = 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"+    unregister "InternalLibrary2" ghcPkgPath+    iResult <- cabal_install specTI ghcPath+    assertInstallSucceeded iResult+    bResult <- cabal_build spec ghcPath+    assertBuildSucceeded bResult+    unregister "InternalLibrary2" ghcPkgPath -    (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" []+    (_, _, output) <- run (Just $ directory spec) (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)
+ 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
+ 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
+ tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ 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
+ 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
tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs view
@@ -1,34 +1,24 @@ module PackageTests.BuildDeps.InternalLibrary3.Check where -import Test.HUnit+import qualified Data.ByteString.Char8 as C import PackageTests.PackageTester import System.FilePath-import qualified Data.ByteString.Char8 as C-import Control.Exception-import Prelude hiding (catch)+import Test.HUnit  -suite :: Test-suite = TestCase $ do+suite :: FilePath -> FilePath -> Test+suite ghcPath ghcPkgPath = 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"+    unregister "InternalLibrary3" ghcPkgPath+    iResult <- cabal_install specTI ghcPath+    assertInstallSucceeded iResult+    bResult <- cabal_build spec ghcPath+    assertBuildSucceeded bResult+    unregister "InternalLibrary3"ghcPkgPath -    (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" []+    (_, _, output) <- run (Just $ directory spec) (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)
+ 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
+ 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
+ tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ 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
+ 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
tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs view
@@ -1,34 +1,24 @@ module PackageTests.BuildDeps.InternalLibrary4.Check where -import Test.HUnit+import qualified Data.ByteString.Char8 as C import PackageTests.PackageTester import System.FilePath-import qualified Data.ByteString.Char8 as C-import Control.Exception-import Prelude hiding (catch)+import Test.HUnit  -suite :: Test-suite = TestCase $ do+suite :: FilePath -> FilePath -> Test+suite ghcPath ghcPkgPath = 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"+    unregister "InternalLibrary4" ghcPkgPath+    iResult <- cabal_install specTI ghcPath+    assertInstallSucceeded iResult+    bResult <- cabal_build spec ghcPath+    assertBuildSucceeded bResult+    unregister "InternalLibrary4" ghcPkgPath -    (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" []+    (_, _, output) <- run (Just $ directory spec) (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)
+ 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
+ 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
+ tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ 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
+ 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
tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs view
@@ -3,16 +3,15 @@ import Test.HUnit import PackageTests.PackageTester import System.FilePath-import Control.Exception-import Prelude hiding (catch)+import qualified Control.Exception as E  -suite :: Test-suite = TestCase $ do+suite :: FilePath -> Test+suite ghcPath = TestCase $ do     let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "SameDepsAllRound") []-    result <- cabal_build spec+    result <- cabal_build spec ghcPath     do         assertEqual "cabal build should succeed - see test-log.txt" True (successful result)-      `catch` \exc -> do+      `E.catch` \exc -> do         putStrLn $ "Cabal result was "++show result-        throwIO (exc :: SomeException)+        E.throwIO (exc :: E.SomeException)
+ 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
+ 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
+ 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
+ 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
tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs view
@@ -4,21 +4,22 @@ import PackageTests.PackageTester import System.FilePath import Data.List-import Control.Exception-import Prelude hiding (catch)+import qualified Control.Exception as E+import Text.Regex.Posix  -suite :: Test-suite = TestCase $ do+suite :: FilePath -> Test+suite ghcPath = TestCase $ do     let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "TargetSpecificDeps1") []-    result <- cabal_build spec+    result <- cabal_build spec ghcPath     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+            (intercalate " " $ lines $ outputText result)+            =~ "Could not find module.*System.Time"++      `E.catch` \exc -> do         putStrLn $ "Cabal result was "++show result-        throwIO (exc :: SomeException)+        E.throwIO (exc :: E.SomeException)
+ 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
+ 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
+ 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
tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs view
@@ -3,17 +3,15 @@ import Test.HUnit import PackageTests.PackageTester import System.FilePath-import Data.List-import Control.Exception-import Prelude hiding (catch)+import qualified Control.Exception as E  -suite :: Test-suite = TestCase $ do+suite :: FilePath -> Test+suite ghcPath = TestCase $ do     let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "TargetSpecificDeps2") []-    result <- cabal_build spec+    result <- cabal_build spec ghcPath     do         assertEqual "cabal build should succeed - see test-log.txt" True (successful result)-      `catch` \exc -> do+      `E.catch` \exc -> do         putStrLn $ "Cabal result was "++show result-        throwIO (exc :: SomeException)+        E.throwIO (exc :: E.SomeException)
+ 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
+ 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
+ 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
tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs view
@@ -4,20 +4,21 @@ import PackageTests.PackageTester import System.FilePath import Data.List-import Control.Exception-import Prelude hiding (catch)+import qualified Control.Exception as E+import Text.Regex.Posix  -suite :: Test-suite = TestCase $ do+suite :: FilePath -> Test+suite ghcPath = TestCase $ do     let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "TargetSpecificDeps3") []-    result <- cabal_build spec+    result <- cabal_build spec ghcPath     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+            (intercalate " " $ lines $ outputText result)+            =~ "Could not find module.*System.Time"+      `E.catch` \exc -> do         putStrLn $ "Cabal result was "++show result-        throwIO (exc :: SomeException)+        E.throwIO (exc :: E.SomeException)
+ 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
+ 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
+ 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
+ tests/PackageTests/BuildTestSuiteDetailedV09/Check.hs view
@@ -0,0 +1,18 @@+module PackageTests.BuildTestSuiteDetailedV09.Check where++import Test.HUnit+import System.FilePath ((</>))++import PackageTests.PackageTester++suite :: PackageSpec -> FilePath -> Test+suite inplaceSpec ghcPath = TestCase $ do+    let dir = "PackageTests" </> "BuildTestSuiteDetailedV09"+        spec = inplaceSpec+            { directory = dir+            , configOpts = "--enable-tests" : configOpts inplaceSpec+            }+    confResult <- cabal_configure spec ghcPath+    assertEqual "configure failed!" (successful confResult) True+    buildResult <- cabal_build spec ghcPath+    assertEqual "build failed!" (successful buildResult) True
+ tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs view
@@ -0,0 +1,6 @@+module Dummy where++import Distribution.TestSuite (Test)++tests :: IO [Test]+tests = return []
+ tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal view
@@ -0,0 +1,19 @@+name: BuildTestSuiteDetailedV09+version: 0.1+license: BSD3+author: Thomas Tuegel+stability: stable+category: PackageTests+build-type: Simple++description:+    Check that Cabal can build test suites of type detailed-0.9.++Library+    exposed-modules: Dummy+    build-depends: base, Cabal++test-suite test-Dummy+  type:       detailed-0.9+  test-module: Dummy+  build-depends: base, Cabal
+ tests/PackageTests/CMain/Bar.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Bar where++bar :: IO ()+bar = return ()++foreign export ccall bar :: IO ()
+ tests/PackageTests/CMain/Check.hs view
@@ -0,0 +1,16 @@+module PackageTests.CMain.Check+       ( checkBuild+       ) where++import Test.HUnit+import System.FilePath+import PackageTests.PackageTester++dir :: FilePath+dir = "PackageTests" </> "CMain"++checkBuild :: FilePath -> Test+checkBuild ghcPath = TestCase $ do+    let spec = PackageSpec dir []+    buildResult <- cabal_build spec ghcPath+    assertBuildSucceeded buildResult
+ tests/PackageTests/CMain/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ tests/PackageTests/CMain/foo.c view
@@ -0,0 +1,13 @@+#include <stdio.h>+#include "HsFFI.h"++#ifdef __GLASGOW_HASKELL__+#include "Bar_stub.h"+#endif++int main(int argc, char **argv) {+    hs_init(&argc, &argv);+    bar();+    printf("Hello world!");+    return 0;+}
+ tests/PackageTests/CMain/my.cabal view
@@ -0,0 +1,10 @@+name:           my+version:        0.1+license:        BSD3+cabal-version:  >= 1.9.2+build-type:     Simple++executable foo+    main-is:    foo.c+    other-modules: Bar+    build-depends: base
+ tests/PackageTests/EmptyLib/Check.hs view
@@ -0,0 +1,13 @@+module PackageTests.EmptyLib.Check where++import PackageTests.PackageTester+import System.FilePath+import Test.HUnit++-- See https://github.com/haskell/cabal/issues/1241+emptyLib :: FilePath -> Test+emptyLib ghcPath = TestCase $ do+   let spec = PackageSpec ("PackageTests" </> "EmptyLib"+                           </> "empty") []+   result <- cabal_build spec ghcPath+   assertBuildSucceeded result
+ tests/PackageTests/EmptyLib/empty/empty.cabal view
@@ -0,0 +1,6 @@+name: emptyLib+Cabal-version: >= 1.2+version: 1.0+build-type: Simple++Library
+ tests/PackageTests/OrderFlags/Check.hs view
@@ -0,0 +1,18 @@+module PackageTests.OrderFlags.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import Control.Exception+import Prelude hiding (catch)+++suite :: FilePath -> Test+suite ghcPath = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "OrderFlags") []+    result <- cabal_build spec ghcPath+    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)
+ tests/PackageTests/OrderFlags/Foo.hs view
@@ -0,0 +1,8 @@+module Foo where++x :: IO Int+x = return 5++f :: IO Int+f = do x+       return 3
+ tests/PackageTests/OrderFlags/my.cabal view
@@ -0,0 +1,20 @@+name: OrderFlags+version: 0.1+license: BSD3+author: Oleksandr Manzyuk+stability: stable+category: PackageTests+build-type: Simple+cabal-version: >=1.9.2++description:+    Check that Cabal correctly orders flags that are passed to GHC.++library+    exposed-modules: Foo+    build-depends: base++    ghc-options: -Wall -Werror++    if impl(ghc >= 6.12.1)+        ghc-options: -fno-warn-unused-do-bind
tests/PackageTests/PackageTester.hs view
@@ -1,36 +1,54 @@-module PackageTests.PackageTester (-        PackageSpec(..),-        Success(..),-        Result(..),-        cabal_configure,-        cabal_build,-        cabal_test,-        cabal_bench,-        cabal_install,-        unregister,-        run+{-# LANGUAGE ScopedTypeVariables #-}++-- You can set the following VERBOSE environment variable to control+-- the verbosity of the output generated by this module.+module PackageTests.PackageTester+    ( PackageSpec(..)+    , Success(..)+    , Result(..)++    -- * Running cabal commands+    , cabal_configure+    , cabal_build+    , cabal_test+    , cabal_bench+    , cabal_install+    , unregister+    , compileSetup+    , run++    -- * Test helpers+    , assertBuildSucceeded+    , assertBuildFailed+    , assertTestSucceeded+    , assertInstallSucceeded+    , assertOutputContains+    , assertOutputDoesNotContain     ) 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 qualified Data.ByteString.Char8 as C import Data.List import Data.Maybe-import qualified Data.ByteString.Char8 as C+import System.Directory (canonicalizePath, doesFileExist, getCurrentDirectory)+import System.Environment (getEnv)+import System.Exit (ExitCode(ExitSuccess))+import System.FilePath+import System.IO+import System.IO.Error (isDoesNotExistError)+import System.Process (runProcess, waitForProcess)+import Test.HUnit (Assertion, assertFailure) +import Distribution.Simple.BuildPaths (exeExtension)+import Distribution.Compat.CreatePipe (createPipe)+import Distribution.ReadE (readEOrFail)+import Distribution.Verbosity (Verbosity, deafening, flagToVerbosity, normal,+                               verbose) -data PackageSpec =-    PackageSpec {-        directory  :: FilePath,-        configOpts :: [String]+data PackageSpec = PackageSpec+    { directory  :: FilePath+    , configOpts :: [String]     }  data Success = Failure@@ -41,122 +59,139 @@              | BenchSuccess              deriving (Eq, Show) -data Result = Result {-        successful :: Bool,-        success    :: Success,-        outputText :: String-    }-    deriving Show+data Result = Result+    { successful :: Bool+    , success    :: Success+    , outputText :: String+    } deriving Show  nullResult :: Result nullResult = Result True Failure "" +------------------------------------------------------------------------+-- * Running cabal commands+ recordRun :: (String, ExitCode, String) -> Success -> Result -> Result recordRun (cmd, exitCode, exeOutput) thisSucc res =-    res {-        successful = successful res && exitCode == ExitSuccess,-        success = if exitCode == ExitSuccess then thisSucc-                                             else success res,-        outputText =+    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-    }+            cmd ++ "\n" ++ exeOutput+        } -cabal_configure :: PackageSpec -> IO Result-cabal_configure spec = do-    res <- doCabalConfigure spec+cabal_configure :: PackageSpec -> FilePath -> IO Result+cabal_configure spec ghcPath = do+    res <- doCabalConfigure spec ghcPath     record spec res     return res -doCabalConfigure :: PackageSpec -> IO Result-doCabalConfigure spec = do-    cleanResult@(_, _, cleanOutput) <- cabal spec ["clean"]+doCabalConfigure :: PackageSpec -> FilePath -> IO Result+doCabalConfigure spec ghcPath = do+    cleanResult@(_, _, _) <- cabal spec ["clean"] ghcPath     requireSuccess cleanResult-    res <- cabal spec $ ["configure", "--user"] ++ configOpts spec+    res <- cabal spec+           (["configure", "--user", "-w", ghcPath] ++ configOpts spec)+           ghcPath     return $ recordRun res ConfigureSuccess nullResult -doCabalBuild :: PackageSpec -> IO Result-doCabalBuild spec = do-    configResult <- doCabalConfigure spec+doCabalBuild :: PackageSpec -> FilePath -> IO Result+doCabalBuild spec ghcPath = do+    configResult <- doCabalConfigure spec ghcPath     if successful configResult         then do-            res <- cabal spec ["build"]+            res <- cabal spec ["build", "-v"] ghcPath             return $ recordRun res BuildSuccess configResult         else             return configResult -cabal_build :: PackageSpec -> IO Result-cabal_build spec = do-    res <- doCabalBuild spec+cabal_build :: PackageSpec -> FilePath -> IO Result+cabal_build spec ghcPath = do+    res <- doCabalBuild spec ghcPath     record spec res     return res -unregister :: String -> IO ()-unregister libraryName = do-    res@(_, _, output) <- run Nothing "ghc-pkg" ["unregister", "--user", libraryName]+unregister :: String -> FilePath -> IO ()+unregister libraryName ghcPkgPath = do+    res@(_, _, output) <- run Nothing ghcPkgPath ["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+cabal_install :: PackageSpec -> FilePath -> IO Result+cabal_install spec ghcPath = do+    buildResult <- doCabalBuild spec ghcPath     res <- if successful buildResult         then do-            res <- cabal spec ["install"]+            res <- cabal spec ["install"] ghcPath             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+cabal_test :: PackageSpec -> [String] -> FilePath -> IO Result+cabal_test spec extraArgs ghcPath = do+    res <- cabal spec ("test" : extraArgs) ghcPath     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+cabal_bench :: PackageSpec -> [String] -> FilePath -> IO Result+cabal_bench spec extraArgs ghcPath = do+    res <- cabal spec ("bench" : extraArgs) ghcPath     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+compileSetup :: FilePath -> FilePath -> IO ()+compileSetup packageDir ghcPath = do     wd <- getCurrentDirectory-    r <- run (Just $ directory spec) "ghc"-             [ "--make"+    r <- run (Just $ packageDir) ghcPath+         [ "--make" -- HPC causes trouble -- see #1012---             , "-fhpc"-             , "-package-conf " ++ wd </> "../dist/package.conf.inplace"-             , "Setup.hs"-             ]+--       , "-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 the output text.+cabal :: PackageSpec -> [String] -> FilePath -> IO (String, ExitCode, String)+cabal spec cabalArgs ghcPath = do+    customSetup <- doesFileExist (directory spec </> "Setup.hs")+    if customSetup+        then do+            compileSetup (directory spec) ghcPath+            path <- canonicalizePath $ directory spec </> "Setup"+            run (Just $ directory spec) path cabalArgs+        else do+            -- Use shared Setup executable (only for Simple build types).+            path <- canonicalizePath "Setup"+            run (Just $ directory spec) path 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)+run cwd path args = do+    verbosity <- getVerbosity+    -- path is relative to the current directory; canonicalizePath makes it+    -- absolute, so that runProcess will find it even when changing directory.+    path' <- do pathExists <- doesFileExist path+                canonicalizePath (if pathExists then path else path <.> exeExtension)+    printRawCommandAndArgs verbosity path' args+    (readh, writeh) <- createPipe+    pid <- runProcess path' args cwd Nothing Nothing (Just writeh) (Just writeh)      -- fork off a thread to start consuming the output-    output <- suckH [] outh-    hClose outh+    out <- suckH [] readh+    hClose readh -    -- wait on the process-    ex <- waitForProcess pid-    let fullCmd = intercalate " " $ cmd:args-    return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd,-        ex, output)+    -- wait for the program to terminate+    exitcode <- waitForProcess pid+    let fullCmd = unwords (path' : args)+    return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, exitcode, out)   where     suckH output h = do         eof <- hIsEOF h@@ -166,14 +201,82 @@                 c <- hGetChar h                 suckH (c:output) h +-- Copied from Distribution/Simple/Utils.hs+printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()+printRawCommandAndArgs verbosity path args+    | verbosity >= deafening = print (path, args)+    | verbosity >= verbose   = putStrLn $ unwords (path : args)+    | otherwise              = return ()+ requireSuccess :: (String, ExitCode, String) -> IO ()-requireSuccess (cmd, exitCode, output) = do-    case exitCode of-        ExitSuccess -> return ()-        ExitFailure r -> do-            ioError $ userError $ "Command " ++ cmd ++ " failed."+requireSuccess (cmd, exitCode, output) =+    unless (exitCode == ExitSuccess) $+        assertFailure $ "Command " ++ cmd ++ " failed.\n" +++        "output: " ++ output  record :: PackageSpec -> Result -> IO () record spec res = do     C.writeFile (directory spec </> "test-log.txt") (C.pack $ outputText res) +------------------------------------------------------------------------+-- * Test helpers++assertBuildSucceeded :: Result -> Assertion+assertBuildSucceeded result = unless (successful result) $+    assertFailure $+    "expected: \'setup build\' should succeed\n" +++    "  output: " ++ outputText result++assertBuildFailed :: Result -> Assertion+assertBuildFailed result = when (successful result) $+    assertFailure $+    "expected: \'setup build\' should fail\n" +++    "  output: " ++ outputText result++assertTestSucceeded :: Result -> Assertion+assertTestSucceeded result = unless (successful result) $+    assertFailure $+    "expected: \'setup test\' should succeed\n" +++    "  output: " ++ outputText result++assertInstallSucceeded :: Result -> Assertion+assertInstallSucceeded result = unless (successful result) $+    assertFailure $+    "expected: \'setup install\' should succeed\n" +++    "  output: " ++ outputText result++assertOutputContains :: String -> Result -> Assertion+assertOutputContains needle result =+    unless (needle `isInfixOf` (concatOutput output)) $+    assertFailure $+    " expected: " ++ needle ++ "\n" +++    " in output: " ++ output ++ ""+  where output = outputText result++assertOutputDoesNotContain :: String -> Result -> Assertion+assertOutputDoesNotContain needle result =+    when (needle `isInfixOf` (concatOutput output)) $+    assertFailure $+    "unexpected: " ++ needle +++    " in output: " ++ output+  where output = outputText result++-- | Replace line breaks with spaces, correctly handling "\r\n".+concatOutput :: String -> String+concatOutput = unwords . lines . filter ((/=) '\r')++------------------------------------------------------------------------+-- Verbosity++lookupEnv :: String -> IO (Maybe String)+lookupEnv name =+    (fmap Just $ getEnv name)+    `E.catch` \ (e :: IOError) ->+        if isDoesNotExistError e+        then return Nothing+        else E.throw e++-- TODO: Convert to a "-v" flag instead.+getVerbosity :: IO Verbosity+getVerbosity = do+    maybe normal (readEOrFail flagToVerbosity) `fmap` lookupEnv "VERBOSE"
+ tests/PackageTests/PathsModule/Executable/Check.hs view
@@ -0,0 +1,13 @@+module PackageTests.PathsModule.Executable.Check (suite) where++import PackageTests.PackageTester+    (PackageSpec(..), assertBuildSucceeded, cabal_build)+import System.FilePath+import Test.HUnit++suite :: FilePath -> Test+suite ghcPath = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "PathsModule" </> "Executable")+               []+    result <- cabal_build spec ghcPath+    assertBuildSucceeded result
+ tests/PackageTests/PathsModule/Executable/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import Paths_PathsModule (getBinDir)++main :: IO ()+main = do+    _ <- getBinDir+    return ()
+ tests/PackageTests/PathsModule/Executable/my.cabal view
@@ -0,0 +1,16 @@+name: PathsModule+version: 0.1+license: BSD3+author: Johan Tibell+stability: stable+category: PackageTests+build-type: Simple+Cabal-version: >= 1.2++description:+    Check that the generated paths module compiles.++Executable TestPathsModule+    main-is: Main.hs+    other-modules: Paths_PathsModule+    build-depends: base
+ tests/PackageTests/PathsModule/Library/Check.hs view
@@ -0,0 +1,12 @@+module PackageTests.PathsModule.Library.Check (suite) where++import PackageTests.PackageTester+    (PackageSpec(..), assertBuildSucceeded, cabal_build)+import System.FilePath+import Test.HUnit++suite :: FilePath -> Test+suite ghcPath = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "PathsModule" </> "Library") []+    result <- cabal_build spec ghcPath+    assertBuildSucceeded result
+ tests/PackageTests/PathsModule/Library/my.cabal view
@@ -0,0 +1,15 @@+name: PathsModule+version: 0.1+license: BSD3+author: Johan Tibell+stability: stable+category: PackageTests+build-type: Simple+Cabal-version: >= 1.2++description:+    Check that the generated paths module compiles.++Library+    exposed-modules: Paths_PathsModule+    build-depends: base
+ tests/PackageTests/PreProcess/Check.hs view
@@ -0,0 +1,13 @@+module PackageTests.PreProcess.Check (suite) where++import PackageTests.PackageTester+    (PackageSpec(..), assertBuildSucceeded, cabal_build)+import System.FilePath+import Test.HUnit++suite :: FilePath -> Test+suite ghcPath = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "PreProcess")+               ["--enable-tests", "--enable-benchmarks"]+    result <- cabal_build spec ghcPath+    assertBuildSucceeded result
+ tests/PackageTests/PreProcess/Foo.hsc view
@@ -0,0 +1,1 @@+module Foo where
+ tests/PackageTests/PreProcess/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import Foo++main :: IO ()+main = return ()
+ tests/PackageTests/PreProcess/my.cabal view
@@ -0,0 +1,32 @@+name: PreProcess+version: 0.1+license: BSD3+author: Johan Tibell+stability: stable+category: PackageTests+build-type: Simple+Cabal-version: >= 1.2++description:+    Check that preprocessors are run.++Library+    exposed-modules: Foo+    build-depends: base++Executable my-executable+    main-is: Main.hs+    other-modules: Foo+    build-depends: base++Test-Suite my-test-suite+    main-is: Main.hs+    type: exitcode-stdio-1.0+    other-modules: Foo+    build-depends: base++Benchmark my-benchmark+    main-is: Main.hs+    type: exitcode-stdio-1.0+    other-modules: Foo+    build-depends: base
tests/PackageTests/TemplateHaskell/Check.hs view
@@ -1,44 +1,32 @@ 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+import System.FilePath+import Test.HUnit -profiling :: Test-profiling = TestCase $ do+vanilla :: FilePath -> Test+vanilla ghcPath = TestCase $ do+  let spec = PackageSpec ("PackageTests" </>+                          "TemplateHaskell" </> "vanilla") []+  result <- cabal_build spec ghcPath+  assertBuildSucceeded result++profiling :: FilePath -> Test+profiling ghcPath = 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)+       spec = PackageSpec ("PackageTests" </>+                           "TemplateHaskell" </> "profiling") flags+   result <- cabal_build spec ghcPath+   assertBuildSucceeded result -dynamic :: Test-dynamic = TestCase $ do+dynamic :: FilePath -> Test+dynamic ghcPath = 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)-+        spec = PackageSpec ("PackageTests" </>+                            "TemplateHaskell" </> "dynamic") flags+    result <- cabal_build spec ghcPath+    assertBuildSucceeded result
+ tests/PackageTests/TemplateHaskell/dynamic/Exe.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import TH++main = print $(splice)
+ tests/PackageTests/TemplateHaskell/dynamic/Lib.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Lib where++import TH++val = $(splice)
+ tests/PackageTests/TemplateHaskell/dynamic/TH.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}+module TH where++splice = [| () |]
+ 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
+ tests/PackageTests/TemplateHaskell/profiling/Exe.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import TH++main = print $(splice)
+ tests/PackageTests/TemplateHaskell/profiling/Lib.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Lib where++import TH++val = $(splice)
+ tests/PackageTests/TemplateHaskell/profiling/TH.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}+module TH where++splice = [| () |]
+ 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
+ tests/PackageTests/TemplateHaskell/vanilla/Exe.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import TH++main = print $(splice)
+ tests/PackageTests/TemplateHaskell/vanilla/Lib.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Lib where++import TH++val = $(splice)
+ tests/PackageTests/TemplateHaskell/vanilla/TH.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}+module TH where++splice = [| () |]
+ tests/PackageTests/TemplateHaskell/vanilla/my.cabal view
@@ -0,0 +1,15 @@+Name: templateHaskell+Version: 0.1+Build-Type: Simple+Cabal-Version: >= 1.2++Library+    Exposed-Modules: Lib+    Other-Modules: TH+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell++Executable main+    Main-is: Exe.hs+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell
tests/PackageTests/TestOptions/Check.hs view
@@ -1,16 +1,15 @@ module PackageTests.TestOptions.Check where -import Test.HUnit-import System.FilePath import PackageTests.PackageTester+import System.FilePath+import Test.HUnit -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"]+suite :: FilePath -> Test+suite ghcPath = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "TestOptions")+               ["--enable-tests"]+    _ <- cabal_build spec ghcPath+    result <- cabal_test spec ["--test-options=1 2 3"] ghcPath     let message = "\"cabal test\" did not pass the correct options to the "                   ++ "test executable with \"--test-options\""     assertEqual message True $ successful result@@ -18,6 +17,7 @@                                , "--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'+               ghcPath+    let message' = "\"cabal test\" did not pass the correct options to the "+                   ++ "test executable with \"--test-option\""+    assertEqual message' True $ successful result'
+ 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
+ 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
tests/PackageTests/TestStanza/Check.hs view
@@ -3,41 +3,28 @@ 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.Parse (readPackageDescription) import Distribution.PackageDescription.Configuration-        ( finalizePackageDescription )-import Distribution.Package-        ( PackageIdentifier(..), PackageName(..), Dependency(..) )+    (finalizePackageDescription)+import Distribution.Package (PackageName(..), Dependency(..)) import Distribution.PackageDescription-        ( PackageDescription(..), BuildInfo(..), TestSuite(..), Library(..)-        , TestSuiteInterface(..)-        , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary-        , emptyTestSuite, BuildType(..) )+    ( PackageDescription(..), BuildInfo(..), TestSuite(..)+    , TestSuiteInterface(..), emptyBuildInfo, emptyTestSuite) import Distribution.Verbosity (silent)-import Distribution.License (License(..))-import Distribution.ModuleName (fromString) import Distribution.System (buildPlatform)-import Distribution.Compiler-        ( CompilerId(..), CompilerFlavor(..) )+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+suite :: FilePath -> Test+suite ghcPath = TestCase $ do+    let dir = "PackageTests" </> "TestStanza"+        pdFile = dir </> "my" <.> "cabal"+        spec = PackageSpec dir []+    result <- cabal_configure spec ghcPath+    assertOutputDoesNotContain "unknown section type" result     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"
+ 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
tests/PackageTests/TestSuiteExeV10/Check.hs view
@@ -3,45 +3,63 @@        , checkTestWithHpc        ) where -import Distribution.PackageDescription ( TestSuite(..), emptyTestSuite )+import Distribution.PackageDescription     ( TestSuite(..), emptyTestSuite )+import Distribution.Version                ( Version(..), orLaterVersion ) import Distribution.Simple.Hpc-import Distribution.Version-import Test.HUnit+import Distribution.Simple.Program.Builtin ( hpcProgram )+import Distribution.Simple.Program.Db      ( emptyProgramDb, configureProgram,+                                             requireProgramVersion )+import PackageTests.PackageTester+import qualified Control.Exception as E    ( IOException, catch )+import Control.Monad                       ( when ) import System.Directory import System.FilePath-import PackageTests.PackageTester+import Test.HUnit +import qualified Distribution.Verbosity as Verbosity+ dir :: FilePath dir = "PackageTests" </> "TestSuiteExeV10" -checkTest :: Version -> Test-checkTest cabalVersion = TestCase $ do+checkTest :: FilePath -> Test+checkTest ghcPath = 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+    buildResult <- cabal_build spec ghcPath+    assertBuildSucceeded buildResult+    testResult <- cabal_test spec [] ghcPath+    assertTestSucceeded 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+checkTestWithHpc :: FilePath -> Test+checkTestWithHpc ghcPath = TestCase $ do+    isCorrectVersion <- checkHpcVersion+    when isCorrectVersion $ do+      let spec = PackageSpec dir [ "--enable-tests"+                                 , "--enable-library-coverage"+                                 ]+      buildResult <- cabal_build spec ghcPath+      assertBuildSucceeded buildResult+      testResult <- cabal_test spec [] ghcPath+      assertTestSucceeded 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+  where+    checkHpcVersion :: IO Bool+    checkHpcVersion = do+      let programDb' = emptyProgramDb+      let verbosity = Verbosity.normal+      let verRange  = orLaterVersion (Version [0,7] [])+      programDb <- configureProgram verbosity hpcProgram programDb'+      (requireProgramVersion verbosity hpcProgram verRange programDb+       >> return True) `catchIO` (\_ -> return False)++    -- Distirubution.Compat.Exception is hidden.+    catchIO :: IO a -> (E.IOException -> IO a) -> IO a+    catchIO = E.catch
+ tests/PackageTests/TestSuiteExeV10/Foo.hs view
@@ -0,0 +1,4 @@+module Foo where++fooTest :: [String] -> Bool+fooTest _ = True
+ 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
+ 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
+ tests/README view
@@ -0,0 +1,22 @@+Writing Package Tests+=====================++The tests under the `PackageTests` directory define and build packages which+exercise various components of Cabal. Each test case is an `HUnit` test. The+entry point for the test suite, where all the test cases are listed, is+`PackageTests.hs`. There are utilites for calling the stages of Cabal's build+process in `PackageTests/PackageTester.hs`; have a look at an existing test case+to see how they're used.++It is very important that package tests use the in-place version of Cabal,+rather than the system version. Several long-standing bugs in the test suite+were caused by testing the system (rather than the newly-compiled) version of+Cabal. There are two places where the system Cabal can accidentally be invoked:+1. Compiling `Setup.hs`. `runghc` needs to be told about the in-place package+database. This issue should be solved for all future package tests; see+`compileSetup` in `PackageTests/PackageTester.hs`.+2. Compiling a package which depends on Cabal. In particular, packages with+`detailed` type test suites depend on the Cabal library directly, so it is+important that they are configured to use the in-place package database. The+test suite already creates a stub `PackageSpec` for this case; see+`PackageTests/BuildTestSuiteDetailedV09/Check.hs` to see how it is used.
+ tests/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ tests/UnitTests.hs view
@@ -0,0 +1,16 @@+module Main+    ( main+    ) where++import Test.Framework++import qualified UnitTests.Distribution.Compat.ReadP++tests :: [Test]+tests = [+    testGroup "Distribution.Compat.ReadP"+        UnitTests.Distribution.Compat.ReadP.tests+    ]++main :: IO ()+main = defaultMain tests
+ tests/UnitTests/Distribution/Compat/ReadP.hs view
@@ -0,0 +1,154 @@+-----------------------------------------------------------------------------+-- |+-- 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.QuickCheck2++tests :: [Test]+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 :: Bool+prop_Get_Nil =+  readP_to_S get [] =~ []++prop_Get_Cons :: Char -> [Char] -> Bool+prop_Get_Cons c s =+  readP_to_S get (c:s) =~ [(c,s)]++prop_Look :: String -> Bool+prop_Look s =+  readP_to_S look s =~ [(s,s)]++prop_Fail :: String -> Bool+prop_Fail s =+  readP_to_S pfail s =~. []++prop_Return :: Int -> String -> Bool+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 :: ReadP Int Int -> ReadP Int Int -> String -> Bool+prop_Plus p q s =+  readP_to_S (p +++ q) s =~.+    (readP_to_S p s ++ readP_to_S q s)++prop_LeftPlus :: ReadP Int Int -> ReadP Int Int -> String -> Bool+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 :: String -> [Char] -> Bool+prop_String_Yes this s =+  readP_to_S (string this) (this ++ s) =~+    [(this,s)]++prop_String_Maybe :: String -> String -> Bool+prop_String_Maybe this s =+  readP_to_S (string this) s =~+    [(this, drop (length this) s) | this `isPrefixOf` s]++prop_Munch :: (Char -> Bool) -> String -> Bool+prop_Munch p s =+  readP_to_S (munch p) s =~+    [(takeWhile p s, dropWhile p s)]++prop_Munch1 :: (Char -> Bool) -> String -> Bool+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 :: [ReadP Int Int] -> String -> Bool+prop_Choice ps s =+  readP_to_S (choice ps) s =~.+    readP_to_S (foldr (+++) pfail ps) s++prop_ReadS :: ReadS Int -> String -> Bool+prop_ReadS r s =+  readP_to_S (readS_to_P r) s =~. r s+-}++evenChar :: Char -> Bool+evenChar = even . fromEnum+
+ 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
+ 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
+ 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
+ tests/misc/ghc-supported-languages.hs view
@@ -0,0 +1,97 @@+-- | 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 []++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)
− tests/suite.hs 
@@ -1,80 +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.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,-        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)-