diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -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 +license: BSD3 +license-file: LICENSE +author: Isaac Jones Duncan Coutts -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 diff --git a/Distribution/Compat/CopyFile.hs b/Distribution/Compat/CopyFile.hs --- a/Distribution/Compat/CopyFile.hs +++ b/Distribution/Compat/CopyFile.hs @@ -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 diff --git a/Distribution/Compat/Environment.hs b/Distribution/Compat/Environment.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Environment.hs @@ -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 diff --git a/Distribution/Compat/Exception.hs b/Distribution/Compat/Exception.hs --- a/Distribution/Compat/Exception.hs +++ b/Distribution/Compat/Exception.hs @@ -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 - diff --git a/Distribution/Compat/ReadP.hs b/Distribution/Compat/ReadP.hs --- a/Distribution/Compat/ReadP.hs +++ b/Distribution/Compat/ReadP.hs @@ -19,6 +19,8 @@ -- This version of ReadP has been locally hacked to make it H98, by -- Martin Sjögren -- +-- The unit tests have been moved to UnitTest.Distribution.Compat.ReadP, by +-- Mark Lentczner ----------------------------------------------------------------------------- module Distribution.Compat.ReadP @@ -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 --} diff --git a/Distribution/Compat/TempFile.hs b/Distribution/Compat/TempFile.hs --- a/Distribution/Compat/TempFile.hs +++ b/Distribution/Compat/TempFile.hs @@ -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 diff --git a/Distribution/Compiler.hs b/Distribution/Compiler.hs --- a/Distribution/Compiler.hs +++ b/Distribution/Compiler.hs @@ -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. diff --git a/Distribution/GetOpt.hs b/Distribution/GetOpt.hs --- a/Distribution/GetOpt.hs +++ b/Distribution/GetOpt.hs @@ -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) diff --git a/Distribution/InstalledPackageInfo.hs b/Distribution/InstalledPackageInfo.hs --- a/Distribution/InstalledPackageInfo.hs +++ b/Distribution/InstalledPackageInfo.hs @@ -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 diff --git a/Distribution/License.hs b/Distribution/License.hs --- a/Distribution/License.hs +++ b/Distribution/License.hs @@ -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 diff --git a/Distribution/Make.hs b/Distribution/Make.hs --- a/Distribution/Make.hs +++ b/Distribution/Make.hs @@ -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 " diff --git a/Distribution/ModuleName.hs b/Distribution/ModuleName.hs --- a/Distribution/ModuleName.hs +++ b/Distribution/ModuleName.hs @@ -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 diff --git a/Distribution/Package.hs b/Distribution/Package.hs --- a/Distribution/Package.hs +++ b/Distribution/Package.hs @@ -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) = diff --git a/Distribution/PackageDescription.hs b/Distribution/PackageDescription.hs --- a/Distribution/PackageDescription.hs +++ b/Distribution/PackageDescription.hs @@ -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) = diff --git a/Distribution/PackageDescription/Check.hs b/Distribution/PackageDescription/Check.hs --- a/Distribution/PackageDescription/Check.hs +++ b/Distribution/PackageDescription/Check.hs @@ -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) diff --git a/Distribution/PackageDescription/Configuration.hs b/Distribution/PackageDescription/Configuration.hs --- a/Distribution/PackageDescription/Configuration.hs +++ b/Distribution/PackageDescription/Configuration.hs @@ -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." diff --git a/Distribution/PackageDescription/Parse.hs b/Distribution/PackageDescription/Parse.hs --- a/Distribution/PackageDescription/Parse.hs +++ b/Distribution/PackageDescription/Parse.hs @@ -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." diff --git a/Distribution/PackageDescription/PrettyPrint.hs b/Distribution/PackageDescription/PrettyPrint.hs --- a/Distribution/PackageDescription/PrettyPrint.hs +++ b/Distribution/PackageDescription/PrettyPrint.hs @@ -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 diff --git a/Distribution/PackageDescription/Utils.hs b/Distribution/PackageDescription/Utils.hs new file mode 100644 --- /dev/null +++ b/Distribution/PackageDescription/Utils.hs @@ -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" diff --git a/Distribution/ParseUtils.hs b/Distribution/ParseUtils.hs --- a/Distribution/ParseUtils.hs +++ b/Distribution/ParseUtils.hs @@ -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) diff --git a/Distribution/ReadE.hs b/Distribution/ReadE.hs --- a/Distribution/ReadE.hs +++ b/Distribution/ReadE.hs @@ -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 diff --git a/Distribution/Simple.hs b/Distribution/Simple.hs --- a/Distribution/Simple.hs +++ b/Distribution/Simple.hs @@ -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 () diff --git a/Distribution/Simple/Bench.hs b/Distribution/Simple/Bench.hs --- a/Distribution/Simple/Bench.hs +++ b/Distribution/Simple/Bench.hs @@ -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)] diff --git a/Distribution/Simple/Build.hs b/Distribution/Simple/Build.hs --- a/Distribution/Simple/Build.hs +++ b/Distribution/Simple/Build.hs @@ -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" diff --git a/Distribution/Simple/Build/Macros.hs b/Distribution/Simple/Build/Macros.hs --- a/Distribution/Simple/Build/Macros.hs +++ b/Distribution/Simple/Build/Macros.hs @@ -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) ] diff --git a/Distribution/Simple/Build/PathsModule.hs b/Distribution/Simple/Build/PathsModule.hs --- a/Distribution/Simple/Build/PathsModule.hs +++ b/Distribution/Simple/Build/PathsModule.hs @@ -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 = diff --git a/Distribution/Simple/BuildPaths.hs b/Distribution/Simple/BuildPaths.hs --- a/Distribution/Simple/BuildPaths.hs +++ b/Distribution/Simple/BuildPaths.hs @@ -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- -- 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 -- ------------------------------------------------------------ diff --git a/Distribution/Simple/BuildTarget.hs b/Distribution/Simple/BuildTarget.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/BuildTarget.hs @@ -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 diff --git a/Distribution/Simple/CCompiler.hs b/Distribution/Simple/CCompiler.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/CCompiler.hs @@ -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 diff --git a/Distribution/Simple/Command.hs b/Distribution/Simple/Command.hs --- a/Distribution/Simple/Command.hs +++ b/Distribution/Simple/Command.hs @@ -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" diff --git a/Distribution/Simple/Compiler.hs b/Distribution/Simple/Compiler.hs --- a/Distribution/Simple/Compiler.hs +++ b/Distribution/Simple/Compiler.hs @@ -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 diff --git a/Distribution/Simple/Configure.hs b/Distribution/Simple/Configure.hs --- a/Distribution/Simple/Configure.hs +++ b/Distribution/Simple/Configure.hs @@ -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) diff --git a/Distribution/Simple/GHC.hs b/Distribution/Simple/GHC.hs --- a/Distribution/Simple/GHC.hs +++ b/Distribution/Simple/GHC.hs @@ -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 diff --git a/Distribution/Simple/Haddock.hs b/Distribution/Simple/Haddock.hs --- a/Distribution/Simple/Haddock.hs +++ b/Distribution/Simple/Haddock.hs @@ -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 } diff --git a/Distribution/Simple/Hpc.hs b/Distribution/Simple/Hpc.hs --- a/Distribution/Simple/Hpc.hs +++ b/Distribution/Simple/Hpc.hs @@ -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 diff --git a/Distribution/Simple/Hugs.hs b/Distribution/Simple/Hugs.hs --- a/Distribution/Simple/Hugs.hs +++ b/Distribution/Simple/Hugs.hs @@ -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] diff --git a/Distribution/Simple/Install.hs b/Distribution/Simple/Install.hs --- a/Distribution/Simple/Install.hs +++ b/Distribution/Simple/Install.hs @@ -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 diff --git a/Distribution/Simple/InstallDirs.hs b/Distribution/Simple/InstallDirs.hs --- a/Distribution/Simple/InstallDirs.hs +++ b/Distribution/Simple/InstallDirs.hs @@ -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 diff --git a/Distribution/Simple/JHC.hs b/Distribution/Simple/JHC.hs --- a/Distribution/Simple/JHC.hs +++ b/Distribution/Simple/JHC.hs @@ -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) - diff --git a/Distribution/Simple/LHC.hs b/Distribution/Simple/LHC.hs --- a/Distribution/Simple/LHC.hs +++ b/Distribution/Simple/LHC.hs @@ -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)) diff --git a/Distribution/Simple/LocalBuildInfo.hs b/Distribution/Simple/LocalBuildInfo.hs --- a/Distribution/Simple/LocalBuildInfo.hs +++ b/Distribution/Simple/LocalBuildInfo.hs @@ -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) diff --git a/Distribution/Simple/NHC.hs b/Distribution/Simple/NHC.hs --- a/Distribution/Simple/NHC.hs +++ b/Distribution/Simple/NHC.hs @@ -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 diff --git a/Distribution/Simple/PreProcess.hs b/Distribution/Simple/PreProcess.hs --- a/Distribution/Simple/PreProcess.hs +++ b/Distribution/Simple/PreProcess.hs @@ -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 } diff --git a/Distribution/Simple/Program.hs b/Distribution/Simple/Program.hs --- a/Distribution/Simple/Program.hs +++ b/Distribution/Simple/Program.hs @@ -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 diff --git a/Distribution/Simple/Program/Builtin.hs b/Distribution/Simple/Program/Builtin.hs --- a/Distribution/Simple/Program/Builtin.hs +++ b/Distribution/Simple/Program/Builtin.hs @@ -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 diff --git a/Distribution/Simple/Program/Db.hs b/Distribution/Simple/Program/Db.hs --- a/Distribution/Simple/Program/Db.hs +++ b/Distribution/Simple/Program/Db.hs @@ -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) diff --git a/Distribution/Simple/Program/Find.hs b/Distribution/Simple/Program/Find.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/Find.hs @@ -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)) diff --git a/Distribution/Simple/Program/GHC.hs b/Distribution/Simple/Program/GHC.hs --- a/Distribution/Simple/Program/GHC.hs +++ b/Distribution/Simple/Program/GHC.hs @@ -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, diff --git a/Distribution/Simple/Program/HcPkg.hs b/Distribution/Simple/Program/HcPkg.hs --- a/Distribution/Simple/Program/HcPkg.hs +++ b/Distribution/Simple/Program/HcPkg.hs @@ -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. diff --git a/Distribution/Simple/Program/Hpc.hs b/Distribution/Simple/Program/Hpc.hs --- a/Distribution/Simple/Program/Hpc.hs +++ b/Distribution/Simple/Program/Hpc.hs @@ -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 diff --git a/Distribution/Simple/Program/Run.hs b/Distribution/Simple/Program/Run.hs --- a/Distribution/Simple/Program/Run.hs +++ b/Distribution/Simple/Program/Run.hs @@ -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 diff --git a/Distribution/Simple/Program/Script.hs b/Distribution/Simple/Program/Script.hs --- a/Distribution/Simple/Program/Script.hs +++ b/Distribution/Simple/Program/Script.hs @@ -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 ++ "\"" diff --git a/Distribution/Simple/Program/Types.hs b/Distribution/Simple/Program/Types.hs --- a/Distribution/Simple/Program/Types.hs +++ b/Distribution/Simple/Program/Types.hs @@ -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 } diff --git a/Distribution/Simple/Register.hs b/Distribution/Simple/Register.hs --- a/Distribution/Simple/Register.hs +++ b/Distribution/Simple/Register.hs @@ -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) diff --git a/Distribution/Simple/Setup.hs b/Distribution/Simple/Setup.hs --- a/Distribution/Simple/Setup.hs +++ b/Distribution/Simple/Setup.hs @@ -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 [] diff --git a/Distribution/Simple/SrcDist.hs b/Distribution/Simple/SrcDist.hs --- a/Distribution/Simple/SrcDist.hs +++ b/Distribution/Simple/SrcDist.hs @@ -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 diff --git a/Distribution/Simple/Test.hs b/Distribution/Simple/Test.hs --- a/Distribution/Simple/Test.hs +++ b/Distribution/Simple/Test.hs @@ -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 - diff --git a/Distribution/Simple/UHC.hs b/Distribution/Simple/UHC.hs --- a/Distribution/Simple/UHC.hs +++ b/Distribution/Simple/UHC.hs @@ -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, "")] diff --git a/Distribution/Simple/UserHooks.hs b/Distribution/Simple/UserHooks.hs --- a/Distribution/Simple/UserHooks.hs +++ b/Distribution/Simple/UserHooks.hs @@ -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 () diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs --- a/Distribution/Simple/Utils.hs +++ b/Distribution/Simple/Utils.hs @@ -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 diff --git a/Distribution/System.hs b/Distribution/System.hs --- a/Distribution/System.hs +++ b/Distribution/System.hs @@ -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 diff --git a/Distribution/Version.hs b/Distribution/Version.hs --- a/Distribution/Version.hs +++ b/Distribution/Version.hs @@ -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] diff --git a/Language/Haskell/Extension.hs b/Language/Haskell/Extension.hs --- a/Language/Haskell/Extension.hs +++ b/Language/Haskell/Extension.hs @@ -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 § 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 § 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. + -- + -- * OverlappingInstances - -- | [GHC § 7.6.3.3] Ignore structural rules guaranteeing the - -- termination of class instance resolution. Termination is - -- guaranteed by a fixed-depth recursion stack, and compilation - -- may fail if this depth is exceeded. + -- | Ignore structural rules guaranteeing the termination of class + -- instance resolution. Termination is guaranteed by a fixed-depth + -- recursion stack, and compilation may fail if this depth is + -- exceeded. + -- + -- * | UndecidableInstances - -- | [GHC § 7.6.3.4] Implies 'OverlappingInstances'. Allow the - -- implementation to choose an instance even when it is possible - -- that further instantiation of types will lead to a more specific - -- instance being applicable. + -- | Implies 'OverlappingInstances'. Allow the implementation to + -- choose an instance even when it is possible that further + -- instantiation of types will lead to a more specific instance + -- being applicable. + -- + -- * | IncoherentInstances - -- | [GHC § 7.3.8] Allows recursive bindings in @do@ blocks, - -- using the @rec@ keyword. + -- | /(deprecated)/ Allows recursive bindings in @do@ blocks, using the @rec@ + -- keyword. See also 'RecursiveDo'. | DoRec - -- | [GHC § 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. + -- + -- * | RecursiveDo - -- | [GHC § 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. + -- + -- * | ParallelListComp - -- | [GHC § 7.6.1.1] Allow multiple parameters in a type class. + -- | Allow multiple parameters in a type class. + -- + -- * | MultiParamTypeClasses - -- | [GHC § 7.17] Enable the dreaded monomorphism restriction. + -- | Enable the dreaded monomorphism restriction. + -- + -- * | MonomorphismRestriction - -- | [GHC § 7.6.2] Allow a specification attached to a - -- multi-parameter type class which indicates that some parameters - -- are entirely determined by others. The implementation will check - -- that this property holds for the declared instances, and will use - -- this property to reduce ambiguity in instance resolution. + -- | Allow a specification attached to a multi-parameter type class + -- which indicates that some parameters are entirely determined by + -- others. The implementation will check that this property holds + -- for the declared instances, and will use this property to reduce + -- ambiguity in instance resolution. + -- + -- * | FunctionalDependencies - -- | [GHC § 7.8.5] Like 'RankNTypes' but does not allow a - -- higher-rank type to itself appear on the left of a function - -- arrow. + -- | Like 'RankNTypes' but does not allow a higher-rank type to + -- itself appear on the left of a function arrow. + -- + -- * | Rank2Types - -- | [GHC § 7.8.5] Allow a universally-quantified type to occur on - -- the left of a function arrow. + -- | Allow a universally-quantified type to occur on the left of a + -- function arrow. + -- + -- * | RankNTypes - -- | [GHC § 7.8.5] Allow data constructors to have polymorphic - -- arguments. Unlike 'RankNTypes', does not allow this for ordinary - -- functions. + -- | Allow data constructors to have polymorphic arguments. Unlike + -- 'RankNTypes', does not allow this for ordinary functions. + -- + -- * | PolymorphicComponents - -- | [GHC § 7.4.4] Allow existentially-quantified data constructors. + -- | Allow existentially-quantified data constructors. + -- + -- * | ExistentialQuantification - -- | [GHC § 7.8.7] Cause a type variable in a signature, which has an - -- explicit @forall@ quantifier, to scope over the definition of the + -- | Cause a type variable in a signature, which has an explicit + -- @forall@ quantifier, to scope over the definition of the -- accompanying value declaration. + -- + -- * | ScopedTypeVariables -- | Deprecated, use 'ScopedTypeVariables' instead. | PatternSignatures - -- | [GHC § 7.8.3] Enable implicit function parameters with dynamic - -- scope. + -- | Enable implicit function parameters with dynamic scope. + -- + -- * | ImplicitParams - -- | [GHC § 7.8.2] Relax some restrictions on the form of the context - -- of a type signature. + -- | Relax some restrictions on the form of the context of a type + -- signature. + -- + -- * | FlexibleContexts - -- | [GHC § 7.6.3.2] Relax some restrictions on the form of the - -- context of an instance declaration. + -- | Relax some restrictions on the form of the context of an + -- instance declaration. + -- + -- * | FlexibleInstances - -- | [GHC § 7.4.1] Allow data type declarations with no constructors. + -- | Allow data type declarations with no constructors. + -- + -- * | EmptyDataDecls - -- | [GHC § 4.10.3] Run the C preprocessor on Haskell source code. + -- | Run the C preprocessor on Haskell source code. + -- + -- * | CPP - -- | [GHC § 7.8.4] Allow an explicit kind signature giving the kind of - -- types over which a type variable ranges. + -- | Allow an explicit kind signature giving the kind of types over + -- which a type variable ranges. + -- + -- * | KindSignatures - -- | [GHC § 7.11] Enable a form of pattern which forces evaluation - -- before an attempted match, and a form of strict @let@/@where@ - -- binding. + -- | Enable a form of pattern which forces evaluation before an + -- attempted match, and a form of strict @let@/@where@ binding. + -- + -- * | BangPatterns - -- | [GHC § 7.6.3.1] Allow type synonyms in instance heads. + -- | Allow type synonyms in instance heads. + -- + -- * | TypeSynonymInstances - -- | [GHC § 7.9] Enable Template Haskell, a system for compile-time + -- | Enable Template Haskell, a system for compile-time -- metaprogramming. + -- + -- * | TemplateHaskell - -- | [GHC § 8] Enable the Foreign Function Interface. In GHC, - -- implements the standard Haskell 98 Foreign Function Interface - -- Addendum, plus some GHC-specific extensions. + -- | Enable the Foreign Function Interface. In GHC, implements the + -- standard Haskell 98 Foreign Function Interface Addendum, plus + -- some GHC-specific extensions. + -- + -- * | ForeignFunctionInterface - -- | [GHC § 7.10] Enable arrow notation. + -- | Enable arrow notation. + -- + -- * | Arrows - -- | [GHC § 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. + -- + -- * | Generics - -- | [GHC § 7.3.11] Enable the implicit importing of the module - -- @Prelude@. When disabled, when desugaring certain built-in syntax - -- into ordinary identifiers, use whatever is in scope rather than the - -- @Prelude@ -- version. + -- | Enable the implicit importing of the module "Prelude". When + -- disabled, when desugaring certain built-in syntax into ordinary + -- identifiers, use whatever is in scope rather than the "Prelude" + -- -- version. + -- + -- * | ImplicitPrelude - -- | [GHC § 7.3.15] Enable syntax for implicitly binding local names - -- corresponding to the field names of a record. Puns bind specific - -- names, unlike 'RecordWildCards'. + -- | Enable syntax for implicitly binding local names corresponding + -- to the field names of a record. Puns bind specific names, unlike + -- 'RecordWildCards'. + -- + -- * | NamedFieldPuns - -- | [GHC § 7.3.5] Enable a form of guard which matches a pattern and - -- binds variables. + -- | Enable a form of guard which matches a pattern and binds + -- variables. + -- + -- * | PatternGuards - -- | [GHC § 7.5.4] Allow a type declared with @newtype@ to use - -- @deriving@ for any class with an instance for the underlying type. + -- | Allow a type declared with @newtype@ to use @deriving@ for any + -- class with an instance for the underlying type. + -- + -- * | GeneralizedNewtypeDeriving - -- | [Hugs § 7.1] Enable the \"Trex\" extensible records system. + -- | Enable the \"Trex\" extensible records system. + -- + -- * | ExtensibleRecords - -- | [Hugs § 7.2] Enable type synonyms which are transparent in - -- some definitions and opaque elsewhere, as a way of implementing - -- abstract datatypes. + -- | Enable type synonyms which are transparent in some definitions + -- and opaque elsewhere, as a way of implementing abstract + -- datatypes. + -- + -- * | RestrictedTypeSynonyms - -- | [Hugs § 7.3] Enable an alternate syntax for string literals, + -- | Enable an alternate syntax for string literals, -- with string templating. + -- + -- * | HereDocuments - -- | [GHC § 7.3.2] Allow the character @#@ as a postfix modifier on - -- identifiers. Also enables literal syntax for unboxed values. + -- | Allow the character @#@ as a postfix modifier on identifiers. + -- Also enables literal syntax for unboxed values. + -- + -- * | MagicHash - -- | [GHC § 7.7] Allow data types and type synonyms which are - -- indexed by types, i.e. ad-hoc polymorphism for types. + -- | Allow data types and type synonyms which are indexed by types, + -- i.e. ad-hoc polymorphism for types. + -- + -- * | TypeFamilies - -- | [GHC § 7.5.2] Allow a standalone declaration which invokes the - -- type class @deriving@ mechanism. + -- | Allow a standalone declaration which invokes the type class + -- @deriving@ mechanism. + -- + -- * | StandaloneDeriving - -- | [GHC § 7.3.1] Allow certain Unicode characters to stand for - -- certain ASCII character sequences, e.g. keywords and punctuation. + -- | Allow certain Unicode characters to stand for certain ASCII + -- character sequences, e.g. keywords and punctuation. + -- + -- * | UnicodeSyntax - -- | [GHC § 8.1.1] Allow the use of unboxed types as foreign types, - -- e.g. in @foreign import@ and @foreign export@. + -- | Allow the use of unboxed types as foreign types, e.g. in + -- @foreign import@ and @foreign export@. + -- + -- * | UnliftedFFITypes - -- | [GHC § 7.4.3] Defer validity checking of types until after - -- expanding type synonyms, relaxing the constraints on how synonyms - -- may be used. + -- | Enable interruptible FFI. + -- + -- * + | InterruptibleFFI + + -- | Allow use of CAPI FFI calling convention (@foreign import capi@). + -- + -- * + | CApiFFI + + -- | Defer validity checking of types until after expanding type + -- synonyms, relaxing the constraints on how synonyms may be used. + -- + -- * | LiberalTypeSynonyms - -- | [GHC § 7.4.2] Allow the name of a type constructor, type class, - -- or type variable to be an infix operator. + -- | Allow the name of a type constructor, type class, or type + -- variable to be an infix operator. | TypeOperators ---PArr -- not ready yet, and will probably be renamed to ParallelArrays - - -- | [GHC § 7.3.16] Enable syntax for implicitly binding local names - -- corresponding to the field names of a record. A wildcard binds - -- all unmentioned names, unlike 'NamedFieldPuns'. + -- | Enable syntax for implicitly binding local names corresponding + -- to the field names of a record. A wildcard binds all unmentioned + -- names, unlike 'NamedFieldPuns'. + -- + -- * | RecordWildCards -- | Deprecated, use 'NamedFieldPuns' instead. | RecordPuns - -- | [GHC § 7.3.14] Allow a record field name to be disambiguated - -- by the type of the record it's in. + -- | Allow a record field name to be disambiguated by the type of + -- the record it's in. + -- + -- * | DisambiguateRecordFields - -- | [GHC § 7.6.4] Enable overloading of string literals using a - -- type class, much like integer literals. + -- | Enable traditional record syntax (as supported by Haskell 98) + -- + -- * + | TraditionalRecordSyntax + + -- | Enable overloading of string literals using a type class, much + -- like integer literals. + -- + -- * | OverloadedStrings - -- | [GHC § 7.4.6] Enable generalized algebraic data types, in - -- which type variables may be instantiated on a per-constructor - -- basis. Implies GADTSyntax. + -- | Enable generalized algebraic data types, in which type + -- variables may be instantiated on a per-constructor basis. Implies + -- 'GADTSyntax'. + -- + -- * | GADTs -- | Enable GADT syntax for declaring ordinary algebraic datatypes. + -- + -- * | GADTSyntax - -- | [GHC § 7.17.2] Make pattern bindings monomorphic. + -- | Make pattern bindings monomorphic. + -- + -- * | MonoPatBinds - -- | [GHC § 7.8.8] Relax the requirements on mutually-recursive - -- polymorphic functions. + -- | Relax the requirements on mutually-recursive polymorphic + -- functions. + -- + -- * | RelaxedPolyRec - -- | [GHC § 2.4.5] Allow default instantiation of polymorphic - -- types in more situations. + -- | Allow default instantiation of polymorphic types in more + -- situations. + -- + -- * | ExtendedDefaultRules - -- | [GHC § 7.2.2] Enable unboxed tuples. + -- | Enable unboxed tuples. + -- + -- * | UnboxedTuples - -- | [GHC § 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'. + -- + -- * | DeriveDataTypeable - -- | [GHC § 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'. + -- + -- * + | DeriveGeneric + + -- | Enable support for default signatures. + -- + -- * + | DefaultSignatures + + -- | Allow type signatures to be specified in instance declarations. + -- + -- * + | InstanceSigs + + -- | Allow a class method's type to place additional constraints on + -- a class type variable. + -- + -- * | ConstrainedClassMethods - -- | [GHC § 7.3.18] Allow imports to be qualified by the package - -- name the module is intended to be imported from, e.g. + -- | Allow imports to be qualified by the package name the module is + -- intended to be imported from, e.g. -- -- > import "network" Network.Socket + -- + -- * | PackageImports - -- | [GHC § 7.8.6] Deprecated in GHC 6.12 and will be removed in - -- GHC 7. Allow a type variable to be instantiated at a + -- | /(deprecated)/ Allow a type variable to be instantiated at a -- polymorphic type. + -- + -- * | ImpredicativeTypes - -- | [GHC § 7.3.3] Change the syntax for qualified infix - -- operators. + -- | /(deprecated)/ Change the syntax for qualified infix operators. + -- + -- * | NewQualifiedOperators - -- | [GHC § 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. + -- + -- * | PostfixOperators - -- | [GHC § 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. + -- + -- * | QuasiQuotes - -- | [GHC § 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. + -- + -- * | TransformListComp - -- | [GHC § 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. + -- + -- * + | MonadComprehensions + + -- | Enable view patterns, which match a value by applying a + -- function and matching on the result. + -- + -- * | ViewPatterns -- | Allow concrete XML syntax to be used in expressions and patterns, @@ -395,6 +535,8 @@ -- | Enables the use of tuple sections, e.g. @(, True)@ desugars into -- @\x -> (x, True)@. + -- + -- * | TupleSections -- | Allows GHC primops, written in C--, to be imported into a Haskell @@ -403,65 +545,167 @@ -- | Support for patterns of the form @n + k@, where @k@ is an -- integer literal. + -- + -- * | NPlusKPatterns -- | Improve the layout rule when @if@ expressions are used in a @do@ -- block. | DoAndIfThenElse + -- | Enable support for multi-way @if@-expressions. + -- + -- * + | MultiWayIf + + -- | Enable support lambda-@case@ expressions. + -- + -- * + | LambdaCase + -- | Makes much of the Haskell sugar be desugared into calls to the -- function with a particular name that is in scope. + -- + -- * | RebindableSyntax -- | Make @forall@ a keyword in types, which can be used to give the -- generalisation explicitly. + -- + -- * | ExplicitForAll -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. + -- + -- * | DatatypeContexts -- | Local (@let@ and @where@) bindings are monomorphic. + -- + -- * | MonoLocalBinds - -- | Enable @deriving@ for the @Data.Functor.Functor@ class. + -- | Enable @deriving@ for the 'Data.Functor.Functor' class. + -- + -- * | DeriveFunctor - -- | Enable @deriving@ for the @Data.Traversable.Traversable@ class. + -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class. + -- + -- * | DeriveTraversable - -- | Enable @deriving@ for the @Data.Foldable.Foldable@ class. + -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class. + -- + -- * | DeriveFoldable - -- | Enable non-decreasing indentation for 'do' blocks. + -- | Enable non-decreasing indentation for @do@ blocks. + -- + -- * | NondecreasingIndentation - -- | [GHC § 7.20.3] Allow imports to be qualified with a safe - -- keyword that requires the imported module be trusted as according - -- to the Safe Haskell definition of trust. + -- | Allow imports to be qualified with a safe keyword that requires + -- the imported module be trusted as according to the Safe Haskell + -- definition of trust. -- -- > import safe Network.Socket + -- + -- * | SafeImports - -- | [GHC § 7.20] Compile a module in the Safe, Safe Haskell - -- mode -- a restricted form of the Haskell language to ensure - -- type safety. + -- | Compile a module in the Safe, Safe Haskell mode -- a restricted + -- form of the Haskell language to ensure type safety. + -- + -- * | Safe - -- | [GHC § 7.20] Compile a module in the Trustworthy, Safe - -- Haskell mode -- no restrictions apply but the module is marked - -- as trusted as long as the package the module resides in is - -- trusted. + -- | Compile a module in the Trustworthy, Safe Haskell mode -- no + -- restrictions apply but the module is marked as trusted as long as + -- the package the module resides in is trusted. + -- + -- * | Trustworthy - -- | [GHC § 7.40] Allow type class/implicit parameter/equality - -- constraints to be used as types with the special kind Constraint. - -- Also generalise the (ctxt => ty) syntax so that any type of kind - -- Constraint can occur before the arrow. + -- | Compile a module in the Unsafe, Safe Haskell mode so that + -- modules compiled using Safe, Safe Haskell mode can't import it. + -- + -- * + | 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. + -- + -- * | ConstraintKinds - deriving (Show, Read, Eq, Enum, Bounded) + -- | Enable kind polymorphism. + -- + -- * + | PolyKinds + -- | Enable datatype promotion. + -- + -- * + | DataKinds + + -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/. + -- + -- * + | ParallelArrays + + -- | Enable explicit role annotations, like in (@data T a\@R@). + -- + -- * + | RoleAnnotations + + -- | Enable overloading of list literals, arithmetic sequences and + -- list patterns using the 'IsList' type class. + -- + -- * + | OverloadedLists + + -- | Enables case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled. + -- + -- * + | EmptyCase + + -- | Triggers the generation of derived 'Typeable' instances for every + -- datatype and type class declaration. + -- + -- * + | AutoDeriveTypeable + + -- | Desugars negative literals directly (without using negate). + -- + -- * + | NegativeLiterals + + -- | Allows the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'. + -- + -- * + | NumDecimals + + -- | Enables support for type classes with no type parameter. + -- + -- * + | NullaryTypeClasses + + -- | Enable explicit namespaces in module import/export lists. + -- + -- * + | ExplicitNamespaces + + -- | Allow the user to write ambiguous types, and the type inference engine to infer them. + -- + -- * + | 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 ] - diff --git a/README b/README --- a/README +++ b/README @@ -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 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -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 diff --git a/tests/Distribution/Compat/CreatePipe.hsc b/tests/Distribution/Compat/CreatePipe.hsc new file mode 100644 --- /dev/null +++ b/tests/Distribution/Compat/CreatePipe.hsc @@ -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 /* for _close and _pipe */ +# include /* 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 diff --git a/tests/PackageTests.hs b/tests/PackageTests.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests.hs @@ -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." diff --git a/tests/PackageTests/BenchmarkExeV10/Check.hs b/tests/PackageTests/BenchmarkExeV10/Check.hs --- a/tests/PackageTests/BenchmarkExeV10/Check.hs +++ b/tests/PackageTests/BenchmarkExeV10/Check.hs @@ -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 diff --git a/tests/PackageTests/BenchmarkExeV10/Foo.hs b/tests/PackageTests/BenchmarkExeV10/Foo.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkExeV10/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +fooTest :: [String] -> Bool +fooTest _ = True diff --git a/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs b/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs @@ -0,0 +1,8 @@ +module Main where + +import Foo +import System.Exit + +main :: IO () +main | fooTest [] = exitSuccess + | otherwise = exitFailure diff --git a/tests/PackageTests/BenchmarkExeV10/my.cabal b/tests/PackageTests/BenchmarkExeV10/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkExeV10/my.cabal @@ -0,0 +1,15 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.9.2 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base + +benchmark bench-Foo + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: bench-Foo.hs + build-depends: base, my diff --git a/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal b/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal @@ -0,0 +1,20 @@ +name: BenchmarkOptions +version: 0.1 +license: BSD3 +author: Johan Tibell +stability: stable +category: PackageTests +build-type: Simple +cabal-version: >= 1.9.2 + +description: + Check that Cabal passes the correct test options to test suites. + +executable dummy + main-is: test-BenchmarkOptions.hs + build-depends: base + +benchmark test-BenchmarkOptions + main-is: test-BenchmarkOptions.hs + type: exitcode-stdio-1.0 + build-depends: base diff --git a/tests/PackageTests/BenchmarkOptions/Check.hs b/tests/PackageTests/BenchmarkOptions/Check.hs --- a/tests/PackageTests/BenchmarkOptions/Check.hs +++ b/tests/PackageTests/BenchmarkOptions/Check.hs @@ -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' diff --git a/tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs b/tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs @@ -0,0 +1,11 @@ +module Main where + +import System.Environment ( getArgs ) +import System.Exit ( exitFailure, exitSuccess ) + +main :: IO () +main = do + args <- getArgs + if args == ["1", "2", "3"] + then exitSuccess + else putStrLn ("Got: " ++ show args) >> exitFailure diff --git a/tests/PackageTests/BenchmarkStanza/Check.hs b/tests/PackageTests/BenchmarkStanza/Check.hs --- a/tests/PackageTests/BenchmarkStanza/Check.hs +++ b/tests/PackageTests/BenchmarkStanza/Check.hs @@ -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" diff --git a/tests/PackageTests/BenchmarkStanza/my.cabal b/tests/PackageTests/BenchmarkStanza/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkStanza/my.cabal @@ -0,0 +1,19 @@ +name: BenchmarkStanza +version: 0.1 +license: BSD3 +author: Johan Tibell +stability: stable +category: PackageTests +build-type: Simple + +description: + Check that Cabal recognizes the benchmark stanza defined below. + +Library + exposed-modules: MyLibrary + build-depends: base + +benchmark dummy + main-is: dummy.hs + type: exitcode-stdio-1.0 + build-depends: base diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs --- a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs @@ -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'" diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal @@ -0,0 +1,20 @@ +name: GlobalBuildDepsNotAdditive1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + If you specify 'base' in the global build dependencies, then define + a library without base, it fails to find 'base' for the library. + +--------------------------------------- + +build-depends: base + +Library + exposed-modules: MyLibrary + build-depends: bytestring, old-time diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs --- a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs @@ -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'" diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal @@ -0,0 +1,20 @@ +name: GlobalBuildDepsNotAdditive1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + If you specify 'base' in the global build dependencies, then define + an executable without base, it fails to find 'base' for the executable + +--------------------------------------- + +build-depends: base + +Executable lemon + main-is: lemon.hs + build-depends: bytestring, old-time diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs --- a/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs @@ -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 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs b/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal @@ -0,0 +1,24 @@ +name: InternalLibrary0 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check that with 'cabal-version:' containing versions less than 1.7, we do *not* + have the new behaviour to allow executables to refer to the library defined + in the same module. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary0 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs b/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs --- a/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs @@ -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 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs b/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new (in >= 1.7.1) ability to allow executables to refer to + the library defined in the same module. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary1 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs b/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs --- a/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs @@ -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) diff --git a/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs b/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary2 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name and version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary2 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs b/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs b/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal @@ -0,0 +1,18 @@ +name: InternalLibrary2 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name and version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time diff --git a/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs --- a/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs @@ -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) diff --git a/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs b/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary3 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name, but a *newer* version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary3 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs b/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs b/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal @@ -0,0 +1,18 @@ +name: InternalLibrary3 +version: 0.2 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name but a *newer* version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time diff --git a/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs --- a/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs @@ -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) diff --git a/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs b/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary4 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that we can explicitly say we want InternalLibrary4-0.2 + and it will give us the *installed* version 0.2 instead of the internal 0.1. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary4 >= 0.2 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs b/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs b/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal @@ -0,0 +1,18 @@ +name: InternalLibrary4 +version: 0.2 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name but a *newer* version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time diff --git a/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs b/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs --- a/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs +++ b/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs @@ -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) diff --git a/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs b/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal b/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal @@ -0,0 +1,31 @@ +name: SameDepsAllRound +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +synopsis: Same dependencies all round +category: PackageTests +build-type: Simple + +description: + Check for the "old build-dep behaviour" namely that we get the same + package dependencies on all build targets, even if different ones + were specified for different targets + . + Here all .hs files use the three packages mentioned, so this shows + that build-depends is not target-specific. This is the behaviour + we want when cabal-version contains versions less than 1.7. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring + +Executable lemon + main-is: lemon.hs + build-depends: old-time + +Executable pineapple + main-is: pineapple.hs diff --git a/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs b/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs b/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "pineapple" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs --- a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs @@ -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) diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal @@ -0,0 +1,22 @@ +name: TargetSpecificDeps1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new build-dep behaviour, where build-depends are + handled specifically for each target + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring + +Executable lemon + main-is: lemon.hs + build-depends: base, bytestring, old-time diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs --- a/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs @@ -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) diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs @@ -0,0 +1,5 @@ +import qualified Data.ByteString.Char8 as C + +main = do + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal @@ -0,0 +1,24 @@ +name: TargetSpecificDeps1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new build-dep behaviour, where build-depends are + handled specifically for each target + This one is a control against TargetSpecificDeps1 - it is correct and should + succeed. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + build-depends: base, bytestring diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs --- a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs @@ -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) diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal @@ -0,0 +1,22 @@ +name: test +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new build-dep behaviour, where build-depends are + handled specifically for each target + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + build-depends: base, bytestring diff --git a/tests/PackageTests/BuildTestSuiteDetailedV09/Check.hs b/tests/PackageTests/BuildTestSuiteDetailedV09/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildTestSuiteDetailedV09/Check.hs @@ -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 diff --git a/tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs b/tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs @@ -0,0 +1,6 @@ +module Dummy where + +import Distribution.TestSuite (Test) + +tests :: IO [Test] +tests = return [] diff --git a/tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal b/tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal @@ -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 diff --git a/tests/PackageTests/CMain/Bar.hs b/tests/PackageTests/CMain/Bar.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/CMain/Bar.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Bar where + +bar :: IO () +bar = return () + +foreign export ccall bar :: IO () diff --git a/tests/PackageTests/CMain/Check.hs b/tests/PackageTests/CMain/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/CMain/Check.hs @@ -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 diff --git a/tests/PackageTests/CMain/Setup.hs b/tests/PackageTests/CMain/Setup.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/CMain/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/tests/PackageTests/CMain/foo.c b/tests/PackageTests/CMain/foo.c new file mode 100644 --- /dev/null +++ b/tests/PackageTests/CMain/foo.c @@ -0,0 +1,13 @@ +#include +#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; +} diff --git a/tests/PackageTests/CMain/my.cabal b/tests/PackageTests/CMain/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/CMain/my.cabal @@ -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 diff --git a/tests/PackageTests/EmptyLib/Check.hs b/tests/PackageTests/EmptyLib/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/EmptyLib/Check.hs @@ -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 diff --git a/tests/PackageTests/EmptyLib/empty/empty.cabal b/tests/PackageTests/EmptyLib/empty/empty.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/EmptyLib/empty/empty.cabal @@ -0,0 +1,6 @@ +name: emptyLib +Cabal-version: >= 1.2 +version: 1.0 +build-type: Simple + +Library diff --git a/tests/PackageTests/OrderFlags/Check.hs b/tests/PackageTests/OrderFlags/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/OrderFlags/Check.hs @@ -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) diff --git a/tests/PackageTests/OrderFlags/Foo.hs b/tests/PackageTests/OrderFlags/Foo.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/OrderFlags/Foo.hs @@ -0,0 +1,8 @@ +module Foo where + +x :: IO Int +x = return 5 + +f :: IO Int +f = do x + return 3 diff --git a/tests/PackageTests/OrderFlags/my.cabal b/tests/PackageTests/OrderFlags/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/OrderFlags/my.cabal @@ -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 diff --git a/tests/PackageTests/PackageTester.hs b/tests/PackageTests/PackageTester.hs --- a/tests/PackageTests/PackageTester.hs +++ b/tests/PackageTests/PackageTester.hs @@ -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" diff --git a/tests/PackageTests/PathsModule/Executable/Check.hs b/tests/PackageTests/PathsModule/Executable/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PathsModule/Executable/Check.hs @@ -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 diff --git a/tests/PackageTests/PathsModule/Executable/Main.hs b/tests/PackageTests/PathsModule/Executable/Main.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PathsModule/Executable/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import Paths_PathsModule (getBinDir) + +main :: IO () +main = do + _ <- getBinDir + return () diff --git a/tests/PackageTests/PathsModule/Executable/my.cabal b/tests/PackageTests/PathsModule/Executable/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PathsModule/Executable/my.cabal @@ -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 diff --git a/tests/PackageTests/PathsModule/Library/Check.hs b/tests/PackageTests/PathsModule/Library/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PathsModule/Library/Check.hs @@ -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 diff --git a/tests/PackageTests/PathsModule/Library/my.cabal b/tests/PackageTests/PathsModule/Library/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PathsModule/Library/my.cabal @@ -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 diff --git a/tests/PackageTests/PreProcess/Check.hs b/tests/PackageTests/PreProcess/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PreProcess/Check.hs @@ -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 diff --git a/tests/PackageTests/PreProcess/Foo.hsc b/tests/PackageTests/PreProcess/Foo.hsc new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PreProcess/Foo.hsc @@ -0,0 +1,1 @@ +module Foo where diff --git a/tests/PackageTests/PreProcess/Main.hs b/tests/PackageTests/PreProcess/Main.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PreProcess/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Foo + +main :: IO () +main = return () diff --git a/tests/PackageTests/PreProcess/my.cabal b/tests/PackageTests/PreProcess/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PreProcess/my.cabal @@ -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 diff --git a/tests/PackageTests/TemplateHaskell/Check.hs b/tests/PackageTests/TemplateHaskell/Check.hs --- a/tests/PackageTests/TemplateHaskell/Check.hs +++ b/tests/PackageTests/TemplateHaskell/Check.hs @@ -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 diff --git a/tests/PackageTests/TemplateHaskell/dynamic/Exe.hs b/tests/PackageTests/TemplateHaskell/dynamic/Exe.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/dynamic/Exe.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import TH + +main = print $(splice) diff --git a/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs b/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Lib where + +import TH + +val = $(splice) diff --git a/tests/PackageTests/TemplateHaskell/dynamic/TH.hs b/tests/PackageTests/TemplateHaskell/dynamic/TH.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/dynamic/TH.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH where + +splice = [| () |] diff --git a/tests/PackageTests/TemplateHaskell/dynamic/my.cabal b/tests/PackageTests/TemplateHaskell/dynamic/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/dynamic/my.cabal @@ -0,0 +1,15 @@ +Name: templateHaskell +Version: 0.1 +Build-Type: Simple +Cabal-Version: >= 1.2 + +Library + Exposed-Modules: Lib + Other-Modules: TH + Build-Depends: base, template-haskell + Extensions: TemplateHaskell + +Executable main + Main-is: Exe.hs + Build-Depends: base, template-haskell + Extensions: TemplateHaskell diff --git a/tests/PackageTests/TemplateHaskell/profiling/Exe.hs b/tests/PackageTests/TemplateHaskell/profiling/Exe.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/profiling/Exe.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import TH + +main = print $(splice) diff --git a/tests/PackageTests/TemplateHaskell/profiling/Lib.hs b/tests/PackageTests/TemplateHaskell/profiling/Lib.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/profiling/Lib.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Lib where + +import TH + +val = $(splice) diff --git a/tests/PackageTests/TemplateHaskell/profiling/TH.hs b/tests/PackageTests/TemplateHaskell/profiling/TH.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/profiling/TH.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH where + +splice = [| () |] diff --git a/tests/PackageTests/TemplateHaskell/profiling/my.cabal b/tests/PackageTests/TemplateHaskell/profiling/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/profiling/my.cabal @@ -0,0 +1,15 @@ +Name: templateHaskell +Version: 0.1 +Build-Type: Simple +Cabal-Version: >= 1.2 + +Library + Exposed-Modules: Lib + Other-Modules: TH + Build-Depends: base, template-haskell + Extensions: TemplateHaskell + +Executable main + Main-is: Exe.hs + Build-Depends: base, template-haskell + Extensions: TemplateHaskell diff --git a/tests/PackageTests/TemplateHaskell/vanilla/Exe.hs b/tests/PackageTests/TemplateHaskell/vanilla/Exe.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/vanilla/Exe.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import TH + +main = print $(splice) diff --git a/tests/PackageTests/TemplateHaskell/vanilla/Lib.hs b/tests/PackageTests/TemplateHaskell/vanilla/Lib.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/vanilla/Lib.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Lib where + +import TH + +val = $(splice) diff --git a/tests/PackageTests/TemplateHaskell/vanilla/TH.hs b/tests/PackageTests/TemplateHaskell/vanilla/TH.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/vanilla/TH.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH where + +splice = [| () |] diff --git a/tests/PackageTests/TemplateHaskell/vanilla/my.cabal b/tests/PackageTests/TemplateHaskell/vanilla/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/vanilla/my.cabal @@ -0,0 +1,15 @@ +Name: templateHaskell +Version: 0.1 +Build-Type: Simple +Cabal-Version: >= 1.2 + +Library + Exposed-Modules: Lib + Other-Modules: TH + Build-Depends: base, template-haskell + Extensions: TemplateHaskell + +Executable main + Main-is: Exe.hs + Build-Depends: base, template-haskell + Extensions: TemplateHaskell diff --git a/tests/PackageTests/TestOptions/Check.hs b/tests/PackageTests/TestOptions/Check.hs --- a/tests/PackageTests/TestOptions/Check.hs +++ b/tests/PackageTests/TestOptions/Check.hs @@ -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' diff --git a/tests/PackageTests/TestOptions/TestOptions.cabal b/tests/PackageTests/TestOptions/TestOptions.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestOptions/TestOptions.cabal @@ -0,0 +1,20 @@ +name: TestOptions +version: 0.1 +license: BSD3 +author: Thomas Tuegel +stability: stable +category: PackageTests +build-type: Simple +cabal-version: >= 1.9.2 + +description: + Check that Cabal passes the correct test options to test suites. + +executable dummy + main-is: test-TestOptions.hs + build-depends: base + +test-suite test-TestOptions + main-is: test-TestOptions.hs + type: exitcode-stdio-1.0 + build-depends: base diff --git a/tests/PackageTests/TestOptions/test-TestOptions.hs b/tests/PackageTests/TestOptions/test-TestOptions.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestOptions/test-TestOptions.hs @@ -0,0 +1,11 @@ +module Main where + +import System.Environment ( getArgs ) +import System.Exit ( exitFailure, exitSuccess ) + +main :: IO () +main = do + args <- getArgs + if args == ["1", "2", "3"] + then exitSuccess + else putStrLn ("Got: " ++ show args) >> exitFailure diff --git a/tests/PackageTests/TestStanza/Check.hs b/tests/PackageTests/TestStanza/Check.hs --- a/tests/PackageTests/TestStanza/Check.hs +++ b/tests/PackageTests/TestStanza/Check.hs @@ -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" diff --git a/tests/PackageTests/TestStanza/my.cabal b/tests/PackageTests/TestStanza/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestStanza/my.cabal @@ -0,0 +1,19 @@ +name: TestStanza +version: 0.1 +license: BSD3 +author: Thomas Tuegel +stability: stable +category: PackageTests +build-type: Simple + +description: + Check that Cabal recognizes the Test stanza defined below. + +Library + exposed-modules: MyLibrary + build-depends: base + +test-suite dummy + main-is: dummy.hs + type: exitcode-stdio-1.0 + build-depends: base diff --git a/tests/PackageTests/TestSuiteExeV10/Check.hs b/tests/PackageTests/TestSuiteExeV10/Check.hs --- a/tests/PackageTests/TestSuiteExeV10/Check.hs +++ b/tests/PackageTests/TestSuiteExeV10/Check.hs @@ -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 diff --git a/tests/PackageTests/TestSuiteExeV10/Foo.hs b/tests/PackageTests/TestSuiteExeV10/Foo.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteExeV10/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +fooTest :: [String] -> Bool +fooTest _ = True diff --git a/tests/PackageTests/TestSuiteExeV10/my.cabal b/tests/PackageTests/TestSuiteExeV10/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteExeV10/my.cabal @@ -0,0 +1,15 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.9.2 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base + +test-suite test-Foo + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: test-Foo.hs + build-depends: base, my diff --git a/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs b/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs @@ -0,0 +1,8 @@ +module Main where + +import Foo +import System.Exit + +main :: IO () +main | fooTest [] = exitSuccess + | otherwise = exitFailure diff --git a/tests/README b/tests/README new file mode 100644 --- /dev/null +++ b/tests/README @@ -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. diff --git a/tests/Setup.hs b/tests/Setup.hs new file mode 100644 --- /dev/null +++ b/tests/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests.hs @@ -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 diff --git a/tests/UnitTests/Distribution/Compat/ReadP.hs b/tests/UnitTests/Distribution/Compat/ReadP.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Compat/ReadP.hs @@ -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 + diff --git a/tests/hackage/check.sh b/tests/hackage/check.sh new file mode 100644 --- /dev/null +++ b/tests/hackage/check.sh @@ -0,0 +1,25 @@ +#!/bin/sh + +base_version=1.4.0.2 +test_version=1.5.6 + +for setup in archive/*/*/Setup.hs archive/*/*/Setup.lhs; do + + pkgname=$(basename ${setup}) + + if test $(wc -w < ${setup}) -gt 21; then + if ghc -package Cabal-${base_version} -S ${setup} -o /dev/null 2> /dev/null; then + + if ghc -package Cabal-${test_version} -S ${setup} -o /dev/null 2> /dev/null; then + echo "OK ${setup}" + else + echo "FAIL ${setup} does not compile with Cabal-${test_version}" + fi + else + echo "OK ${setup} (does not compile with Cabal-${base_version})" + fi + else + echo "trivial ${setup}" + fi + +done diff --git a/tests/hackage/download.sh b/tests/hackage/download.sh new file mode 100644 --- /dev/null +++ b/tests/hackage/download.sh @@ -0,0 +1,19 @@ +#!/bin/sh + +if test ! -f archive/archive.tar; then + + wget http://hackage.haskell.org/cgi-bin/hackage-scripts/archive.tar + mkdir -p archive + mv archive.tar archive/ + tar -C archive -xf archive/archive.tar + +fi + +if test ! -f archive/00-index.tar.gz; then + + wget http://hackage.haskell.org/packages/archive/00-index.tar.gz + mkdir -p archive + mv 00-index.tar.gz archive/ + tar -C archive -xzf archive/00-index.tar.gz + +fi diff --git a/tests/hackage/unpack.sh b/tests/hackage/unpack.sh new file mode 100644 --- /dev/null +++ b/tests/hackage/unpack.sh @@ -0,0 +1,16 @@ +#!/bin/sh + +for tarball in archive/*/*/*.tar.gz; do + + pkgdir=$(dirname ${tarball}) + pkgname=$(basename ${tarball} .tar.gz) + + if tar -tzf ${tarball} ${pkgname}/Setup.hs 2> /dev/null; then + tar -xzf ${tarball} ${pkgname}/Setup.hs -O > ${pkgdir}/Setup.hs + elif tar -tzf ${tarball} ${pkgname}/Setup.lhs 2> /dev/null; then + tar -xzf ${tarball} ${pkgname}/Setup.lhs -O > ${pkgdir}/Setup.lhs + else + echo "${pkgname} has no Setup.hs or .lhs at all!!?!" + fi + +done diff --git a/tests/misc/ghc-supported-languages.hs b/tests/misc/ghc-supported-languages.hs new file mode 100644 --- /dev/null +++ b/tests/misc/ghc-supported-languages.hs @@ -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) diff --git a/tests/suite.hs b/tests/suite.hs deleted file mode 100644 --- a/tests/suite.hs +++ /dev/null @@ -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) -