diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,5 +1,5 @@ name: Cabal -version: 1.22.8.0 +version: 1.24.0.0 copyright: 2003-2006, Isaac Jones 2005-2011, Duncan Coutts license: BSD3 @@ -20,16 +20,22 @@ category: Distribution cabal-version: >=1.10 build-type: Simple --- 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. +-- If we use a new Cabal feature, this needs to be changed to Custom so +-- we can bootstrap. extra-source-files: README.md tests/README.md changelog - doc/developing-packages.markdown doc/index.markdown + doc/Cabal.css doc/developing-packages.markdown doc/index.markdown doc/installing-packages.markdown doc/misc.markdown - -- Generated with 'misc/gen-extra-source-files.sh' & 'M-x sort-lines': + -- Generated with 'misc/gen-extra-source-files.sh' + -- Do NOT edit this section manually; instead, run the script. + -- BEGIN gen-extra-source-files + tests/PackageTests/AllowNewer/AllowNewer.cabal + tests/PackageTests/AllowNewer/benchmarks/Bench.hs + tests/PackageTests/AllowNewer/src/Foo.hs + tests/PackageTests/AllowNewer/tests/Test.hs tests/PackageTests/BenchmarkExeV10/Foo.hs tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs tests/PackageTests/BenchmarkExeV10/my.cabal @@ -74,20 +80,46 @@ 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/BuildTestSuiteDetailedV09/Dummy2.hs + tests/PackageTests/BuildableField/BuildableField.cabal + tests/PackageTests/BuildableField/Main.hs tests/PackageTests/CMain/Bar.hs - tests/PackageTests/CMain/Setup.hs tests/PackageTests/CMain/foo.c tests/PackageTests/CMain/my.cabal tests/PackageTests/DeterministicAr/Lib.hs tests/PackageTests/DeterministicAr/my.cabal + tests/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal + tests/PackageTests/DuplicateModuleName/src/Foo.hs + tests/PackageTests/DuplicateModuleName/tests/Foo.hs + tests/PackageTests/DuplicateModuleName/tests2/Foo.hs tests/PackageTests/EmptyLib/empty/empty.cabal + tests/PackageTests/GhcPkgGuess/SameDirectory/SameDirectory.cabal + tests/PackageTests/GhcPkgGuess/SameDirectory/ghc + tests/PackageTests/GhcPkgGuess/SameDirectory/ghc-pkg + tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/SameDirectory.cabal + tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-7.10 + tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-pkg-ghc-7.10 + tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/SameDirectory.cabal + tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-7.10 + tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-pkg-7.10 + tests/PackageTests/GhcPkgGuess/Symlink/SameDirectory.cabal + tests/PackageTests/GhcPkgGuess/Symlink/bin/ghc + tests/PackageTests/GhcPkgGuess/Symlink/bin/ghc-pkg + tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/SameDirectory.cabal + tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-7.10 + tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-pkg-7.10 + tests/PackageTests/GhcPkgGuess/SymlinkVersion/SameDirectory.cabal + tests/PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-7.10 + tests/PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-pkg-ghc-7.10 tests/PackageTests/Haddock/CPP.hs tests/PackageTests/Haddock/Literate.lhs tests/PackageTests/Haddock/NoCPP.hs tests/PackageTests/Haddock/Simple.hs tests/PackageTests/Haddock/my.cabal + tests/PackageTests/HaddockNewline/A.hs + tests/PackageTests/HaddockNewline/HaddockNewline.cabal + tests/PackageTests/HaddockNewline/Setup.hs + tests/PackageTests/Options.hs tests/PackageTests/OrderFlags/Foo.hs tests/PackageTests/OrderFlags/my.cabal tests/PackageTests/PathsModule/Executable/Main.hs @@ -96,6 +128,9 @@ tests/PackageTests/PreProcess/Foo.hsc tests/PackageTests/PreProcess/Main.hs tests/PackageTests/PreProcess/my.cabal + tests/PackageTests/PreProcessExtraSources/Foo.hsc + tests/PackageTests/PreProcessExtraSources/Main.hs + tests/PackageTests/PreProcessExtraSources/my.cabal tests/PackageTests/ReexportedModules/ReexportedModules.cabal tests/PackageTests/TemplateHaskell/dynamic/Exe.hs tests/PackageTests/TemplateHaskell/dynamic/Lib.hs @@ -109,17 +144,33 @@ tests/PackageTests/TemplateHaskell/vanilla/Lib.hs tests/PackageTests/TemplateHaskell/vanilla/TH.hs tests/PackageTests/TemplateHaskell/vanilla/my.cabal + tests/PackageTests/TestNameCollision/child/Child.hs + tests/PackageTests/TestNameCollision/child/child.cabal + tests/PackageTests/TestNameCollision/child/tests/Test.hs + tests/PackageTests/TestNameCollision/parent/Parent.hs + tests/PackageTests/TestNameCollision/parent/parent.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/PackageTests/TestSuiteTests/ExeV10/Foo.hs + tests/PackageTests/TestSuiteTests/ExeV10/my.cabal + tests/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs + tests/PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs + tests/PackageTests/TestSuiteTests/LibV09/Lib.hs + tests/PackageTests/TestSuiteTests/LibV09/LibV09.cabal + tests/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs + tests/PackageTests/Tests.hs + tests/PackageTests/UniqueIPID/P1/M.hs + tests/PackageTests/UniqueIPID/P1/my.cabal + tests/PackageTests/UniqueIPID/P2/M.hs + tests/PackageTests/UniqueIPID/P2/my.cabal + tests/PackageTests/multInst/my.cabal tests/Setup.hs tests/hackage/check.sh tests/hackage/download.sh tests/hackage/unpack.sh tests/misc/ghc-supported-languages.hs + -- END gen-extra-source-files source-repository head type: git @@ -131,16 +182,16 @@ library build-depends: - base >= 4.4 && < 5, - deepseq >= 1.3 && < 1.5, - filepath >= 1 && < 1.5, - directory >= 1 && < 1.3, - process >= 1.1.0.1 && < 1.3, - time >= 1.1 && < 1.6, - containers >= 0.1 && < 0.6, array >= 0.1 && < 0.6, - pretty >= 1 && < 1.2, - bytestring >= 0.9 + base >= 4.5 && < 5, + bytestring >= 0.9 && < 1, + containers >= 0.4 && < 0.6, + deepseq >= 1.3 && < 1.5, + directory >= 1.1 && < 1.3, + filepath >= 1.3 && < 1.5, + pretty >= 1.1 && < 1.2, + process >= 1.1.0.1 && < 1.5, + time >= 1.4 && < 1.7 if flag(bundled-binary-generic) build-depends: binary >= 0.5 && < 0.7 @@ -153,15 +204,24 @@ if !os(windows) build-depends: - unix >= 2.0 && < 2.8 + unix >= 2.5 && < 2.8 + if os(windows) + build-depends: + Win32 >= 2.2 && < 2.4 + ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances + -Wnoncanonical-monadfail-instances exposed-modules: Distribution.Compat.CreatePipe Distribution.Compat.Environment Distribution.Compat.Exception + Distribution.Compat.Internal.TempFile Distribution.Compat.ReadP + Distribution.Compat.Semigroup Distribution.Compiler Distribution.InstalledPackageInfo Distribution.License @@ -208,6 +268,7 @@ Distribution.Simple.Program.GHC Distribution.Simple.Program.HcPkg Distribution.Simple.Program.Hpc + Distribution.Simple.Program.Internal Distribution.Simple.Program.Ld Distribution.Simple.Program.Run Distribution.Simple.Program.Script @@ -230,15 +291,17 @@ Distribution.Verbosity Distribution.Version Language.Haskell.Extension + Distribution.Compat.Binary other-modules: - Distribution.Compat.Binary Distribution.Compat.CopyFile - Distribution.Compat.TempFile + Distribution.Compat.GetShortPathName + Distribution.Compat.MonadFail Distribution.GetOpt + Distribution.Lex Distribution.Simple.GHC.Internal - Distribution.Simple.GHC.IPI641 Distribution.Simple.GHC.IPI642 + Distribution.Simple.GHC.IPIConvert Distribution.Simple.GHC.ImplInfo Paths_Cabal @@ -248,24 +311,30 @@ Distribution.Compat.Binary.Generic default-language: Haskell98 - default-extensions: CPP -- Small, fast running tests. test-suite unit-tests type: exitcode-stdio-1.0 hs-source-dirs: tests other-modules: + Test.Laws + Test.QuickCheck.Utils UnitTests.Distribution.Compat.CreatePipe UnitTests.Distribution.Compat.ReadP + UnitTests.Distribution.Simple.Program.Internal + UnitTests.Distribution.Simple.Utils + UnitTests.Distribution.System UnitTests.Distribution.Utils.NubList + UnitTests.Distribution.Version main-is: UnitTests.hs build-depends: base, - test-framework, - test-framework-hunit, - test-framework-quickcheck2, - HUnit, - QuickCheck < 2.9, + directory, + tasty, + tasty-hunit, + tasty-quickcheck, + pretty, + QuickCheck >= 2.7 && < 2.9, Cabal ghc-options: -Wall default-language: Haskell98 @@ -275,54 +344,28 @@ type: exitcode-stdio-1.0 main-is: PackageTests.hs other-modules: - 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.TestStanza.Check PackageTests.DeterministicAr.Check - PackageTests.EmptyLib.Check - PackageTests.Haddock.Check - PackageTests.OrderFlags.Check + PackageTests.TestSuiteTests.ExeV10.Check PackageTests.PackageTester - PackageTests.PathsModule.Executable.Check - PackageTests.PathsModule.Library.Check - PackageTests.PreProcess.Check - PackageTests.ReexportedModules.Check - PackageTests.TemplateHaskell.Check - PackageTests.TestOptions.Check - PackageTests.TestStanza.Check - PackageTests.TestSuiteExeV10.Check hs-source-dirs: tests build-depends: base, containers, - test-framework, - test-framework-quickcheck2 >= 0.2.12, - test-framework-hunit, - HUnit, - QuickCheck >= 2.1.0.1 && < 2.9, + tagged, + tasty, + tasty-hunit, + transformers, Cabal, process, directory, filepath, - extensible-exceptions, bytestring, regex-posix, old-time if !os(windows) - build-depends: unix - ghc-options: -Wall + build-depends: unix, exceptions + ghc-options: -Wall -rtsopts default-extensions: CPP default-language: Haskell98 diff --git a/Distribution/Compat/Binary.hs b/Distribution/Compat/Binary.hs --- a/Distribution/Compat/Binary.hs +++ b/Distribution/Compat/Binary.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 711 +{-# LANGUAGE PatternSynonyms #-} +#endif #ifndef MIN_VERSION_binary #define MIN_VERSION_binary(x, y, z) 0 @@ -14,7 +17,12 @@ #endif ) where -import Control.Exception (ErrorCall(..), catch, evaluate) +import Control.Exception (catch, evaluate) +#if __GLASGOW_HASKELL__ >= 711 +import Control.Exception (pattern ErrorCall) +#else +import Control.Exception (ErrorCall(..)) +#endif import Data.ByteString.Lazy (ByteString) #if __GLASGOW_HASKELL__ < 706 diff --git a/Distribution/Compat/Binary/Class.hs b/Distribution/Compat/Binary/Class.hs --- a/Distribution/Compat/Binary/Class.hs +++ b/Distribution/Compat/Binary/Class.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DefaultSignatures #-} ----------------------------------------------------------------------------- @@ -53,13 +53,8 @@ import GHC.Generics --- --- This isn't available in older Hugs or older GHC --- -#if __GLASGOW_HASKELL__ >= 606 import qualified Data.Sequence as Seq import qualified Data.Foldable as Fold -#endif ------------------------------------------------------------------------ @@ -467,11 +462,6 @@ ------------------------------------------------------------------------ -- Queues and Sequences -#if __GLASGOW_HASKELL__ >= 606 --- --- This is valid Hugs, but you need the most recent Hugs --- - instance (Binary e) => Binary (Seq.Seq e) where put s = put (Seq.length s) >> Fold.mapM_ put s get = do n <- get :: Get Int @@ -480,8 +470,6 @@ rep xs n g = xs `seq` n `seq` do x <- g rep (xs Seq.|> x) (n-1) g - -#endif ------------------------------------------------------------------------ -- Floating point diff --git a/Distribution/Compat/CopyFile.hs b/Distribution/Compat/CopyFile.hs --- a/Distribution/Compat/CopyFile.hs +++ b/Distribution/Compat/CopyFile.hs @@ -11,24 +11,22 @@ setDirOrdinary, ) where +import Distribution.Compat.Exception +import Distribution.Compat.Internal.TempFile import Control.Monad ( when, unless ) import Control.Exception - ( bracket, bracketOnError, throwIO ) + ( bracketOnError, throwIO ) import qualified Data.ByteString.Lazy as BSL -import Distribution.Compat.Exception - ( catchIO ) import System.IO.Error ( ioeSetLocation ) import System.Directory ( doesFileExist, renameFile, removeFile ) -import Distribution.Compat.TempFile - ( openBinaryTempFile ) import System.FilePath ( takeDirectory ) import System.IO - ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf + ( IOMode(ReadMode), hClose, hGetBuf, hPutBuf , withBinaryFile ) import Foreign ( allocaBytes ) @@ -69,7 +67,7 @@ copyFile fromFPath toFPath = copy `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile")) - where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> + where copy = withBinaryFile fromFPath ReadMode $ \hFrom -> bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> do allocaBytes bufferSize $ copyContents hFrom hTmp hClose hTmp @@ -100,8 +98,7 @@ filesEqual f1 f2 = do ex1 <- doesFileExist f1 ex2 <- doesFileExist f2 - if not (ex1 && ex2) then return False else do - + if not (ex1 && ex2) then return False else withBinaryFile f1 ReadMode $ \h1 -> withBinaryFile f2 ReadMode $ \h2 -> do c1 <- BSL.hGetContents h1 diff --git a/Distribution/Compat/Environment.hs b/Distribution/Compat/Environment.hs --- a/Distribution/Compat/Environment.hs +++ b/Distribution/Compat/Environment.hs @@ -1,14 +1,29 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} {-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.Environment (getEnvironment) +module Distribution.Compat.Environment + ( getEnvironment, lookupEnv, setEnv ) where import qualified System.Environment as System +#if __GLASGOW_HASKELL__ >= 706 +import System.Environment (lookupEnv) +#else +import Distribution.Compat.Exception (catchIO) +#endif #ifdef mingw32_HOST_OS +import Control.Monad import qualified Data.Char as Char (toUpper) -#endif +import Foreign.C +import GHC.Windows +#else +import Foreign.C.Types +import Foreign.C.String +import Foreign.C.Error (throwErrnoIfMinus1_) +import System.Posix.Internals ( withFilePath ) +#endif /* mingw32_HOST_OS */ getEnvironment :: IO [(String, String)] #ifdef mingw32_HOST_OS @@ -22,3 +37,53 @@ #else getEnvironment = System.getEnvironment #endif + +#if __GLASGOW_HASKELL__ < 706 +-- | @lookupEnv var@ returns the value of the environment variable @var@, or +-- @Nothing@ if there is no such value. +lookupEnv :: String -> IO (Maybe String) +lookupEnv name = (Just `fmap` System.getEnv name) `catchIO` const (return Nothing) +#endif /* __GLASGOW_HASKELL__ < 706 */ + +-- | @setEnv name value@ sets the specified environment variable to @value@. +-- +-- Throws `Control.Exception.IOException` if either @name@ or @value@ is the +-- empty string or contains an equals sign. +setEnv :: String -> String -> IO () +setEnv key value_ + | null value = error "Distribuiton.Compat.setEnv: empty string" + | otherwise = setEnv_ key value + where + -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We + -- still strip it manually so that the null check above succeeds if a value + -- starts with NUL. + value = takeWhile (/= '\NUL') value_ + +setEnv_ :: String -> String -> IO () + +#ifdef mingw32_HOST_OS + +setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do + success <- c_SetEnvironmentVariable k v + unless success (throwGetLastError "setEnv") + +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif /* i386_HOST_ARCH */ + +foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW" + c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool +#else +setEnv_ key value = do + withFilePath key $ \ keyP -> + withFilePath value $ \ valueP -> + throwErrnoIfMinus1_ "setenv" $ + c_setenv keyP valueP (fromIntegral (fromEnum True)) + +foreign import ccall unsafe "setenv" + c_setenv :: CString -> CString -> CInt -> IO CInt +#endif /* mingw32_HOST_OS */ diff --git a/Distribution/Compat/GetShortPathName.hs b/Distribution/Compat/GetShortPathName.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/GetShortPathName.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compat.GetShortPathName +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : Windows-only +-- +-- Win32 API 'GetShortPathName' function. + +module Distribution.Compat.GetShortPathName ( getShortPathName ) + where + +#ifdef mingw32_HOST_OS +import Control.Monad (void) + +import qualified System.Win32 as Win32 +import System.Win32 (LPCTSTR, LPTSTR, DWORD) +import Foreign.Marshal.Array (allocaArray) + +#ifdef x86_64_HOST_ARCH +#define WINAPI ccall +#else +#define WINAPI stdcall +#endif + +foreign import WINAPI unsafe "windows.h GetShortPathNameW" + c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD + +-- | On Windows, retrieves the short path form of the specified path. On +-- non-Windows, does nothing. See https://github.com/haskell/cabal/issues/3185. +getShortPathName :: FilePath -> IO FilePath +getShortPathName path = + Win32.withTString path $ \c_path -> + allocaArray arr_len $ \c_out -> do + void $ Win32.failIfZero "GetShortPathName failed!" $ + c_GetShortPathName c_path c_out c_len + Win32.peekTString c_out + where + arr_len = length path + 1 + c_len = fromIntegral arr_len + +#else + +getShortPathName :: FilePath -> IO FilePath +getShortPathName path = return path + +#endif diff --git a/Distribution/Compat/Internal/TempFile.hs b/Distribution/Compat/Internal/TempFile.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Internal/TempFile.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} +module Distribution.Compat.Internal.TempFile ( + openTempFile, + openBinaryTempFile, + openNewBinaryFile, + createTempDirectory, + ) where + +import Distribution.Compat.Exception + +import System.FilePath (()) +import Foreign.C (CInt, eEXIST, getErrno, errnoToIOError) + +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, + withFilePath, c_getpid) +import System.IO.Error (isAlreadyExistsError) +import GHC.IO.Handle.FD (fdToHandle) +import Control.Exception (onException) + +#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) +import System.Directory ( createDirectory ) +#else +import qualified System.Posix +#endif + +-- ------------------------------------------------------------ +-- * temporary files +-- ------------------------------------------------------------ + +-- This is here for Haskell implementations that do not come with +-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9. +-- TODO: Not sure about JHC +-- TODO: This file should probably be removed. + +-- This is a copy/paste of the openBinaryTempFile definition, but +-- if uses 666 rather than 600 for the permissions. The base library +-- needs to be changed to make this better. +openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) +openNewBinaryFile dir template = do + pid <- c_getpid + findTempName pid + where + -- We split off the last extension, so we can use .foo.ext files + -- for temporary files (hidden on Unix OSes). Unfortunately we're + -- below file path in the hierarchy here. + (prefix,suffix) = + case break (== '.') $ reverse template of + -- First case: template contains no '.'s. Just re-reverse it. + (rev_suffix, "") -> (reverse rev_suffix, "") + -- Second case: template contains at least one '.'. Strip the + -- dot from the prefix and prepend it to the suffix (if we don't + -- do this, the unique number will get added after the '.' and + -- thus be part of the extension, which is wrong.) + (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) + -- Otherwise, something is wrong, because (break (== '.')) should + -- always return a pair with either the empty string or a string + -- beginning with '.' as the second component. + _ -> error "bug in System.IO.openTempFile" + + oflags = rw_flags .|. o_EXCL .|. o_BINARY + + findTempName x = do + fd <- withFilePath filepath $ \ f -> + c_open f oflags 0o666 + if fd < 0 + then do + errno <- getErrno + if errno == eEXIST + then findTempName (x+1) + else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) + else do + -- TODO: We want to tell fdToHandle what the file path is, + -- as any exceptions etc will only be able to report the + -- FD currently + h <- fdToHandle fd `onException` c_close fd + return (filepath, h) + where + filename = prefix ++ show x ++ suffix + filepath = dir `combine` filename + + -- FIXME: bits copied from System.FilePath + combine a b + | null b = a + | null a = b + | last a == pathSeparator = a ++ b + | otherwise = a ++ [pathSeparator] ++ b + +-- FIXME: Should use System.FilePath library +pathSeparator :: Char +#ifdef mingw32_HOST_OS +pathSeparator = '\\' +#else +pathSeparator = '/' +#endif + +-- FIXME: Copied from GHC.Handle +std_flags, output_flags, rw_flags :: CInt +std_flags = o_NONBLOCK .|. o_NOCTTY +output_flags = std_flags .|. o_CREAT +rw_flags = output_flags .|. o_RDWR + +createTempDirectory :: FilePath -> String -> IO FilePath +createTempDirectory dir template = do + pid <- c_getpid + findTempName pid + where + findTempName x = do + let dirpath = dir template ++ "-" ++ show x + r <- tryIO $ mkPrivateDir dirpath + case r of + Right _ -> return dirpath + Left e | isAlreadyExistsError e -> findTempName (x+1) + | otherwise -> ioError e + +mkPrivateDir :: String -> IO () +#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) +mkPrivateDir s = createDirectory s +#else +mkPrivateDir s = System.Posix.createDirectory s 0o700 +#endif diff --git a/Distribution/Compat/MonadFail.hs b/Distribution/Compat/MonadFail.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/MonadFail.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE CPP #-} + +-- | Compatibility layer for "Control.Monad.Fail" +module Distribution.Compat.MonadFail ( MonadFail(fail) ) where +#if __GLASGOW_HASKELL__ >= 800 +-- provided by base-4.9.0.0 and later +import Control.Monad.Fail (MonadFail(fail)) +#else +-- the following code corresponds to +-- http://hackage.haskell.org/package/fail-4.9.0.0 +import qualified Prelude as P +import Prelude hiding (fail) + +import Text.ParserCombinators.ReadP +import Text.ParserCombinators.ReadPrec + +class Monad m => MonadFail m where + fail :: String -> m a + +-- instances provided by base-4.9 + +instance MonadFail Maybe where + fail _ = Nothing + +instance MonadFail [] where + fail _ = [] + +instance MonadFail IO where + fail = P.fail + +instance MonadFail ReadPrec where + fail = P.fail -- = P (\_ -> fail s) + +instance MonadFail ReadP where + fail = P.fail +#endif diff --git a/Distribution/Compat/ReadP.hs b/Distribution/Compat/ReadP.hs --- a/Distribution/Compat/ReadP.hs +++ b/Distribution/Compat/ReadP.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Compat.ReadP @@ -70,12 +69,11 @@ ) where -import Control.Monad( MonadPlus(..), liftM, liftM2, ap ) +import qualified Distribution.Compat.MonadFail as Fail + +import Control.Monad( MonadPlus(..), liftM, liftM2, replicateM, ap, (>=>) ) import Data.Char (isSpace) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative(..)) -#endif -import Control.Applicative (Alternative(empty, (<|>))) +import Control.Applicative as AP (Applicative(..), Alternative(empty, (<|>))) infixr 5 +++, <++ @@ -96,18 +94,21 @@ fmap = liftM instance Applicative (P s) where - pure = return + pure x = Result x Fail (<*>) = ap instance Monad (P s) where - return x = Result x Fail + return = AP.pure - (Get f) >>= k = Get (\c -> f c >>= k) - (Look f) >>= k = Look (\s -> f s >>= k) + (Get f) >>= k = Get (f >=> k) + (Look f) >>= k = Look (f >=> k) Fail >>= _ = Fail (Result x p) >>= k = k x `mplus` (p >>= k) (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s] + fail = Fail.fail + +instance Fail.MonadFail (P s) where fail _ = Fail instance Alternative (P s) where @@ -155,14 +156,17 @@ fmap h (R f) = R (\k -> f (k . h)) instance Applicative (Parser r s) where - pure = return + pure x = R (\k -> k x) (<*>) = ap instance Monad (Parser r s) where - return x = R (\k -> k x) - fail _ = R (\_ -> Fail) + return = AP.pure + fail = Fail.fail R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) +instance Fail.MonadFail (Parser r s) where + fail _ = R (const Fail) + --instance MonadPlus (Parser r s) where -- mzero = pfail -- mplus = (+++) @@ -197,7 +201,7 @@ pfail :: ReadP r a -- ^ Always fails. -pfail = R (\_ -> Fail) +pfail = R (const Fail) (+++) :: ReadP r a -> ReadP r a -> ReadP r a -- ^ Symmetric choice. @@ -230,7 +234,7 @@ where gath l (Get f) = Get (\c -> gath (l.(c:)) (f c)) gath _ Fail = Fail - gath l (Look f) = Look (\s -> gath l (f s)) + gath l (Look f) = Look (gath l . f) gath l (Result k p) = k (l []) `mplus` gath l p gath _ (Final _) = error "do not use readS_to_P in gather!" @@ -250,9 +254,9 @@ -- ^ Parses and returns the specified string. string this = do s <- look; scan this s where - scan [] _ = do return this - scan (x:xs) (y:ys) | x == y = do get >> scan xs ys - scan _ _ = do pfail + scan [] _ = return this + scan (x:xs) (y:ys) | x == y = get >> scan xs ys + scan _ _ = pfail munch :: (Char -> Bool) -> ReadP r String -- ^ Parses the first zero or more characters satisfying the predicate. @@ -288,7 +292,7 @@ count :: Int -> ReadP r a -> ReadP r [a] -- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of -- results is returned. -count n p = sequence (replicate n p) +count n p = replicateM n p between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a -- ^ @ between open close p @ parses @open@, followed by @p@ and finally diff --git a/Distribution/Compat/Semigroup.hs b/Distribution/Compat/Semigroup.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Semigroup.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeOperators #-} + +-- | Compatibility layer for "Data.Semigroup" +module Distribution.Compat.Semigroup + ( Semigroup((<>)) + , Mon.Monoid(..) + , All(..) + , Any(..) + + , Last'(..) + + , gmappend + , gmempty + ) where + +import Distribution.Compat.Binary (Binary) + +import Control.Applicative as App +import GHC.Generics +#if __GLASGOW_HASKELL__ >= 711 +-- Data.Semigroup is available since GHC 8.0/base-4.9 +import Data.Semigroup +import qualified Data.Monoid as Mon +#else +-- provide internal simplified non-exposed class for older GHCs +import Data.Monoid as Mon (Monoid(..), All(..), Any(..), Dual(..)) +-- containers +import Data.Set (Set) +import Data.IntSet (IntSet) +import Data.Map (Map) +import Data.IntMap (IntMap) + + +class Semigroup a where + (<>) :: a -> a -> a + +-- several primitive instances +instance Semigroup () where + _ <> _ = () + +instance Semigroup [a] where + (<>) = (++) + +instance Semigroup a => Semigroup (Dual a) where + Dual a <> Dual b = Dual (b <> a) + +instance Semigroup a => Semigroup (Maybe a) where + Nothing <> b = b + a <> Nothing = a + Just a <> Just b = Just (a <> b) + +instance Semigroup (Either a b) where + Left _ <> b = b + a <> _ = a + +instance Semigroup Ordering where + LT <> _ = LT + EQ <> y = y + GT <> _ = GT + +instance Semigroup b => Semigroup (a -> b) where + f <> g = \a -> f a <> g a + +instance Semigroup All where + All a <> All b = All (a && b) + +instance Semigroup Any where + Any a <> Any b = Any (a || b) + +instance (Semigroup a, Semigroup b) => Semigroup (a, b) where + (a,b) <> (a',b') = (a<>a',b<>b') + +instance (Semigroup a, Semigroup b, Semigroup c) + => Semigroup (a, b, c) where + (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c') + +instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) + => Semigroup (a, b, c, d) where + (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d') + +instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e) + => Semigroup (a, b, c, d, e) where + (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e') + +-- containers instances +instance Semigroup IntSet where + (<>) = mappend + +instance Ord a => Semigroup (Set a) where + (<>) = mappend + +instance Semigroup (IntMap v) where + (<>) = mappend + +instance Ord k => Semigroup (Map k v) where + (<>) = mappend +#endif + +-- | Cabal's own 'Data.Monoid.Last' copy to avoid requiring an orphan +-- 'Binary' instance. +-- +-- Once the oldest `binary` version we support provides a 'Binary' +-- instance for 'Data.Monoid.Last' we can remove this one here. +-- +-- NB: 'Data.Semigroup.Last' is defined differently and not a 'Monoid' +newtype Last' a = Last' { getLast' :: Maybe a } + deriving (Eq, Ord, Read, Show, Binary, + Functor, App.Applicative, Generic) + +instance Semigroup (Last' a) where + x <> Last' Nothing = x + _ <> x = x + +instance Monoid (Last' a) where + mempty = Last' Nothing + mappend = (<>) + +------------------------------------------------------------------------------- +------------------------------------------------------------------------------- +-- Stolen from Edward Kmett's BSD3-licensed `semigroups` package + +-- | Generically generate a 'Semigroup' ('<>') operation for any type +-- implementing 'Generic'. This operation will append two values +-- by point-wise appending their component fields. It is only defined +-- for product types. +-- +-- @ +-- 'gmappend' a ('gmappend' b c) = 'gmappend' ('gmappend' a b) c +-- @ +gmappend :: (Generic a, GSemigroup (Rep a)) => a -> a -> a +gmappend x y = to (gmappend' (from x) (from y)) + +class GSemigroup f where + gmappend' :: f p -> f p -> f p + +instance Semigroup a => GSemigroup (K1 i a) where + gmappend' (K1 x) (K1 y) = K1 (x <> y) + +instance GSemigroup f => GSemigroup (M1 i c f) where + gmappend' (M1 x) (M1 y) = M1 (gmappend' x y) + +instance (GSemigroup f, GSemigroup g) => GSemigroup (f :*: g) where + gmappend' (x1 :*: x2) (y1 :*: y2) = gmappend' x1 y1 :*: gmappend' x2 y2 + +-- | Generically generate a 'Monoid' 'mempty' for any product-like type +-- implementing 'Generic'. +-- +-- It is only defined for product types. +-- +-- @ +-- 'gmappend' 'gmempty' a = a = 'gmappend' a 'gmempty' +-- @ + +gmempty :: (Generic a, GMonoid (Rep a)) => a +gmempty = to gmempty' + +class GSemigroup f => GMonoid f where + gmempty' :: f p + +instance (Semigroup a, Monoid a) => GMonoid (K1 i a) where + gmempty' = K1 mempty + +instance GMonoid f => GMonoid (M1 i c f) where + gmempty' = M1 gmempty' + +instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where + gmempty' = gmempty' :*: gmempty' diff --git a/Distribution/Compat/TempFile.hs b/Distribution/Compat/TempFile.hs deleted file mode 100644 --- a/Distribution/Compat/TempFile.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.TempFile ( - openTempFile, - openBinaryTempFile, - openNewBinaryFile, - createTempDirectory, - ) where - - -import System.FilePath (()) -import Foreign.C (eEXIST) - -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) -import System.Posix.Internals (withFilePath) -import Foreign.C (CInt) -import GHC.IO.Handle.FD (fdToHandle) -import Distribution.Compat.Exception (tryIO) -import Control.Exception (onException) -import Foreign.C (getErrno, errnoToIOError) - -import System.Posix.Internals (c_getpid) - -#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) -import System.Directory ( createDirectory ) -#else -import qualified System.Posix -#endif - --- ------------------------------------------------------------ --- * temporary files --- ------------------------------------------------------------ - --- This is here for Haskell implementations that do not come with --- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9. --- TODO: Not sure about JHC --- TODO: This file should probably be removed. - --- This is a copy/paste of the openBinaryTempFile definition, but --- if uses 666 rather than 600 for the permissions. The base library --- needs to be changed to make this better. -openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) -openNewBinaryFile dir template = do - pid <- c_getpid - findTempName pid - where - -- We split off the last extension, so we can use .foo.ext files - -- for temporary files (hidden on Unix OSes). Unfortunately we're - -- below file path in the hierarchy here. - (prefix,suffix) = - case break (== '.') $ reverse template of - -- First case: template contains no '.'s. Just re-reverse it. - (rev_suffix, "") -> (reverse rev_suffix, "") - -- Second case: template contains at least one '.'. Strip the - -- dot from the prefix and prepend it to the suffix (if we don't - -- do this, the unique number will get added after the '.' and - -- thus be part of the extension, which is wrong.) - (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) - -- Otherwise, something is wrong, because (break (== '.')) should - -- always return a pair with either the empty string or a string - -- beginning with '.' as the second component. - _ -> error "bug in System.IO.openTempFile" - - oflags = rw_flags .|. o_EXCL .|. o_BINARY - - findTempName x = do - fd <- withFilePath filepath $ \ f -> - c_open f oflags 0o666 - if fd < 0 - then do - errno <- getErrno - if errno == eEXIST - then findTempName (x+1) - else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) - else do - -- TODO: We want to tell fdToHandle what the file path is, - -- as any exceptions etc will only be able to report the - -- FD currently - h <- fdToHandle fd `onException` c_close fd - return (filepath, h) - where - filename = prefix ++ show x ++ suffix - filepath = dir `combine` filename - - -- FIXME: bits copied from System.FilePath - combine a b - | null b = a - | null a = b - | last a == pathSeparator = a ++ b - | otherwise = a ++ [pathSeparator] ++ b - --- FIXME: Should use System.FilePath library -pathSeparator :: Char -#ifdef mingw32_HOST_OS -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif - --- FIXME: Copied from GHC.Handle -std_flags, output_flags, rw_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -rw_flags = output_flags .|. o_RDWR - -createTempDirectory :: FilePath -> String -> IO FilePath -createTempDirectory dir template = do - pid <- c_getpid - findTempName pid - where - findTempName x = do - let dirpath = dir template ++ "-" ++ show x - r <- tryIO $ mkPrivateDir dirpath - case r of - Right _ -> return dirpath - Left e | isAlreadyExistsError e -> findTempName (x+1) - | otherwise -> ioError e - -mkPrivateDir :: String -> IO () -#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) -mkPrivateDir s = createDirectory s -#else -mkPrivateDir s = System.Posix.createDirectory s 0o700 -#endif diff --git a/Distribution/Compiler.hs b/Distribution/Compiler.hs --- a/Distribution/Compiler.hs +++ b/Distribution/Compiler.hs @@ -42,15 +42,15 @@ AbiTag(..), abiTagString ) where -import Distribution.Compat.Binary (Binary) +import Distribution.Compat.Binary +import Language.Haskell.Extension + import Data.Data (Data) import Data.Typeable (Typeable) import Data.Maybe (fromMaybe) import Distribution.Version (Version(..)) import GHC.Generics (Generic) -import Language.Haskell.Extension (Language, Extension) - import qualified System.Info (compilerName, compilerVersion) import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse @@ -180,7 +180,7 @@ data AbiTag = NoAbiTag | AbiTag String - deriving (Generic, Show, Read) + deriving (Eq, Generic, Show, Read) instance Binary AbiTag diff --git a/Distribution/InstalledPackageInfo.hs b/Distribution/InstalledPackageInfo.hs --- a/Distribution/InstalledPackageInfo.hs +++ b/Distribution/InstalledPackageInfo.hs @@ -27,7 +27,9 @@ -- This module is meant to be local-only to Distribution... module Distribution.InstalledPackageInfo ( - InstalledPackageInfo_(..), InstalledPackageInfo, + InstalledPackageInfo(..), + installedComponentId, + installedPackageId, OriginalModule(..), ExposedModule(..), ParseResult(..), PError(..), PWarning, emptyInstalledPackageInfo, @@ -39,42 +41,30 @@ ) where import Distribution.ParseUtils - ( FieldDescr(..), ParseResult(..), PError(..), PWarning - , simpleField, listField, parseLicenseQ - , showFields, showSingleNamedField, showSimpleSingleNamedField - , parseFieldsFlat - , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ - , showFilePath, showToken, boolField, parseOptVersion - , parseFreeText, showFreeText, parseOptCommaList ) -import Distribution.License ( License(..) ) -import Distribution.Package - ( PackageName(..), PackageIdentifier(..) - , PackageId, InstalledPackageId(..) - , packageName, packageVersion, PackageKey(..) ) +import Distribution.License +import Distribution.Package hiding (installedUnitId, installedPackageId) import qualified Distribution.Package as Package import Distribution.ModuleName - ( ModuleName ) import Distribution.Version - ( Version(..) ) import Distribution.Text - ( Text(disp, parse) ) -import Text.PrettyPrint as Disp import qualified Distribution.Compat.ReadP as Parse +import Distribution.Compat.Binary -import Distribution.Compat.Binary (Binary) +import Text.PrettyPrint as Disp import Data.Maybe (fromMaybe) import GHC.Generics (Generic) -- ----------------------------------------------------------------------------- -- The InstalledPackageInfo type - -data InstalledPackageInfo_ m +-- For BC reasons, we continue to name this record an InstalledPackageInfo; +-- but it would more accurately be called an InstalledUnitInfo with Backpack +data InstalledPackageInfo = InstalledPackageInfo { -- these parts are exactly the same as PackageDescription - installedPackageId :: InstalledPackageId, - sourcePackageId :: PackageId, - packageKey :: PackageKey, + sourcePackageId :: PackageId, + installedUnitId :: UnitId, + compatPackageKey :: String, license :: License, copyright :: String, maintainer :: String, @@ -86,10 +76,10 @@ description :: String, category :: String, -- these parts are required by an installed package only: + abiHash :: AbiHash, exposed :: Bool, exposedModules :: [ExposedModule], - instantiatedWith :: [(m, OriginalModule)], - hiddenModules :: [m], + hiddenModules :: [ModuleName], trusted :: Bool, importDirs :: [FilePath], libraryDirs :: [FilePath], @@ -99,7 +89,7 @@ extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi includeDirs :: [FilePath], includes :: [String], - depends :: [InstalledPackageId], + depends :: [UnitId], ccOptions :: [String], ldOptions :: [String], frameworkDirs :: [FilePath], @@ -108,26 +98,34 @@ haddockHTMLs :: [FilePath], pkgRoot :: Maybe FilePath } - deriving (Generic, Read, Show) + deriving (Eq, Generic, Read, Show) -instance Binary m => Binary (InstalledPackageInfo_ m) +installedComponentId :: InstalledPackageInfo -> ComponentId +installedComponentId ipi = case installedUnitId ipi of + SimpleUnitId cid -> cid -instance Package.Package (InstalledPackageInfo_ str) where +{-# DEPRECATED installedPackageId "Use installedUnitId instead" #-} +-- | Backwards compatibility with Cabal pre-1.24. +installedPackageId :: InstalledPackageInfo -> UnitId +installedPackageId = installedUnitId + +instance Binary InstalledPackageInfo + +instance Package.Package InstalledPackageInfo where packageId = sourcePackageId -instance Package.PackageInstalled (InstalledPackageInfo_ str) where - installedPackageId = installedPackageId - installedDepends = depends +instance Package.HasUnitId InstalledPackageInfo where + installedUnitId = installedUnitId -type InstalledPackageInfo = InstalledPackageInfo_ ModuleName +instance Package.PackageInstalled InstalledPackageInfo where + installedDepends = depends -emptyInstalledPackageInfo :: InstalledPackageInfo_ m +emptyInstalledPackageInfo :: InstalledPackageInfo emptyInstalledPackageInfo = InstalledPackageInfo { - installedPackageId = InstalledPackageId "", - sourcePackageId = PackageIdentifier (PackageName "") noVersion, - packageKey = OldPackageKey (PackageIdentifier - (PackageName "") noVersion), + sourcePackageId = PackageIdentifier (PackageName "") (Version [] []), + installedUnitId = mkUnitId "", + compatPackageKey = "", license = UnspecifiedLicense, copyright = "", maintainer = "", @@ -138,10 +136,10 @@ synopsis = "", description = "", category = "", + abiHash = AbiHash "", exposed = False, exposedModules = [], hiddenModules = [], - instantiatedWith = [], trusted = False, importDirs = [], libraryDirs = [], @@ -161,15 +159,12 @@ pkgRoot = Nothing } -noVersion :: Version -noVersion = Version [] [] - -- ----------------------------------------------------------------------------- -- Exposed modules data OriginalModule = OriginalModule { - originalPackageId :: InstalledPackageId, + originalPackageId :: UnitId, originalModuleName :: ModuleName } deriving (Generic, Eq, Read, Show) @@ -177,10 +172,9 @@ data ExposedModule = ExposedModule { exposedName :: ModuleName, - exposedReexport :: Maybe OriginalModule, - exposedSignature :: Maybe OriginalModule -- This field is unused for now. + exposedReexport :: Maybe OriginalModule } - deriving (Generic, Read, Show) + deriving (Eq, Generic, Read, Show) instance Text OriginalModule where disp (OriginalModule ipi m) = @@ -192,14 +186,11 @@ return (OriginalModule ipi m) instance Text ExposedModule where - disp (ExposedModule m reexport signature) = + disp (ExposedModule m reexport) = Disp.sep [ disp m , case reexport of Just m' -> Disp.sep [Disp.text "from", disp m'] Nothing -> Disp.empty - , case signature of - Just m' -> Disp.sep [Disp.text "is", disp m'] - Nothing -> Disp.empty ] parse = do m <- parseModuleNameQ @@ -208,12 +199,7 @@ _ <- Parse.string "from" Parse.skipSpaces fmap Just parse - Parse.skipSpaces - signature <- Parse.option Nothing $ do - _ <- Parse.string "is" - Parse.skipSpaces - fmap Just parse - return (ExposedModule m reexport signature) + return (ExposedModule m reexport) instance Binary OriginalModule @@ -229,7 +215,7 @@ showExposedModules xs | all isExposedModule xs = fsep (map disp xs) | otherwise = fsep (Disp.punctuate comma (map disp xs)) - where isExposedModule (ExposedModule _ Nothing Nothing) = True + where isExposedModule (ExposedModule _ Nothing) = True isExposedModule _ = False parseExposedModules :: Parse.ReadP r [ExposedModule] @@ -243,14 +229,6 @@ parseFieldsFlat (fieldsInstalledPackageInfo ++ deprecatedFieldDescrs) emptyInstalledPackageInfo -parseInstantiatedWith :: Parse.ReadP r (ModuleName, OriginalModule) -parseInstantiatedWith = do k <- parse - _ <- Parse.char '=' - n <- parse - _ <- Parse.char '@' - p <- parse - return (k, OriginalModule p n) - -- ----------------------------------------------------------------------------- -- Pretty-printing @@ -263,9 +241,6 @@ showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) showSimpleInstalledPackageInfoField = showSimpleSingleNamedField fieldsInstalledPackageInfo -showInstantiatedWith :: (ModuleName, OriginalModule) -> Doc -showInstantiatedWith (k, OriginalModule p m) = disp k <> text "=" <> disp m <> text "@" <> disp p - -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing @@ -282,10 +257,11 @@ packageVersion (\ver pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgVersion=ver}}) , simpleField "id" disp parse - installedPackageId (\ipid pkg -> pkg{installedPackageId=ipid}) + installedUnitId (\pk pkg -> pkg{installedUnitId=pk}) + -- NB: parse these as component IDs , simpleField "key" - disp parse - packageKey (\ipid pkg -> pkg{packageKey=ipid}) + (disp . ComponentId) (fmap (\(ComponentId s) -> s) parse) + compatPackageKey (\pk pkg -> pkg{compatPackageKey=pk}) , simpleField "license" disp parseLicenseQ license (\l pkg -> pkg{license=l}) @@ -328,9 +304,9 @@ , listField "hidden-modules" disp parseModuleNameQ hiddenModules (\xs pkg -> pkg{hiddenModules=xs}) - , listField "instantiated-with" - showInstantiatedWith parseInstantiatedWith - instantiatedWith (\xs pkg -> pkg{instantiatedWith=xs}) + , simpleField "abi" + disp parse + abiHash (\abi pkg -> pkg{abiHash=abi}) , boolField "trusted" trusted (\val pkg -> pkg{trusted=val}) , listField "import-dirs" diff --git a/Distribution/Lex.hs b/Distribution/Lex.hs new file mode 100644 --- /dev/null +++ b/Distribution/Lex.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Lex +-- Copyright : Ben Gamari 2015-2019 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains a simple lexer supporting quoted strings + +module Distribution.Lex ( + tokenizeQuotedWords + ) where + +import Data.Char (isSpace) +import Distribution.Compat.Semigroup as Semi + +newtype DList a = DList ([a] -> [a]) + +runDList :: DList a -> [a] +runDList (DList run) = run [] + +singleton :: a -> DList a +singleton a = DList (a:) + +instance Monoid (DList a) where + mempty = DList id + mappend = (Semi.<>) + +instance Semigroup (DList a) where + DList a <> DList b = DList (a . b) + +tokenizeQuotedWords :: String -> [String] +tokenizeQuotedWords = filter (not . null) . go False mempty + where + go :: Bool -- ^ in quoted region + -> DList Char -- ^ accumulator + -> String -- ^ string to be parsed + -> [String] -- ^ parse result + go _ accum [] + | [] <- accum' = [] + | otherwise = [accum'] + where accum' = runDList accum + + go False accum (c:cs) + | isSpace c = runDList accum : go False mempty cs + | c == '"' = go True accum cs + + go True accum (c:cs) + | c == '"' = go False accum cs + + go quoted accum (c:cs) + = go quoted (accum `mappend` singleton c) cs + diff --git a/Distribution/License.hs b/Distribution/License.hs --- a/Distribution/License.hs +++ b/Distribution/License.hs @@ -47,13 +47,13 @@ knownLicenses, ) where -import Distribution.Version (Version(Version)) - -import Distribution.Text (Text(..), display) +import Distribution.Version +import Distribution.Text import qualified Distribution.Compat.ReadP as Parse +import Distribution.Compat.Binary + import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>)) -import Distribution.Compat.Binary (Binary) import qualified Data.Char as Char (isAlphaNum) import Data.Data (Data) import Data.Typeable (Typeable) diff --git a/Distribution/Make.hs b/Distribution/Make.hs --- a/Distribution/Make.hs +++ b/Distribution/Make.hs @@ -62,22 +62,19 @@ -- local import Distribution.Compat.Exception -import Distribution.Package --must not specify imports, since we're exporting moule. -import Distribution.Simple.Program(defaultProgramConfiguration) +import Distribution.Package +import Distribution.Simple.Program import Distribution.PackageDescription import Distribution.Simple.Setup import Distribution.Simple.Command -import Distribution.Simple.Utils (rawSystemExit, cabalVersion) +import Distribution.Simple.Utils -import Distribution.License (License(..)) +import Distribution.License import Distribution.Version - ( Version(..) ) import Distribution.Text - ( display ) import System.Environment (getArgs, getProgName) -import Data.List (intercalate) import System.Exit defaultMain :: IO () diff --git a/Distribution/ModuleName.hs b/Distribution/ModuleName.hs --- a/Distribution/ModuleName.hs +++ b/Distribution/ModuleName.hs @@ -22,14 +22,13 @@ ) where import Distribution.Text - ( Text(..) ) +import Distribution.Compat.Binary +import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.Binary (Binary) import qualified Data.Char as Char ( isAlphaNum, isUpper ) import Data.Data (Data) import Data.Typeable (Typeable) -import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp import Data.List ( intercalate, intersperse ) diff --git a/Distribution/Package.hs b/Distribution/Package.hs --- a/Distribution/Package.hs +++ b/Distribution/Package.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | @@ -21,14 +22,16 @@ PackageIdentifier(..), PackageId, - -- * Installed package identifiers - InstalledPackageId(..), + -- * Package keys/installed package IDs (used for linker symbols) + ComponentId(..), + UnitId(..), + mkUnitId, + mkLegacyUnitId, + getHSLibraryName, + InstalledPackageId, -- backwards compat - -- * Package keys (used for linker symbols and library name) - PackageKey(..), - mkPackageKey, - packageKeyHash, - packageKeyLibraryName, + -- * ABI hash + AbiHash(..), -- * Package source dependencies Dependency(..), @@ -38,32 +41,28 @@ -- * Package classes Package(..), packageName, packageVersion, - PackageFixedDeps(..), + HasUnitId(..), + installedPackageId, PackageInstalled(..), ) where -import Distribution.ModuleName ( ModuleName ) import Distribution.Version ( Version(..), VersionRange, anyVersion, thisVersion , notThisVersion, simplifyVersionRange ) -import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP ((<++)) import qualified Text.PrettyPrint as Disp +import Distribution.Compat.ReadP +import Distribution.Compat.Binary +import Distribution.Text import Control.DeepSeq (NFData(..)) -import Data.Ord ( comparing ) -import Distribution.Compat.Binary (Binary) import qualified Data.Char as Char - ( isDigit, isAlphaNum, isUpper, isLower, ord, chr ) + ( isDigit, isAlphaNum, ) import Data.Data ( Data ) -import Data.List ( intercalate, foldl', sortBy ) +import Data.List ( intercalate ) import Data.Typeable ( Typeable ) -import Data.Word ( Word64 ) -import GHC.Fingerprint ( Fingerprint(..), fingerprintString ) import GHC.Generics (Generic) -import Numeric ( showIntAtBase ) import Text.PrettyPrint ((<>), (<+>), text) newtype PackageName = PackageName { unPackageName :: String } @@ -113,192 +112,47 @@ rnf (PackageIdentifier name version) = rnf name `seq` rnf version -- ------------------------------------------------------------ --- * Installed Package Ids --- ------------------------------------------------------------ - --- | An InstalledPackageId uniquely identifies an instance of an installed --- package. There can be at most one package with a given 'InstalledPackageId' --- in a package database, or overlay of databases. --- -newtype InstalledPackageId = InstalledPackageId String - deriving (Generic, Read,Show,Eq,Ord,Typeable,Data) - -instance Binary InstalledPackageId - -instance Text InstalledPackageId where - disp (InstalledPackageId str) = text str - - parse = InstalledPackageId `fmap` Parse.munch1 abi_char - where abi_char c = Char.isAlphaNum c || c `elem` "-_." - --- ------------------------------------------------------------ --- * Package Keys +-- * Component Source Hash -- ------------------------------------------------------------ --- | A 'PackageKey' is the notion of "package ID" which is visible to the --- compiler. Why is this not a 'PackageId'? The 'PackageId' is a user-visible --- concept written explicity in Cabal files; on the other hand, a 'PackageKey' --- may contain, for example, information about the transitive dependency --- tree of a package. Why is this not an 'InstalledPackageId'? A 'PackageKey' --- affects the ABI because it is used for linker symbols; however, an --- 'InstalledPackageId' can be used to distinguish two ABI-compatible versions --- of a library. --- --- The key is defined to be a 128-bit MD5 hash, separated into two 64-bit --- components (the most significant component coming first) which are --- individually base-62 encoded (A-Z, a-z, 0-9). --- --- @ --- key ::= hash64 hash64 --- hash64 ::= [A-Za-z0-9]{11} --- @ --- --- The string that is hashed is specified as raw_key: --- --- @ --- raw_key ::= package_id "\n" --- holes_nl --- depends_nl --- package_id ::= package_name "-" package_version --- holes_nl ::= "" --- | hole_inst "\n" holes_nl --- hole_inst ::= modulename " " key ":" modulename --- depends_nl ::= "" --- | depend "\n" depends_nl --- depend ::= key --- @ --- --- The holes list MUST be sorted by the first modulename; the depends list --- MUST be sorted by the key. holes describes the backing implementations of --- all holes in the package; depends describes all of the build-depends of --- a package. A package key MAY be used in holes even if it is not --- mentioned in depends: depends contains STRICTLY packages which are --- textually mentioned in the package description. --- --- The trailing newline is MANDATORY. --- --- There is also a variant of package key which is prefixed by a informational --- string. This key MUST NOT be used in the computation of the hash proper, --- but it is useful for human-readable consumption. --- --- @ --- infokey ::= infostring "_" key --- infostring ::= [A-Za-z0-9-]+ --- @ --- --- For example, Cabal provides a key with the first five characters of the --- package name for linker symbols. +-- | A 'ComponentId' uniquely identifies the transitive source +-- code closure of a component. For non-Backpack components, it also +-- serves as the basis for install paths, symbols, etc. -- -data PackageKey - -- | Modern package key which is a hash of the PackageId and the transitive - -- dependency key. Manually inline it here so we can get the instances - -- we need. Also contains a short informative string - = PackageKey !String {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 - -- | Old-style package key which is just a 'PackageId'. Required because - -- old versions of GHC assume that the 'sourcePackageId' recorded for an - -- installed package coincides with the package key it was compiled with. - | OldPackageKey !PackageId +data ComponentId + = ComponentId String deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) -instance Binary PackageKey - --- | Convenience function which converts a fingerprint into a new-style package --- key. -fingerprintPackageKey :: String -> Fingerprint -> PackageKey -fingerprintPackageKey s (Fingerprint a b) = PackageKey s a b - --- | Generates a 'PackageKey' from a 'PackageId', sorted package keys of the --- immediate dependencies. -mkPackageKey :: Bool -- are modern style package keys supported? - -> PackageId - -> [PackageKey] -- dependencies - -> [(ModuleName, (PackageKey, ModuleName))] -- hole instantiations - -> PackageKey -mkPackageKey True pid deps holes = - fingerprintPackageKey stubName . fingerprintString $ - display pid ++ "\n" ++ - -- NB: packageKeyHash, NOT display - concat [ display m ++ " " ++ packageKeyHash p' ++ ":" ++ display m' ++ "\n" - | (m, (p', m')) <- sortBy (comparing fst) holes] ++ - concat [ packageKeyHash d ++ "\n" - | d <- sortBy (comparing packageKeyHash) deps] - where stubName = take 5 (filter (/= '-') (unPackageName (pkgName pid))) -mkPackageKey False pid _ _ = OldPackageKey pid - --- The base-62 code is based off of 'locators' --- ((c) Operational Dynamics Consulting, BSD3 licensed) - --- Note: Instead of base-62 encoding a single 128-bit integer --- (ceil(21.49) characters), we'll base-62 a pair of 64-bit integers --- (2 * ceil(10.75) characters). Luckily for us, it's the same number of --- characters! In the long term, this should go in GHC.Fingerprint, --- but not now... - --- | Size of a 64-bit word when written as a base-62 string -word64Base62Len :: Int -word64Base62Len = 11 - --- | Converts a 64-bit word into a base-62 string -toBase62 :: Word64 -> String -toBase62 w = pad ++ str - where - pad = replicate len '0' - len = word64Base62Len - length str -- 11 == ceil(64 / lg 62) - str = showIntAtBase 62 represent w "" - represent :: Int -> Char - represent x - | x < 10 = Char.chr (48 + x) - | x < 36 = Char.chr (65 + x - 10) - | x < 62 = Char.chr (97 + x - 36) - | otherwise = error ("represent (base 62): impossible!") +{-# DEPRECATED InstalledPackageId "Use UnitId instead" #-} +type InstalledPackageId = UnitId --- | Parses a base-62 string into a 64-bit word -fromBase62 :: String -> Word64 -fromBase62 ss = foldl' multiply 0 ss - where - value :: Char -> Int - value c - | Char.isDigit c = Char.ord c - 48 - | Char.isUpper c = Char.ord c - 65 + 10 - | Char.isLower c = Char.ord c - 97 + 36 - | otherwise = error ("value (base 62): impossible!") +instance Binary ComponentId - multiply :: Word64 -> Char -> Word64 - multiply acc c = acc * 62 + (fromIntegral $ value c) +instance Text ComponentId where + disp (ComponentId str) = text str --- | Parses a base-62 string into a fingerprint. -readBase62Fingerprint :: String -> Fingerprint -readBase62Fingerprint s = Fingerprint w1 w2 - where (s1,s2) = splitAt word64Base62Len s - w1 = fromBase62 s1 - w2 = fromBase62 (take word64Base62Len s2) + parse = ComponentId `fmap` Parse.munch1 abi_char + where abi_char c = Char.isAlphaNum c || c `elem` "-_." -packageKeyHash :: PackageKey -> String -packageKeyHash (PackageKey _ w1 w2) = toBase62 w1 ++ toBase62 w2 -packageKeyHash (OldPackageKey pid) = display pid +instance NFData ComponentId where + rnf (ComponentId pk) = rnf pk -packageKeyLibraryName :: PackageId -> PackageKey -> String -packageKeyLibraryName pid (PackageKey _ w1 w2) = display pid ++ "-" ++ toBase62 w1 ++ toBase62 w2 -packageKeyLibraryName _ (OldPackageKey pid) = display pid +-- | Returns library name prefixed with HS, suitable for filenames +getHSLibraryName :: UnitId -> String +getHSLibraryName (SimpleUnitId (ComponentId s)) = "HS" ++ s -instance Text PackageKey where - disp (PackageKey prefix w1 w2) = Disp.text prefix <> Disp.char '_' - <> Disp.text (toBase62 w1) <> Disp.text (toBase62 w2) - disp (OldPackageKey pid) = disp pid +-- | For now, there is no distinction between component IDs +-- and unit IDs in Cabal. +newtype UnitId = SimpleUnitId ComponentId + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, Text, NFData) - parse = parseNew <++ parseOld - where parseNew = do - prefix <- Parse.munch1 (\c -> Char.isAlphaNum c || c `elem` "-") - _ <- Parse.char '_' -- if we use '-' it's ambiguous - fmap (fingerprintPackageKey prefix . readBase62Fingerprint) - . Parse.count (word64Base62Len * 2) - $ Parse.satisfy Char.isAlphaNum - parseOld = do pid <- parse - return (OldPackageKey pid) +-- | Makes a simple-style UnitId from a string. +mkUnitId :: String -> UnitId +mkUnitId = SimpleUnitId . ComponentId -instance NFData PackageKey where - rnf (PackageKey prefix _ _) = rnf prefix - rnf (OldPackageKey pid) = rnf pid +-- | Make an old-style UnitId from a package identifier +mkLegacyUnitId :: PackageId -> UnitId +mkLegacyUnitId = SimpleUnitId . ComponentId . display -- ------------------------------------------------------------ -- * Package source dependencies @@ -358,22 +212,31 @@ instance Package PackageIdentifier where packageId = id --- | Subclass of packages that have specific versioned dependencies. --- --- So for example a not-yet-configured package has dependencies on version --- ranges, not specific versions. A configured or an already installed package --- depends on exact versions. Some operations or data structures (like --- dependency graphs) only make sense on this subclass of package types. --- -class Package pkg => PackageFixedDeps pkg where - depends :: pkg -> [PackageIdentifier] +-- | Packages that have an installed package ID +class Package pkg => HasUnitId pkg where + installedUnitId :: pkg -> UnitId +{-# DEPRECATED installedPackageId "Use installedUnitId instead" #-} +-- | Compatibility wrapper for Cabal pre-1.24. +installedPackageId :: HasUnitId pkg => pkg -> UnitId +installedPackageId = installedUnitId + -- | Class of installed packages. -- -- The primary data type which is an instance of this package is -- 'InstalledPackageInfo', but when we are doing install plans in Cabal install -- we may have other, installed package-like things which contain more metadata. -- Installed packages have exact dependencies 'installedDepends'. -class Package pkg => PackageInstalled pkg where - installedPackageId :: pkg -> InstalledPackageId - installedDepends :: pkg -> [InstalledPackageId] +class (HasUnitId pkg) => PackageInstalled pkg where + installedDepends :: pkg -> [UnitId] + +-- ----------------------------------------------------------------------------- +-- ABI hash + +newtype AbiHash = AbiHash String + deriving (Eq, Show, Read, Generic) +instance Binary AbiHash + +instance Text AbiHash where + disp (AbiHash abi) = Disp.text abi + parse = fmap AbiHash (Parse.munch Char.isAlphaNum) diff --git a/Distribution/PackageDescription.hs b/Distribution/PackageDescription.hs --- a/Distribution/PackageDescription.hs +++ b/Distribution/PackageDescription.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} @@ -98,46 +97,47 @@ GenericPackageDescription(..), Flag(..), FlagName(..), FlagAssignment, CondTree(..), ConfVar(..), Condition(..), + cNot, cAnd, cOr, -- * Source repositories SourceRepo(..), RepoKind(..), RepoType(..), knownRepoTypes, + + -- * Custom setup build information + SetupBuildInfo(..), ) where -import Distribution.Compat.Binary (Binary) -import Data.Data (Data) -import Data.List (nub, intercalate) -import Data.Maybe (fromMaybe, maybeToList) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (Monoid(mempty, mappend)) -#endif -import Data.Typeable ( Typeable ) -import Control.Monad (MonadPlus(mplus)) -import GHC.Generics (Generic) -import Text.PrettyPrint as Disp +import Distribution.Compat.Binary +import qualified Distribution.Compat.Semigroup as Semi ((<>)) +import Distribution.Compat.Semigroup as Semi (Monoid(..), Semigroup, gmempty) import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP ((<++)) -import qualified Data.Char as Char (isAlphaNum, isDigit, toLower) -import qualified Data.Map as Map -import Data.Map (Map) - +import Distribution.Compat.ReadP ((<++)) import Distribution.Package - ( PackageName(PackageName), PackageIdentifier(PackageIdentifier) - , Dependency, Package(..), PackageName, packageName ) -import Distribution.ModuleName ( ModuleName ) +import Distribution.ModuleName import Distribution.Version - ( Version(Version), VersionRange, anyVersion, orLaterVersion - , asVersionIntervals, LowerBound(..) ) -import Distribution.License (License(UnspecifiedLicense)) -import Distribution.Compiler (CompilerFlavor) -import Distribution.System (OS, Arch) +import Distribution.License +import Distribution.Compiler +import Distribution.System import Distribution.Text - ( Text(..), display ) import Language.Haskell.Extension - ( Language, Extension ) +import Data.Data (Data) +import Data.Foldable (traverse_) +import Data.List (nub, intercalate) +import Data.Maybe (fromMaybe, maybeToList) +import Data.Foldable as Fold (Foldable(foldMap)) +import Data.Traversable as Trav (Traversable(traverse)) +import Data.Typeable ( Typeable ) +import Control.Applicative as AP (Alternative(..), Applicative(..)) +import Control.Monad (MonadPlus(mplus,mzero), ap) +import GHC.Generics (Generic) +import Text.PrettyPrint as Disp +import qualified Data.Char as Char (isAlphaNum, isDigit, toLower) +import qualified Data.Map as Map +import Data.Map (Map) + -- ----------------------------------------------------------------------------- -- The PackageDescription type @@ -168,6 +168,7 @@ customFieldsPD :: [(String,String)], -- ^Custom fields starting -- with x-, stored in a -- simple assoc-list. + -- | YOU PROBABLY DON'T WANT TO USE THIS FIELD. This field is -- special! Depending on how far along processing the -- PackageDescription we are, the contents of this field are @@ -186,6 +187,7 @@ -- transitioning to specifying just a single version, not a range. specVersionRaw :: Either Version VersionRange, buildType :: Maybe BuildType, + setupBuildInfo :: Maybe SetupBuildInfo, -- components library :: Maybe Library, executables :: [Executable], @@ -253,6 +255,7 @@ description = "", category = "", customFieldsPD = [], + setupBuildInfo = Nothing, library = Nothing, executables = [], testSuites = [], @@ -298,6 +301,33 @@ _ -> UnknownBuildType name -- --------------------------------------------------------------------------- +-- The SetupBuildInfo type + +-- One can see this as a very cut-down version of BuildInfo below. +-- To keep things simple for tools that compile Setup.hs we limit the +-- options authors can specify to just Haskell package dependencies. + +data SetupBuildInfo = SetupBuildInfo { + setupDepends :: [Dependency], + defaultSetupDepends :: Bool + -- ^ Is this a default 'custom-setup' section added by the cabal-install + -- code (as opposed to user-provided)? This field is only used + -- internally, and doesn't correspond to anything in the .cabal + -- file. See #3199. + } + deriving (Generic, Show, Eq, Read, Typeable, Data) + +instance Binary SetupBuildInfo + +instance Semi.Monoid SetupBuildInfo where + mempty = SetupBuildInfo [] False + mappend = (Semi.<>) + +instance Semigroup SetupBuildInfo where + a <> b = SetupBuildInfo (setupDepends a Semi.<> setupDepends b) + (defaultSetupDepends a || defaultSetupDepends b) + +-- --------------------------------------------------------------------------- -- Module renaming -- | Renaming applied to the modules provided by a package. @@ -313,18 +343,18 @@ defaultRenaming = ModuleRenaming True [] lookupRenaming :: Package pkg => pkg -> Map PackageName ModuleRenaming -> ModuleRenaming -lookupRenaming pkg rns = - Map.findWithDefault - (error ("lookupRenaming: missing renaming for " ++ display (packageName pkg))) - (packageName pkg) rns +lookupRenaming = Map.findWithDefault defaultRenaming . packageName instance Binary ModuleRenaming where instance Monoid ModuleRenaming where - ModuleRenaming b rns `mappend` ModuleRenaming b' rns' - = ModuleRenaming (b || b') (rns ++ rns') -- ToDo: dedupe? mempty = ModuleRenaming False [] + mappend = (Semi.<>) +instance Semigroup ModuleRenaming where + ModuleRenaming b rns <> ModuleRenaming b' rns' + = ModuleRenaming (b || b') (rns ++ rns') -- ToDo: dedupe? + -- NB: parentheses are mandatory, because later we may extend this syntax -- to allow "hiding (A, B)" or other modifier words. instance Text ModuleRenaming where @@ -383,7 +413,10 @@ libExposed = True, libBuildInfo = mempty } - mappend a b = Library { + mappend = (Semi.<>) + +instance Semigroup Library where + a <> b = Library { exposedModules = combine exposedModules, reexportedModules = combine reexportedModules, requiredSignatures = combine requiredSignatures, @@ -411,7 +444,7 @@ -- function with the library build info as argument. withLib :: PackageDescription -> (Library -> IO ()) -> IO () withLib pkg_descr f = - maybe (return ()) f (maybeHasLibs pkg_descr) + traverse_ f (maybeHasLibs pkg_descr) -- | Get all the module names from the library (exposed and internal modules) -- which need to be compiled. (This does not include reexports, which @@ -444,7 +477,7 @@ parse = do mpkgname <- Parse.option Nothing $ do - pkgname <- parse + pkgname <- parse _ <- Parse.char ':' return (Just pkgname) origname <- parse @@ -468,12 +501,11 @@ instance Binary Executable instance Monoid Executable where - mempty = Executable { - exeName = mempty, - modulePath = mempty, - buildInfo = mempty - } - mappend a b = Executable{ + mempty = gmempty + mappend = (Semi.<>) + +instance Semigroup Executable where + a <> b = Executable{ exeName = combine' exeName, modulePath = combine modulePath, buildInfo = combine buildInfo @@ -558,8 +590,10 @@ testBuildInfo = mempty, testEnabled = False } + mappend = (Semi.<>) - mappend a b = TestSuite { +instance Semigroup TestSuite where + a <> b = TestSuite { testName = combine' testName, testInterface = combine testInterface, testBuildInfo = combine testBuildInfo, @@ -574,9 +608,12 @@ instance Monoid TestSuiteInterface where mempty = TestSuiteUnsupported (TestTypeUnknown mempty (Version [] [])) - mappend a (TestSuiteUnsupported _) = a - mappend _ b = b + mappend = (Semi.<>) +instance Semigroup TestSuiteInterface where + a <> (TestSuiteUnsupported _) = a + _ <> b = b + emptyTestSuite :: TestSuite emptyTestSuite = mempty @@ -691,8 +728,10 @@ benchmarkBuildInfo = mempty, benchmarkEnabled = False } + mappend = (Semi.<>) - mappend a b = Benchmark { +instance Semigroup Benchmark where + a <> b = Benchmark { benchmarkName = combine' benchmarkName, benchmarkInterface = combine benchmarkInterface, benchmarkBuildInfo = combine benchmarkBuildInfo, @@ -707,9 +746,12 @@ instance Monoid BenchmarkInterface where mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty (Version [] [])) - mappend a (BenchmarkUnsupported _) = a - mappend _ b = b + mappend = (Semi.<>) +instance Semigroup BenchmarkInterface where + a <> (BenchmarkUnsupported _) = a + _ <> b = b + emptyBenchmark :: Benchmark emptyBenchmark = mempty @@ -769,6 +811,7 @@ ldOptions :: [String], -- ^ options for linker pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used frameworks :: [String], -- ^support frameworks for Mac OS X + extraFrameworkDirs:: [String], -- ^ extra locations to find frameworks. cSources :: [FilePath], jsSources :: [FilePath], hsSourceDirs :: [FilePath], -- ^ where to look for the Haskell module hierarchy @@ -801,63 +844,68 @@ instance Monoid BuildInfo where mempty = BuildInfo { - buildable = True, - buildTools = [], - cppOptions = [], - ccOptions = [], - ldOptions = [], - pkgconfigDepends = [], - frameworks = [], - cSources = [], - jsSources = [], - hsSourceDirs = [], - otherModules = [], - defaultLanguage = Nothing, - otherLanguages = [], - defaultExtensions = [], - otherExtensions = [], - oldExtensions = [], - extraLibs = [], - extraGHCiLibs = [], - extraLibDirs = [], - includeDirs = [], - includes = [], - installIncludes = [], - options = [], - profOptions = [], - sharedOptions = [], - customFieldsBI = [], - targetBuildDepends = [], + buildable = True, + buildTools = [], + cppOptions = [], + ccOptions = [], + ldOptions = [], + pkgconfigDepends = [], + frameworks = [], + extraFrameworkDirs = [], + cSources = [], + jsSources = [], + hsSourceDirs = [], + otherModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraGHCiLibs = [], + extraLibDirs = [], + includeDirs = [], + includes = [], + installIncludes = [], + options = [], + profOptions = [], + sharedOptions = [], + customFieldsBI = [], + targetBuildDepends = [], targetBuildRenaming = Map.empty } - mappend a b = BuildInfo { - buildable = buildable a && buildable b, - buildTools = combine buildTools, - cppOptions = combine cppOptions, - ccOptions = combine ccOptions, - ldOptions = combine ldOptions, - pkgconfigDepends = combine pkgconfigDepends, - frameworks = combineNub frameworks, - cSources = combineNub cSources, - jsSources = combineNub jsSources, - hsSourceDirs = combineNub hsSourceDirs, - otherModules = combineNub otherModules, - defaultLanguage = combineMby defaultLanguage, - otherLanguages = combineNub otherLanguages, - defaultExtensions = combineNub defaultExtensions, - otherExtensions = combineNub otherExtensions, - oldExtensions = combineNub oldExtensions, - extraLibs = combine extraLibs, - extraGHCiLibs = combine extraGHCiLibs, - extraLibDirs = combineNub extraLibDirs, - includeDirs = combineNub includeDirs, - includes = combineNub includes, - installIncludes = combineNub installIncludes, - options = combine options, - profOptions = combine profOptions, - sharedOptions = combine sharedOptions, - customFieldsBI = combine customFieldsBI, - targetBuildDepends = combineNub targetBuildDepends, + mappend = (Semi.<>) + +instance Semigroup BuildInfo where + a <> b = BuildInfo { + buildable = buildable a && buildable b, + buildTools = combine buildTools, + cppOptions = combine cppOptions, + ccOptions = combine ccOptions, + ldOptions = combine ldOptions, + pkgconfigDepends = combine pkgconfigDepends, + frameworks = combineNub frameworks, + extraFrameworkDirs = combineNub extraFrameworkDirs, + cSources = combineNub cSources, + jsSources = combineNub jsSources, + hsSourceDirs = combineNub hsSourceDirs, + otherModules = combineNub otherModules, + defaultLanguage = combineMby defaultLanguage, + otherLanguages = combineNub otherLanguages, + defaultExtensions = combineNub defaultExtensions, + otherExtensions = combineNub otherExtensions, + oldExtensions = combineNub oldExtensions, + extraLibs = combine extraLibs, + extraGHCiLibs = combine extraGHCiLibs, + extraLibDirs = combineNub extraLibDirs, + includeDirs = combineNub includeDirs, + includes = combineNub includes, + installIncludes = combineNub installIncludes, + options = combine options, + profOptions = combine profOptions, + sharedOptions = combine sharedOptions, + customFieldsBI = combine customFieldsBI, + targetBuildDepends = combineNub targetBuildDepends, targetBuildRenaming = combineMap targetBuildRenaming } where @@ -1102,12 +1150,12 @@ condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)], condBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] } - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Typeable, Data, Generic) instance Package GenericPackageDescription where packageId = packageId . packageDescription ---TODO: make PackageDescription an instance of Text. +instance Binary GenericPackageDescription -- | A flag can represent a feature to be included, or a way of linking -- a target against its dependencies, or in fact whatever you can think of. @@ -1117,8 +1165,10 @@ , flagDefault :: Bool , flagManual :: Bool } - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Typeable, Data, Generic) +instance Binary Flag + -- | A 'FlagName' is the name of a user-defined configuration flag newtype FlagName = FlagName String deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) @@ -1137,16 +1187,96 @@ | Arch Arch | Flag FlagName | Impl CompilerFlavor VersionRange - deriving (Eq, Show, Typeable, Data) + deriving (Eq, Show, Typeable, Data, Generic) +instance Binary ConfVar + -- | A boolean expression parameterized over the variable type used. data Condition c = Var c | Lit Bool | CNot (Condition c) | COr (Condition c) (Condition c) | CAnd (Condition c) (Condition c) - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Typeable, Data, Generic) +-- | Boolean negation of a 'Condition' value. +cNot :: Condition a -> Condition a +cNot (Lit b) = Lit (not b) +cNot (CNot c) = c +cNot c = CNot c + +-- | Boolean AND of two 'Condtion' values. +cAnd :: Condition a -> Condition a -> Condition a +cAnd (Lit False) _ = Lit False +cAnd _ (Lit False) = Lit False +cAnd (Lit True) x = x +cAnd x (Lit True) = x +cAnd x y = CAnd x y + +-- | Boolean OR of two 'Condition' values. +cOr :: Eq v => Condition v -> Condition v -> Condition v +cOr (Lit True) _ = Lit True +cOr _ (Lit True) = Lit True +cOr (Lit False) x = x +cOr x (Lit False) = x +cOr c (CNot d) + | c == d = Lit True +cOr (CNot c) d + | c == d = Lit True +cOr x y = COr x y + +instance Functor Condition where + f `fmap` Var c = Var (f c) + _ `fmap` Lit c = Lit c + f `fmap` CNot c = CNot (fmap f c) + f `fmap` COr c d = COr (fmap f c) (fmap f d) + f `fmap` CAnd c d = CAnd (fmap f c) (fmap f d) + +instance Foldable Condition where + f `foldMap` Var c = f c + _ `foldMap` Lit _ = mempty + f `foldMap` CNot c = Fold.foldMap f c + f `foldMap` COr c d = foldMap f c `mappend` foldMap f d + f `foldMap` CAnd c d = foldMap f c `mappend` foldMap f d + +instance Traversable Condition where + f `traverse` Var c = Var `fmap` f c + _ `traverse` Lit c = pure $ Lit c + f `traverse` CNot c = CNot `fmap` Trav.traverse f c + f `traverse` COr c d = COr `fmap` traverse f c <*> traverse f d + f `traverse` CAnd c d = CAnd `fmap` traverse f c <*> traverse f d + +instance Applicative Condition where + pure = Var + (<*>) = ap + +instance Monad Condition where + return = AP.pure + -- Terminating cases + (>>=) (Lit x) _ = Lit x + (>>=) (Var x) f = f x + -- Recursing cases + (>>=) (CNot x ) f = CNot (x >>= f) + (>>=) (COr x y) f = COr (x >>= f) (y >>= f) + (>>=) (CAnd x y) f = CAnd (x >>= f) (y >>= f) + +instance Monoid (Condition a) where + mempty = Lit False + mappend = (Semi.<>) + +instance Semigroup (Condition a) where + (<>) = COr + +instance Alternative Condition where + empty = mempty + (<|>) = mappend + +instance MonadPlus Condition where + mzero = mempty + mplus = mappend + +instance Binary c => Binary (Condition c) + data CondTree v c a = CondNode { condTreeData :: a , condTreeConstraints :: c @@ -1154,4 +1284,6 @@ , CondTree v c a , Maybe (CondTree v c a))] } - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Typeable, Data, Generic) + +instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a) diff --git a/Distribution/PackageDescription/Check.hs b/Distribution/PackageDescription/Check.hs --- a/Distribution/PackageDescription/Check.hs +++ b/Distribution/PackageDescription/Check.hs @@ -33,53 +33,35 @@ checkPackageFileNames, ) where -import Data.Maybe - ( isNothing, isJust, catMaybes, maybeToList, fromMaybe ) -import Data.List (sort, group, isPrefixOf, nub, find) -import Control.Monad - ( filterM, liftM ) -import qualified System.Directory as System - ( doesFileExist, doesDirectoryExist ) -import qualified Data.Map as Map - import Distribution.PackageDescription import Distribution.PackageDescription.Configuration - ( flattenPackageDescription, finalizePackageDescription ) import Distribution.Compiler - ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..) - , unknownCompilerInfo, AbiTag(..) ) import Distribution.System - ( OS(..), Arch(..), buildPlatform ) import Distribution.License - ( License(..), knownLicenses ) import Distribution.Simple.CCompiler - ( filenameCDialect ) -import Distribution.Simple.Utils - ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase ) - +import Distribution.Simple.Utils hiding (findPackageDesc, notice) import Distribution.Version - ( Version(..) - , VersionRange(..), foldVersionRange' - , anyVersion, noVersion, thisVersion, laterVersion, earlierVersion - , orLaterVersion, orEarlierVersion - , unionVersionRanges, intersectVersionRanges - , asVersionIntervals, UpperBound(..), isNoVersion ) import Distribution.Package - ( PackageName(PackageName), packageName, packageVersion - , Dependency(..), pkgName ) - import Distribution.Text - ( display, disp ) +import Language.Haskell.Extension + +import Data.Maybe + ( isNothing, isJust, catMaybes, mapMaybe, maybeToList, fromMaybe ) +import Data.List (sort, group, isPrefixOf, nub, find) +import Control.Monad + ( filterM, liftM ) +import qualified System.Directory as System + ( doesFileExist, doesDirectoryExist ) +import qualified Data.Map as Map + import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>), (<+>)) -import qualified Language.Haskell.Extension as Extension (deprecatedExtensions) -import Language.Haskell.Extension - ( Language(UnknownLanguage), knownLanguages - , Extension(..), KnownExtension(..) ) +import qualified System.Directory (getDirectoryContents) +import System.IO (openBinaryFile, IOMode(ReadMode), hGetContents) import System.FilePath ( (), takeExtension, isRelative, isAbsolute - , splitDirectories, splitPath ) + , splitDirectories, splitPath, splitExtension ) import System.FilePath.Windows as FilePath.Windows ( isValid ) @@ -108,6 +90,10 @@ -- ban them entirely. | PackageDistSuspicious { explanation :: String } + -- | Like PackageDistSuspicious but will only display warnings + -- rather than causing abnormal exit when you run 'cabal check'. + | PackageDistSuspiciousWarn { explanation :: String } + -- | An issue that is OK in the author's environment but is almost -- certain to be a portability problem for other environments. We can -- quite legitimately refuse to publicly distribute packages with these @@ -128,7 +114,6 @@ | specVersion pkg >= Version specver [] = Nothing | otherwise = check cond pc - -- ------------------------------------------------------------ -- * Standard checks -- ------------------------------------------------------------ @@ -150,6 +135,7 @@ checkConfiguredPackage pkg ++ checkConditionals gpkg ++ checkPackageVersions gpkg + ++ checkDevelopmentOnlyFlags gpkg where pkg = fromMaybe (flattenPackageDescription gpkg) mpkg @@ -184,9 +170,12 @@ , check (null . versionBranch . packageVersion $ pkg) $ PackageBuildImpossible "No 'version' field." - , check (null (executables pkg) && isNothing (library pkg)) $ + , check (all ($ pkg) [ null . executables + , null . testSuites + , null . benchmarks + , isNothing . library ]) $ PackageBuildImpossible - "No executables and no library found. Nothing to do." + "No executables, libraries, tests, or benchmarks found. Nothing to do." , check (not (null duplicateNames)) $ PackageBuildImpossible $ "Duplicate sections: " ++ commaSep duplicateNames @@ -308,14 +297,6 @@ 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. - , check libNameClash $ - PackageBuildImpossible $ - "The test suite " ++ testName test - ++ " has the same name as the package." ] where moduleDuplicates = dups $ testModules test @@ -328,13 +309,8 @@ TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] _ -> False - libNameClash = testName test `elem` [ libName - | _lib <- maybeToList (library pkg) - , let PackageName libName = - pkgName (package pkg) ] - checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck] -checkBenchmark pkg bm = +checkBenchmark _pkg bm = catMaybes [ case benchmarkInterface bm of @@ -360,12 +336,6 @@ PackageBuildImpossible $ "The 'main-is' field must specify a '.hs' or '.lhs' file " ++ "(even if it is generated by a preprocessor)." - - -- See comment for similar check on test suites. - , check libNameClash $ - PackageBuildImpossible $ - "The benchmark " ++ benchmarkName bm - ++ " has the same name as the package." ] where moduleDuplicates = dups $ benchmarkModules bm @@ -374,11 +344,6 @@ BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] _ -> False - libNameClash = benchmarkName bm `elem` [ libName - | _lib <- maybeToList (library pkg) - , let PackageName libName = - pkgName (package pkg) ] - -- ------------------------------------------------------------ -- * Additional pure checks -- ------------------------------------------------------------ @@ -407,6 +372,12 @@ ++ commaSep (map display knownBuildTypes) _ -> Nothing + , check (isJust (setupBuildInfo pkg) && buildType pkg /= Just Custom) $ + PackageBuildWarning $ + "Ignoring the 'custom-setup' section because the 'build-type' is " + ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a " + ++ "custom Setup.hs script." + , check (not (null unknownCompilers)) $ PackageBuildWarning $ "Unknown compiler " ++ commaSep (map quote unknownCompilers) @@ -427,14 +398,14 @@ ++ ". Languages must be specified in either the 'default-language' " ++ " or the 'other-languages' field." - , check (not (null deprecatedExtensions)) $ + , check (not (null ourDeprecatedExtensions)) $ PackageDistSuspicious $ "Deprecated extensions: " - ++ commaSep (map (quote . display . fst) deprecatedExtensions) + ++ commaSep (map (quote . display . fst) ourDeprecatedExtensions) ++ ". " ++ unwords [ "Instead of '" ++ display ext ++ "' use '" ++ display replacement ++ "'." - | (ext, Just replacement) <- deprecatedExtensions ] + | (ext, Just replacement) <- ourDeprecatedExtensions ] , check (null (category pkg)) $ PackageDistSuspicious "No 'category' field." @@ -476,8 +447,8 @@ unknownExtensions = [ name | bi <- allBuildInfo pkg , UnknownExtension name <- allExtensions bi , name `notElem` map display knownLanguages ] - deprecatedExtensions = nub $ catMaybes - [ find ((==ext) . fst) Extension.deprecatedExtensions + ourDeprecatedExtensions = nub $ catMaybes + [ find ((==ext) . fst) deprecatedExtensions | bi <- allBuildInfo pkg , ext <- allExtensions bi ] languagesUsedAsExtensions = @@ -588,19 +559,7 @@ checkGhcOptions pkg = catMaybes [ - check has_WerrorWall $ - PackageDistSuspicious $ - "'ghc-options: -Wall -Werror' makes the package very easy to " - ++ "break with future GHC versions because new GHC versions often " - ++ "add new warnings. Use just 'ghc-options: -Wall' instead." - - , check (not has_WerrorWall && has_Werror) $ - PackageDistSuspicious $ - "'ghc-options: -Werror' makes the package easy to " - ++ "break with future GHC versions because new GHC versions often " - ++ "add new warnings." - - , checkFlags ["-fasm"] $ + checkFlags ["-fasm"] $ PackageDistInexcusable $ "'ghc-options: -fasm' is unnecessary and will not work on CPU " ++ "architectures other than x86, x86-64, ppc or sparc." @@ -612,27 +571,16 @@ ++ "is using the FFI incorrectly and will probably not work with GHC " ++ "6.10 or later." - , checkFlags ["-fdefer-type-errors"] $ - PackageDistInexcusable $ - "'ghc-options: -fdefer-type-errors' is fine during development but " - ++ "is not appropriate for a distributed package." - , checkFlags ["-fhpc"] $ PackageDistInexcusable $ - "'ghc-options: -fhpc' is not appropriate for a distributed package." - - -- -dynamic is not a debug flag - , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic") - all_ghc_options) $ - PackageDistInexcusable $ - "'ghc-options: -d*' debug flags are not appropriate " - ++ "for a distributed package." + "'ghc-options: -fhpc' is not not necessary. Use the configure flag " + ++ " --enable-coverage instead." , checkFlags ["-prof"] $ PackageBuildWarning $ "'ghc-options: -prof' is not necessary and will lead to problems " ++ "when used on a library. Use the configure flag " - ++ "--enable-library-profiling and/or --enable-executable-profiling." + ++ "--enable-library-profiling and/or --enable-profiling." , checkFlags ["-o"] $ PackageBuildWarning $ @@ -664,7 +612,7 @@ ++ "Setting it yourself interferes with the --disable-optimization flag." , checkFlags ["-O2"] $ - PackageDistSuspicious $ + PackageDistSuspiciousWarn $ "'ghc-options: -O2' is rarely needed. " ++ "Check that it is giving a real benefit " ++ "and not just imposing longer compile times on your users." @@ -687,21 +635,21 @@ "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use " ++ "the 'extensions' field." - , checkProfFlags ["-auto-all"] $ - PackageDistSuspicious $ - "'ghc-prof-options: -auto-all' is fine during development, but " - ++ "not recommended in a distributed package. " - - , checkProfFlags ["-fprof-auto"] $ - PackageDistSuspicious $ - "'ghc-prof-options: -fprof-auto' is fine during development, but " - ++ "not recommended in a distributed package. " - , check ("-threaded" `elem` lib_ghc_options) $ - PackageDistSuspicious $ + PackageBuildWarning $ "'ghc-options: -threaded' has no effect for libraries. It should " ++ "only be used for executables." + , check ("-rtsopts" `elem` lib_ghc_options) $ + PackageBuildWarning $ + "'ghc-options: -rtsopts' has no effect for libraries. It should " + ++ "only be used for executables." + + , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $ + PackageBuildWarning $ + "'ghc-options: -with-rtsopts' has no effect for libraries. It " + ++ "should only be used for executables." + , checkAlternatives "ghc-options" "extensions" [ (flag, display extension) | flag <- all_ghc_options , Just extension <- [ghcExtension flag] ] @@ -721,26 +669,24 @@ , checkAlternatives "ghc-options" "extra-lib-dirs" [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ] - ] - where - has_WerrorWall = flip any ghc_options $ \opts -> - "-Werror" `elem` opts - && ("-Wall" `elem` opts || "-W" `elem` opts) - has_Werror = any (\opts -> "-Werror" `elem` opts) ghc_options + , checkAlternatives "ghc-options" "frameworks" + [ (flag, fmwk) | (flag@"-framework", fmwk) <- + zip all_ghc_options (safeTail all_ghc_options) ] - (ghc_options, ghc_prof_options) = - unzip . map (\bi -> (hcOptions GHC bi, hcProfOptions GHC bi)) - $ (allBuildInfo pkg) - all_ghc_options = concat ghc_options - all_ghc_prof_options = concat ghc_prof_options - lib_ghc_options = maybe [] (hcOptions GHC . libBuildInfo) (library pkg) + , checkAlternatives "ghc-options" "extra-framework-dirs" + [ (flag, dir) | (flag@"-framework-path", dir) <- + zip all_ghc_options (safeTail all_ghc_options) ] + ] - checkFlags,checkProfFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkFlags flags = doCheckFlags flags all_ghc_options - checkProfFlags flags = doCheckFlags flags all_ghc_prof_options + where + all_ghc_options = concatMap get_ghc_options (allBuildInfo pkg) + lib_ghc_options = maybe [] (get_ghc_options . libBuildInfo) (library pkg) + get_ghc_options bi = hcOptions GHC bi ++ hcProfOptions GHC bi + ++ hcSharedOptions GHC bi - doCheckFlags flags opts = check (any (`elem` flags) opts) + checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck + checkFlags flags = check (any (`elem` flags) all_ghc_options) ghcExtension ('-':'f':name) = case name of "allow-overlapping-instances" -> enable OverlappingInstances @@ -843,7 +789,7 @@ , isOutsideTree path ] ++ [ PackageDistInexcusable $ - quote (kind ++ ": " ++ path) ++ " is an absolute directory." + quote (kind ++ ": " ++ path) ++ " is an absolute path." | (path, kind) <- relPaths , isAbsolute path ] ++ @@ -882,6 +828,7 @@ ++ [ (path, "extra-doc-files") | path <- extraDocFiles pkg ] ++ [ (path, "data-files") | path <- dataFiles pkg ] ++ [ (path, "data-dir") | path <- [dataDir pkg]] + ++ [ (path, "license-file") | path <- licenseFiles pkg ] ++ concat [ [ (path, "c-sources") | path <- cSources bi ] ++ [ (path, "js-sources") | path <- jsSources bi ] @@ -973,6 +920,13 @@ ++ ". To use this new syntax, the package needs to specify at least" ++ "'cabal-version: >= 1.21'." + -- check use of 'extra-framework-dirs' field + , checkVersion [1,23] (any (not . null) (buildInfoField extraFrameworkDirs)) $ + -- Just a warning, because this won't break on old Cabal versions. + PackageDistSuspiciousWarn $ + "To use the 'extra-framework-dirs' field the package needs to specify" + ++ " at least 'cabal-version: >= 1.23'." + -- check use of default-extensions field -- don't need to do the equivalent check for other-extensions , checkVersion [1,10] (any (not . null) (buildInfoField defaultExtensions)) $ @@ -1084,6 +1038,27 @@ ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " ++ "compatibility with earlier Cabal versions then you may be able to " ++ "use an equivalent compiler-specific flag." + + , check (specVersion pkg >= Version [1,23] [] + && isNothing (setupBuildInfo pkg) + && buildType pkg == Just Custom) $ + PackageBuildWarning $ + "Packages using 'cabal-version: >= 1.23' with 'build-type: Custom' " + ++ "must use a 'custom-setup' section with a 'setup-depends' field " + ++ "that specifies the dependencies of the Setup.hs script itself. " + ++ "The 'setup-depends' field uses the same syntax as 'build-depends', " + ++ "so a simple example would be 'setup-depends: base, Cabal'." + + , check (specVersion pkg < Version [1,23] [] + && isNothing (setupBuildInfo pkg) + && buildType pkg == Just Custom) $ + PackageDistSuspiciousWarn $ + "From version 1.23 cabal supports specifiying explicit dependencies " + ++ "for Custom setup scripts. Consider using cabal-version >= 1.23 and " + ++ "adding a 'custom-setup' section with a 'setup-depends' field " + ++ "that specifies the dependencies of the Setup.hs script itself. " + ++ "The 'setup-depends' field uses the same syntax as 'build-depends', " + ++ "so a simple example would be 'setup-depends: base, Cabal'." ] where -- Perform a check on packages that use a version of the spec less than @@ -1143,14 +1118,13 @@ depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg , usesWildcardSyntax vr ] - -- XXX: If the user writes build-depends: foo with (), this is + -- TODO: If the user writes build-depends: foo with (), this is -- indistinguishable from build-depends: foo, so there won't be an -- error even though there should be depsUsingThinningRenamingSyntax = [ name | bi <- allBuildInfo pkg - , (name, rns) <- Map.toList (targetBuildRenaming bi) - , rns /= ModuleRenaming True [] ] + , (name, _) <- Map.toList (targetBuildRenaming bi) ] testedWithUsingWildcardSyntax = [ Dependency (PackageName (display compiler)) vr @@ -1279,7 +1253,7 @@ ++ "new major version of the 'base' package is released. If you are " ++ "not sure what upper bound to use then use the next major " ++ "version. For example if you have tested your package with 'base' " - ++ "version 2 and 3 then use 'build-depends: base >= 2 && < 4'." + ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'." ] where @@ -1338,10 +1312,10 @@ unknownOSs = [ os | OS (OtherOS os) <- conditions ] unknownArches = [ arch | Arch (OtherArch arch) <- conditions ] unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ] - conditions = maybe [] freeVars (condLibrary pkg) - ++ concatMap (freeVars . snd) (condExecutables pkg) - freeVars (CondNode _ _ ifs) = concatMap compfv ifs - compfv (c, ct, mct) = condfv c ++ freeVars ct ++ maybe [] freeVars mct + conditions = maybe [] fvs (condLibrary pkg) + ++ concatMap (fvs . snd) (condExecutables pkg) + fvs (CondNode _ _ ifs) = concatMap compfv ifs -- free variables + compfv (c, ct, mct) = condfv c ++ fvs ct ++ maybe [] fvs mct condfv c = case c of Var v -> [v] Lit _ -> [] @@ -1349,6 +1323,131 @@ COr c1 c2 -> condfv c1 ++ condfv c2 CAnd c1 c2 -> condfv c1 ++ condfv c2 +checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck] +checkDevelopmentOnlyFlagsBuildInfo bi = + catMaybes [ + + check has_WerrorWall $ + PackageDistInexcusable $ + "'ghc-options: -Wall -Werror' makes the package very easy to " + ++ "break with future GHC versions because new GHC versions often " + ++ "add new warnings. Use just 'ghc-options: -Wall' instead." + ++ extraExplanation + + , check (not has_WerrorWall && has_Werror) $ + PackageDistInexcusable $ + "'ghc-options: -Werror' makes the package easy to " + ++ "break with future GHC versions because new GHC versions often " + ++ "add new warnings. " + ++ extraExplanation + + , checkFlags ["-fdefer-type-errors"] $ + PackageDistInexcusable $ + "'ghc-options: -fdefer-type-errors' is fine during development but " + ++ "is not appropriate for a distributed package. " + ++ extraExplanation + + -- -dynamic is not a debug flag + , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic") + ghc_options) $ + PackageDistInexcusable $ + "'ghc-options: -d*' debug flags are not appropriate " + ++ "for a distributed package. " + ++ extraExplanation + + , checkFlags ["-fprof-auto", "-fprof-auto-top", "-fprof-auto-calls", + "-fprof-cafs", "-fno-prof-count-entries", + "-auto-all", "-auto", "-caf-all"] $ + PackageDistSuspicious $ + "'ghc-options: -fprof*' profiling flags are typically not " + ++ "appropriate for a distributed library package. These flags are " + ++ "useful to profile this package, but when profiling other packages " + ++ "that use this one these flags clutter the profile output with " + ++ "excessive detail. If you think other packages really want to see " + ++ "cost centres from this package then use '-fprof-auto-exported' " + ++ "which puts cost centres only on exported functions. " + ++ extraExplanation + ] + where + extraExplanation = + " Alternatively, if you want to use this, make it conditional based " + ++ "on a Cabal configuration flag (with 'manual: True' and 'default: " + ++ "False') and enable that flag during development." + + has_WerrorWall = has_Werror && ( has_Wall || has_W ) + has_Werror = "-Werror" `elem` ghc_options + has_Wall = "-Wall" `elem` ghc_options + has_W = "-W" `elem` ghc_options + ghc_options = hcOptions GHC bi ++ hcProfOptions GHC bi + ++ hcSharedOptions GHC bi + + checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck + checkFlags flags = check (any (`elem` flags) ghc_options) + +checkDevelopmentOnlyFlags :: GenericPackageDescription -> [PackageCheck] +checkDevelopmentOnlyFlags pkg = + concatMap checkDevelopmentOnlyFlagsBuildInfo + [ bi + | (conditions, bi) <- allConditionalBuildInfo + , not (any guardedByManualFlag conditions) ] + where + guardedByManualFlag = definitelyFalse + + -- We've basically got three-values logic here: True, False or unknown + -- hence this pattern to propagate the unknown cases properly. + definitelyFalse (Var (Flag n)) = maybe False not (Map.lookup n manualFlags) + definitelyFalse (Var _) = False + definitelyFalse (Lit b) = not b + definitelyFalse (CNot c) = definitelyTrue c + definitelyFalse (COr c1 c2) = definitelyFalse c1 && definitelyFalse c2 + definitelyFalse (CAnd c1 c2) = definitelyFalse c1 || definitelyFalse c2 + + definitelyTrue (Var (Flag n)) = fromMaybe False (Map.lookup n manualFlags) + definitelyTrue (Var _) = False + definitelyTrue (Lit b) = b + definitelyTrue (CNot c) = definitelyFalse c + definitelyTrue (COr c1 c2) = definitelyTrue c1 || definitelyTrue c2 + definitelyTrue (CAnd c1 c2) = definitelyTrue c1 && definitelyTrue c2 + + manualFlags = Map.fromList + [ (flagName flag, flagDefault flag) + | flag <- genPackageFlags pkg + , flagManual flag ] + + allConditionalBuildInfo :: [([Condition ConfVar], BuildInfo)] + allConditionalBuildInfo = + concatMap (collectCondTreePaths libBuildInfo) + (maybeToList (condLibrary pkg)) + + ++ concatMap (collectCondTreePaths buildInfo . snd) + (condExecutables pkg) + + ++ concatMap (collectCondTreePaths testBuildInfo . snd) + (condTestSuites pkg) + + ++ concatMap (collectCondTreePaths benchmarkBuildInfo . snd) + (condBenchmarks pkg) + + -- get all the leaf BuildInfo, paired up with the path (in the tree sense) + -- of if-conditions that guard it + collectCondTreePaths :: (a -> b) + -> CondTree v c a + -> [([Condition v], b)] + collectCondTreePaths mapData = go [] + where + go conditions condNode = + -- the data at this level in the tree: + (reverse conditions, mapData (condTreeData condNode)) + + : concat + [ go (condition:conditions) ifThen + | (condition, ifThen, _) <- condTreeComponents condNode ] + + ++ concat + [ go (condition:conditions) elseThen + | (condition, _, Just elseThen) <- condTreeComponents condNode ] + + -- ------------------------------------------------------------ -- * Checks involving files in the package -- ------------------------------------------------------------ @@ -1360,8 +1459,10 @@ checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg where checkFilesIO = CheckPackageContentOps { - doesFileExist = System.doesFileExist . relative, - doesDirectoryExist = System.doesDirectoryExist . relative + doesFileExist = System.doesFileExist . relative, + doesDirectoryExist = System.doesDirectoryExist . relative, + getDirectoryContents = System.Directory.getDirectoryContents . relative, + getFileContents = \f -> openBinaryFile (relative f) ReadMode >>= hGetContents } relative path = root path @@ -1369,8 +1470,10 @@ -- Used by 'checkPackageContent'. -- data CheckPackageContentOps m = CheckPackageContentOps { - doesFileExist :: FilePath -> m Bool, - doesDirectoryExist :: FilePath -> m Bool + doesFileExist :: FilePath -> m Bool, + doesDirectoryExist :: FilePath -> m Bool, + getDirectoryContents :: FilePath -> m [FilePath], + getFileContents :: FilePath -> m String } -- | Sanity check things that requires looking at files in the package. @@ -1384,6 +1487,7 @@ -> PackageDescription -> m [PackageCheck] checkPackageContent ops pkg = do + cabalBomError <- checkCabalFileBOM ops licenseErrors <- checkLicensesExist ops pkg setupError <- checkSetupExists ops pkg configureError <- checkConfigureExists ops pkg @@ -1391,10 +1495,50 @@ vcsLocation <- checkMissingVcsInfo ops pkg return $ licenseErrors - ++ catMaybes [setupError, configureError] + ++ catMaybes [cabalBomError, setupError, configureError] ++ localPathErrors ++ vcsLocation +checkCabalFileBOM :: Monad m => CheckPackageContentOps m + -> m (Maybe PackageCheck) +checkCabalFileBOM ops = do + epdfile <- findPackageDesc ops + case epdfile of + Left pc -> return $ Just pc + Right pdfile -> (flip check pc . startsWithBOM . fromUTF8) `liftM` (getFileContents ops pdfile) + where pc = PackageDistInexcusable $ + pdfile ++ " starts with an Unicode byte order mark (BOM). This may cause problems with older cabal versions." + +-- |Find a package description file in the given directory. Looks for +-- @.cabal@ files. Like 'Distribution.Simple.Utils.findPackageDesc', +-- but generalized over monads. +findPackageDesc :: Monad m => CheckPackageContentOps m + -> m (Either PackageCheck FilePath) -- ^.cabal +findPackageDesc ops + = do let dir = "." + files <- getDirectoryContents ops dir + -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal + -- file we filter to exclude dirs and null base file names: + cabalFiles <- filterM (doesFileExist ops) + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == ".cabal" ] + case cabalFiles of + [] -> return (Left $ PackageBuildImpossible noDesc) + [cabalFile] -> return (Right cabalFile) + multiple -> return (Left $ PackageBuildImpossible $ multiDesc multiple) + + where + noDesc :: String + noDesc = "No cabal file found.\n" + ++ "Please create a package description file .cabal" + + multiDesc :: [String] -> String + multiDesc l = "Multiple cabal files found.\n" + ++ "Please use only one of: " + ++ intercalate ", " l + checkLicensesExist :: Monad m => CheckPackageContentOps m -> PackageDescription -> m [PackageCheck] @@ -1412,10 +1556,11 @@ checkSetupExists :: Monad m => CheckPackageContentOps m -> PackageDescription -> m (Maybe PackageCheck) -checkSetupExists ops _ = do +checkSetupExists ops pkg = do + let simpleBuild = buildType pkg == Just Simple hsexists <- doesFileExist ops "Setup.hs" lhsexists <- doesFileExist ops "Setup.lhs" - return $ check (not hsexists && not lhsexists) $ + return $ check (not simpleBuild && not hsexists && not lhsexists) $ PackageDistInexcusable $ "The package is missing a Setup.hs or Setup.lhs script." @@ -1438,6 +1583,8 @@ | bi <- allBuildInfo pkg , (dir, kind) <- [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ] + ++ [ (dir, "extra-framework-dirs") + | dir <- extraFrameworkDirs bi ] ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ] , isRelative dir ] @@ -1486,8 +1633,8 @@ -- checkPackageFileNames :: [FilePath] -> [PackageCheck] checkPackageFileNames files = - (take 1 . catMaybes . map checkWindowsPath $ files) - ++ (take 1 . catMaybes . map checkTarPath $ files) + (take 1 . mapMaybe checkWindowsPath $ files) + ++ (take 1 . mapMaybe checkTarPath $ files) -- If we get any of these checks triggering then we're likely to get -- many, and that's probably not helpful, so return at most one. diff --git a/Distribution/PackageDescription/Configuration.hs b/Distribution/PackageDescription/Configuration.hs --- a/Distribution/PackageDescription/Configuration.hs +++ b/Distribution/PackageDescription/Configuration.hs @@ -23,46 +23,38 @@ -- Utils parseCondition, freeVars, + extractCondition, + extractConditions, + addBuildableCondition, mapCondTree, mapTreeData, mapTreeConds, mapTreeConstrs, + transformAllBuildInfos, + transformAllBuildDepends, ) where +import Control.Applicative -- 7.10 -Werror workaround. +import Prelude + import Distribution.Package - ( PackageName, Dependency(..) ) import Distribution.PackageDescription - ( GenericPackageDescription(..), PackageDescription(..) - , Library(..), Executable(..), BuildInfo(..) - , Flag(..), FlagName(..), FlagAssignment - , Benchmark(..), CondTree(..), ConfVar(..), Condition(..) - , TestSuite(..) ) import Distribution.PackageDescription.Utils - ( cabalBug, userBug ) import Distribution.Version - ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) import Distribution.Compiler - ( CompilerId(CompilerId) ) import Distribution.System - ( Platform(..), OS, Arch ) import Distribution.Simple.Utils - ( currentDir, lowercase ) -import Distribution.Simple.Compiler - ( CompilerInfo(..) ) - import Distribution.Text - ( Text(parse) ) import Distribution.Compat.ReadP as ReadP hiding ( char ) -import Control.Arrow (first) import qualified Distribution.Compat.ReadP as ReadP ( char ) +import Distribution.Compat.Semigroup as Semi +import Control.Arrow (first) import Data.Char ( isAlphaNum ) -import Data.Maybe ( catMaybes, maybeToList ) +import Data.Maybe ( mapMaybe, maybeToList ) import Data.Map ( Map, fromListWith, toList ) import qualified Data.Map as Map -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif +import Data.Tree ( Tree(Node) ) ------------------------------------------------------------------------------ @@ -185,14 +177,14 @@ -- clarity. data DepTestRslt d = DepOk | MissingDeps d -instance Monoid d => Monoid (DepTestRslt d) where +instance Semigroup d => Monoid (DepTestRslt d) where mempty = DepOk - mappend DepOk x = x - mappend x DepOk = x - mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d') - + mappend = (Semi.<>) -data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree +instance Semigroup d => Semigroup (DepTestRslt d) where + DepOk <> x = x + x <> DepOk = x + (MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d') -- | Try to find a flag assignment that satisfies the constraints of all trees. @@ -201,8 +193,9 @@ -- resulting data, the associated dependencies, and the chosen flag -- assignments. -- --- In case of failure, the _smallest_ number of of missing dependencies is --- returned. [TODO: Could also be specified with a function argument.] +-- In case of failure, the union of the dependencies that led to backtracking +-- on all branches is returned. +-- [TODO: Could also be specified with a function argument.] -- -- TODO: The current algorithm is rather naive. A better approach would be to: -- @@ -228,65 +221,138 @@ -- ^ Either the missing dependencies (error case), or a pair of -- (set of build targets with dependencies, chosen flag assignments) resolveWithFlags dom os arch impl constrs trees checkDeps = - case try dom [] of - Right r -> Right r - Left dbt -> Left $ findShortest dbt + either (Left . fromDepMapUnion) Right $ explore (build [] dom) where extraConstrs = toDepMap constrs -- simplify trees by (partially) evaluating all conditions and converting -- dependencies to dependency maps. + simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged] simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps + . addBuildableCondition pdTaggedBuildInfo . mapTreeConds (fst . simplifyWithSysParams os arch impl)) trees - -- @try@ recursively tries all possible flag assignments in the domain and - -- either succeeds or returns a binary tree with the missing dependencies - -- encountered in each run. Since the tree is constructed lazily, we - -- avoid some computation overhead in the successful case. - try [] flags = + -- @explore@ searches a tree of assignments, backtracking whenever a flag + -- introduces a dependency that cannot be satisfied. If there is no + -- solution, @explore@ returns the union of all dependencies that caused + -- it to backtrack. Since the tree is constructed lazily, we avoid some + -- computation overhead in the successful case. + explore :: Tree FlagAssignment + -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment) + explore (Node flags ts) = let targetSet = TargetSet $ flip map simplifiedTrees $ -- apply additional constraints to all dependencies first (`constrainBy` extraConstrs) . simplifyCondTree (env flags) deps = overallDependencies targetSet in case checkDeps (fromDepMap deps) of - DepOk -> Right (targetSet, flags) - MissingDeps mds -> Left (BTN mds) + DepOk | null ts -> Right (targetSet, flags) + | otherwise -> tryAll $ map explore ts + MissingDeps mds -> Left (toDepMapUnion mds) - try ((n, vals):rest) flags = - tryAll $ map (\v -> try rest ((n, v):flags)) vals + -- Builds a tree of all possible flag assignments. Internal nodes + -- have only partial assignments. + build :: FlagAssignment -> [(FlagName, [Bool])] -> Tree FlagAssignment + build assigned [] = Node assigned [] + build assigned ((fn, vals) : unassigned) = + Node assigned $ map (\v -> build ((fn, v) : assigned) unassigned) vals + tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a tryAll = foldr mp mz -- special version of `mplus' for our local purposes - mp (Left xs) (Left ys) = (Left (BTB xs ys)) - mp (Left _) m@(Right _) = m + mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a mp m@(Right _) _ = m + mp _ m@(Right _) = m + mp (Left xs) (Left ys) = + let union = Map.foldrWithKey (Map.insertWith' combine) + (unDepMapUnion xs) (unDepMapUnion ys) + combine x y = simplifyVersionRange $ unionVersionRanges x y + in union `seq` Left (DepMapUnion union) -- `mzero' - mz = Left (BTN []) + mz :: Either DepMapUnion a + mz = Left (DepMapUnion Map.empty) + env :: FlagAssignment -> FlagName -> Either FlagName Bool env flags flag = (maybe (Left flag) Right . lookup flag) flags - -- for the error case we inspect our lazy tree of missing dependencies and - -- pick the shortest list of missing dependencies - findShortest (BTN x) = x - findShortest (BTB lt rt) = - let l = findShortest lt - r = findShortest rt - in case (l,r) of - ([], xs) -> xs -- [] is too short - (xs, []) -> xs - ([x], _) -> [x] -- single elem is optimum - (_, [x]) -> [x] - (xs, ys) -> if lazyLengthCmp xs ys - then xs else ys - -- lazy variant of @\xs ys -> length xs <= length ys@ - lazyLengthCmp [] _ = True - lazyLengthCmp _ [] = False - lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys + pdTaggedBuildInfo :: PDTagged -> BuildInfo + pdTaggedBuildInfo (Lib l) = libBuildInfo l + pdTaggedBuildInfo (Exe _ e) = buildInfo e + pdTaggedBuildInfo (Test _ t) = testBuildInfo t + pdTaggedBuildInfo (Bench _ b) = benchmarkBuildInfo b + pdTaggedBuildInfo PDNull = mempty +-- | Transforms a 'CondTree' by putting the input under the "then" branch of a +-- conditional that is True when Buildable is True. If 'addBuildableCondition' +-- can determine that Buildable is always True, it returns the input unchanged. +-- If Buildable is always False, it returns the empty 'CondTree'. +addBuildableCondition :: (Eq v, Monoid a, Monoid c) => (a -> BuildInfo) + -> CondTree v c a + -> CondTree v c a +addBuildableCondition getInfo t = + case extractCondition (buildable . getInfo) t of + Lit True -> t + Lit False -> CondNode mempty mempty [] + c -> CondNode mempty mempty [(c, t, Nothing)] + +-- Note: extracting buildable conditions. +-- -------------------------------------- +-- +-- If the conditions in a cond tree lead to Buildable being set to False, then +-- none of the dependencies for this cond tree should actually be taken into +-- account. On the other hand, some of the flags may only be decided in the +-- solver, so we cannot necessarily make the decision whether a component is +-- Buildable or not prior to solving. +-- +-- What we are doing here is to partially evaluate a condition tree in order to +-- extract the condition under which Buildable is True. The predicate determines +-- whether data under a 'CondTree' is buildable. + + +-- | Extract the condition matched by the given predicate from a cond tree. +-- +-- We use this mainly for extracting buildable conditions (see the Note above), +-- but the function is in fact more general. +extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v +extractCondition p = go + where + go (CondNode x _ cs) | not (p x) = Lit False + | otherwise = goList cs + + goList [] = Lit True + goList ((c, t, e) : cs) = + let + ct = go t + ce = maybe (Lit True) go e + in + ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs + +-- | Extract conditions matched by the given predicate from all cond trees in a +-- 'GenericPackageDescription'. +extractConditions :: (BuildInfo -> Bool) -> GenericPackageDescription + -> [Condition ConfVar] +extractConditions f gpkg = + concat [ + maybeToList $ extractCondition (f . libBuildInfo) <$> condLibrary gpkg + , extractCondition (f . buildInfo) . snd <$> condExecutables gpkg + , extractCondition (f . testBuildInfo) . snd <$> condTestSuites gpkg + , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg + ] + + +-- | A map of dependencies that combines version ranges using 'unionVersionRanges'. +newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName VersionRange } + +toDepMapUnion :: [Dependency] -> DepMapUnion +toDepMapUnion ds = + DepMapUnion $ fromListWith unionVersionRanges [ (p,vr) | Dependency p vr <- ds ] + +fromDepMapUnion :: DepMapUnion -> [Dependency] +fromDepMapUnion m = [ Dependency p vr | (p,vr) <- toList (unDepMapUnion m) ] + -- | 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 } @@ -294,7 +360,10 @@ instance Monoid DependencyMap where mempty = DependencyMap Map.empty - (DependencyMap a) `mappend` (DependencyMap b) = + mappend = (Semi.<>) + +instance Semigroup DependencyMap where + (DependencyMap a) <> (DependencyMap b) = DependencyMap (Map.unionWith intersectVersionRanges a b) toDepMap :: [Dependency] -> DependencyMap @@ -304,18 +373,20 @@ fromDepMap :: DependencyMap -> [Dependency] fromDepMap m = [ Dependency p vr | (p,vr) <- toList (unDependencyMap m) ] +-- | Flattens a CondTree using a partial flag assignment. When a condition +-- cannot be evaluated, both branches are ignored. simplifyCondTree :: (Monoid a, Monoid d) => (v -> Either v Bool) -> CondTree v d a -> (d, a) simplifyCondTree env (CondNode a d ifs) = - mconcat $ (d, a) : catMaybes (map simplifyIf ifs) + mconcat $ (d, a) : mapMaybe simplifyIf ifs where simplifyIf (cnd, t, me) = case simplifyCondition cnd env of (Lit True, _) -> Just $ simplifyCondTree env t (Lit False, _) -> fmap (simplifyCondTree env) me - _ -> error $ "Environment not defined for all free vars" + _ -> Nothing -- | Flatten a CondTree. This will resolve the CondTree by taking all -- possible paths into account. Note that since branches represent exclusive @@ -350,11 +421,11 @@ where (depss, _) = unzip $ filter (removeDisabledSections . snd) targets removeDisabledSections :: PDTagged -> Bool - removeDisabledSections (Lib _) = True - removeDisabledSections (Exe _ _) = True - removeDisabledSections (Test _ t) = testEnabled t - removeDisabledSections (Bench _ b) = benchmarkEnabled b - removeDisabledSections PDNull = True + removeDisabledSections (Lib l) = buildable (libBuildInfo l) + removeDisabledSections (Exe _ e) = buildable (buildInfo e) + removeDisabledSections (Test _ t) = testEnabled t && buildable (testBuildInfo t) + removeDisabledSections (Bench _ b) = benchmarkEnabled b && buildable (benchmarkBuildInfo b) + removeDisabledSections PDNull = True -- Apply extra constraints to a dependency map. -- Combines dependencies where the result will only contain keys from the left @@ -440,14 +511,17 @@ instance Monoid PDTagged where mempty = PDNull - PDNull `mappend` x = x - x `mappend` PDNull = x - Lib l `mappend` Lib l' = Lib (l `mappend` l') - Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e') - Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t') - Bench n b `mappend` Bench n' b' | n == n' = Bench n (b `mappend` b') - _ `mappend` _ = cabalBug "Cannot combine incompatible tags" + mappend = (Semi.<>) +instance Semigroup PDTagged where + PDNull <> x = x + x <> PDNull = x + Lib l <> Lib l' = Lib (l <> l') + Exe n e <> Exe n' e' | n == n' = Exe n (e <> e') + Test n t <> Test n' t' | n == n' = Test n (t <> t') + Bench n b <> Bench n' b' | n == n' = Bench n (b <> b') + _ <> _ = cabalBug "Cannot combine incompatible tags" + -- | Create a package description with all configurations resolved. -- -- This function takes a `GenericPackageDescription` and several environment @@ -465,9 +539,10 @@ -- -- This function will fail if it cannot find a flag assignment that leads to -- satisfiable dependencies. (It will not try alternative assignments for --- explicitly specified flags.) In case of failure it will return a /minimum/ --- number of dependencies that could not be satisfied. On success, it will --- return the package description and the full flag assignment chosen. +-- explicitly specified flags.) In case of failure it will return the missing +-- dependencies that it encountered when trying different flag assignments. +-- On success, it will return the package description and the full flag +-- assignment chosen. -- finalizePackageDescription :: FlagAssignment -- ^ Explicitly specified flag assignments @@ -492,10 +567,6 @@ , testSuites = tests' , benchmarks = bms' , buildDepends = fromDepMap (overallDependencies targetSet) - --TODO: we need to find a way to avoid pulling in deps - -- for non-buildable components. However cannot simply - -- filter at this stage, since if the package were not - -- available we would have failed already. } , flagVals ) @@ -607,3 +678,82 @@ if null (hsSourceDirs bi) then bi { hsSourceDirs = [currentDir] } else bi + +-- Walk a 'GenericPackageDescription' and apply @onBuildInfo@/@onSetupBuildInfo@ +-- to all nested 'BuildInfo'/'SetupBuildInfo' values. +transformAllBuildInfos :: (BuildInfo -> BuildInfo) + -> (SetupBuildInfo -> SetupBuildInfo) + -> GenericPackageDescription + -> GenericPackageDescription +transformAllBuildInfos onBuildInfo onSetupBuildInfo gpd = gpd' + where + onLibrary lib = lib { libBuildInfo = onBuildInfo $ libBuildInfo lib } + onExecutable exe = exe { buildInfo = onBuildInfo $ buildInfo exe } + onTestSuite tst = tst { testBuildInfo = onBuildInfo $ testBuildInfo tst } + onBenchmark bmk = bmk { benchmarkBuildInfo = + onBuildInfo $ benchmarkBuildInfo bmk } + + pd = packageDescription gpd + pd' = pd { + library = fmap onLibrary (library pd), + executables = map onExecutable (executables pd), + testSuites = map onTestSuite (testSuites pd), + benchmarks = map onBenchmark (benchmarks pd), + setupBuildInfo = fmap onSetupBuildInfo (setupBuildInfo pd) + } + + gpd' = transformAllCondTrees onLibrary onExecutable + onTestSuite onBenchmark id + $ gpd { packageDescription = pd' } + +-- | Walk a 'GenericPackageDescription' and apply @f@ to all nested +-- @build-depends@ fields. +transformAllBuildDepends :: (Dependency -> Dependency) + -> GenericPackageDescription + -> GenericPackageDescription +transformAllBuildDepends f gpd = gpd' + where + onBI bi = bi { targetBuildDepends = map f $ targetBuildDepends bi } + onSBI stp = stp { setupDepends = map f $ setupDepends stp } + onPD pd = pd { buildDepends = map f $ buildDepends pd } + + pd' = onPD $ packageDescription gpd + gpd' = transformAllCondTrees id id id id (map f) + . transformAllBuildInfos onBI onSBI + $ gpd { packageDescription = pd' } + +-- | Walk all 'CondTree's inside a 'GenericPackageDescription' and apply +-- appropriate transformations to all nodes. Helper function used by +-- 'transformAllBuildDepends' and 'transformAllBuildInfos'. +transformAllCondTrees :: (Library -> Library) + -> (Executable -> Executable) + -> (TestSuite -> TestSuite) + -> (Benchmark -> Benchmark) + -> ([Dependency] -> [Dependency]) + -> GenericPackageDescription -> GenericPackageDescription +transformAllCondTrees onLibrary onExecutable + onTestSuite onBenchmark onDepends gpd = gpd' + where + gpd' = gpd { + condLibrary = condLib', + condExecutables = condExes', + condTestSuites = condTests', + condBenchmarks = condBenchs' + } + + condLib = condLibrary gpd + condExes = condExecutables gpd + condTests = condTestSuites gpd + condBenchs = condBenchmarks gpd + + condLib' = fmap (onCondTree onLibrary) condLib + condExes' = map (mapSnd $ onCondTree onExecutable) condExes + condTests' = map (mapSnd $ onCondTree onTestSuite) condTests + condBenchs' = map (mapSnd $ onCondTree onBenchmark) condBenchs + + mapSnd :: (a -> b) -> (c,a) -> (c,b) + mapSnd = fmap + + onCondTree :: (a -> b) -> CondTree v [Dependency] a + -> CondTree v [Dependency] b + onCondTree g = mapCondTree g onDepends id diff --git a/Distribution/PackageDescription/Parse.hs b/Distribution/PackageDescription/Parse.hs --- a/Distribution/PackageDescription/Parse.hs +++ b/Distribution/PackageDescription/Parse.hs @@ -41,49 +41,35 @@ flagFieldDescrs ) where -import Data.Char (isSpace) -import Data.Maybe (listToMaybe, isJust) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid ( Monoid(..) ) -#endif -import Data.List (nub, unfoldr, partition, (\\)) +import Distribution.ParseUtils hiding (parseFields) +import Distribution.PackageDescription +import Distribution.PackageDescription.Utils +import Distribution.Package +import Distribution.ModuleName +import Distribution.Version +import Distribution.Verbosity +import Distribution.Compiler +import Distribution.PackageDescription.Configuration +import Distribution.Simple.Utils +import Distribution.Text +import Distribution.Compat.ReadP hiding (get) + +import Data.Char (isSpace) +import Data.Foldable (traverse_) +import Data.Maybe (listToMaybe, isJust) +import Data.List (nub, unfoldr, partition, (\\)) import Control.Monad (liftM, foldM, when, unless, ap) #if __GLASGOW_HASKELL__ < 710 +import Data.Monoid (Monoid(..)) import Control.Applicative (Applicative(..)) #endif -import Control.Arrow (first) +import Control.Arrow (first) import System.Directory (doesFileExist) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import Data.Typeable -import Data.Data -import qualified Data.Map as Map -import Distribution.Text - ( Text(disp, parse), display, simpleParse ) -import Distribution.Compat.ReadP - ((+++), option) -import qualified Distribution.Compat.ReadP as Parse import Text.PrettyPrint -import Distribution.ParseUtils hiding (parseFields) -import Distribution.PackageDescription -import Distribution.PackageDescription.Utils - ( cabalBug, userBug ) -import Distribution.Package - ( PackageIdentifier(..), Dependency(..), packageName, packageVersion ) -import Distribution.ModuleName ( ModuleName ) -import Distribution.Version - ( Version(Version), orLaterVersion - , LowerBound(..), asVersionIntervals ) -import Distribution.Verbosity (Verbosity) -import Distribution.Compiler (CompilerFlavor(..)) -import Distribution.PackageDescription.Configuration (parseCondition, freeVars) -import Distribution.Simple.Utils - ( die, dieWithLocation, warn, intercalate, lowercase, cabalVersion - , withFileContents, withUTF8FileContents - , writeFileAtomic, writeUTF8File ) - -- ----------------------------------------------------------------------------- -- The PackageDescription type @@ -403,8 +389,7 @@ buildTools (\xs binfo -> binfo{buildTools=xs}) , commaListFieldWithSep vcat "build-depends" disp parse - buildDependsWithRenaming - setBuildDependsWithRenaming + targetBuildDepends (\xs binfo -> binfo{targetBuildDepends=xs}) , spaceListField "cpp-options" showToken parseTokenQ' cppOptions (\val binfo -> binfo{cppOptions=val}) @@ -420,6 +405,9 @@ , listField "frameworks" showToken parseTokenQ frameworks (\val binfo -> binfo{frameworks=val}) + , listField "extra-framework-dirs" + showToken parseFilePathQ + extraFrameworkDirs (\val binfo -> binfo{extraFrameworkDirs=val}) , listFieldWithSep vcat "c-sources" showFilePath parseFilePathQ cSources (\paths binfo -> binfo{cSources=paths}) @@ -530,6 +518,15 @@ repoSubdir (\val repo -> repo { repoSubdir = val }) ] +------------------------------------------------------------------------------ + +setupBInfoFieldDescrs :: [FieldDescr SetupBuildInfo] +setupBInfoFieldDescrs = + [ commaListFieldWithSep vcat "setup-depends" + disp parse + setupDepends (\xs binfo -> binfo{setupDepends=xs}) + ] + -- --------------------------------------------------------------- -- Parsing @@ -589,7 +586,8 @@ -- prop_isMapM fs = mapSimpleFields return fs == return fs --- names of fields that represents dependencies, thus consrca +-- names of fields that represents dependencies +-- TODO: maybe build-tools should go here too? constraintFieldNames :: [String] constraintFieldNames = ["build-depends"] @@ -597,9 +595,9 @@ -- they add and define an accessor that specifies what the dependencies -- are. This way we would completely reuse the parsing knowledge from the -- field descriptor. -parseConstraint :: Field -> ParseResult [DependencyWithRenaming] +parseConstraint :: Field -> ParseResult [Dependency] parseConstraint (F l n v) - | n == "build-depends" = runP l n (parseCommaList parse) v + | n `elem` constraintFieldNames = runP l n (parseCommaList parse) v parseConstraint f = userBug $ "Constraint was expected (got: " ++ show f ++ ")" {- @@ -627,12 +625,19 @@ instance Functor f => Functor (StT s f) where fmap g (StT f) = StT $ fmap (first g) . f +#if __GLASGOW_HASKELL__ >= 710 +instance (Monad m) => Applicative (StT s m) where +#else instance (Monad m, Functor m) => Applicative (StT s m) where - pure = return +#endif + pure a = StT (\s -> return (a,s)) (<*>) = ap + instance Monad m => Monad (StT s m) where +#if __GLASGOW_HASKELL__ < 710 return a = StT (\s -> return (a,s)) +#endif StT f >>= g = StT $ \s -> do (a,s') <- f s runStT (g a) s' @@ -736,13 +741,13 @@ -- 'getBody' assumes that the remaining fields only consist of -- flags, lib and exe sections. - (repos, flags, mlib, exes, tests, bms) <- getBody + (repos, flags, mcsetup, mlib, exes, tests, bms) <- getBody warnIfRest -- warn if getBody did not parse up to the last field. -- warn about using old/new syntax with wrong cabal-version: maybeWarnCabalVersion (not $ oldSyntax fields0) pkg checkForUndefinedFlags flags mlib exes tests return $ GenericPackageDescription - pkg { sourceRepos = repos } + pkg { sourceRepos = repos, setupBuildInfo = mcsetup } flags mlib exes tests bms where @@ -848,6 +853,7 @@ -- The body consists of an optional sequence of declarations of flags and -- an arbitrary number of executables and at most one library. getBody :: PM ([SourceRepo], [Flag] + ,Maybe SetupBuildInfo ,Maybe (CondTree ConfVar [Dependency] Library) ,[(String, CondTree ConfVar [Dependency] Executable)] ,[(String, CondTree ConfVar [Dependency] TestSuite)] @@ -860,8 +866,8 @@ exename <- lift $ runP line_no "executable" parseTokenQ sec_label flds <- collectFields parseExeFields sec_fields skipField - (repos, flags, lib, exes, tests, bms) <- getBody - return (repos, flags, lib, (exename, flds): exes, tests, bms) + (repos, flags, csetup, lib, exes, tests, bms) <- getBody + return (repos, flags, csetup, lib, (exename, flds): exes, tests, bms) | sec_type == "test-suite" -> do when (null sec_label) $ lift $ syntaxError line_no @@ -890,7 +896,6 @@ -- Does the current node specify a test type? hasTestType = testInterface ts' /= testInterface emptyTestSuite - components = condTreeComponents ct -- If the current level of the tree specifies a type, -- then we are done. If not, then one of the conditional -- branches below the current node must specify a type. @@ -898,12 +903,13 @@ -- 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 (condTreeComponents ct) if checkTestType emptyTestSuite flds then do skipField - (repos, flags, lib, exes, tests, bms) <- getBody - return (repos, flags, lib, exes, (testname, flds) : tests, bms) + (repos, flags, csetup, lib, exes, tests, bms) <- getBody + return (repos, flags, csetup, lib, exes, + (testname, flds) : tests, bms) else lift $ syntaxError line_no $ "Test suite \"" ++ testname ++ "\" is missing required field \"type\" or the field " @@ -938,7 +944,6 @@ -- Does the current node specify a benchmark type? hasBenchmarkType = benchmarkInterface ts' /= benchmarkInterface emptyBenchmark - components = condTreeComponents ct -- If the current level of the tree specifies a type, -- then we are done. If not, then one of the conditional -- branches below the current node must specify a type. @@ -946,12 +951,13 @@ -- 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 (condTreeComponents ct) if checkBenchmarkType emptyBenchmark flds then do skipField - (repos, flags, lib, exes, tests, bms) <- getBody - return (repos, flags, lib, exes, tests, (benchname, flds) : bms) + (repos, flags, csetup, lib, exes, tests, bms) <- getBody + return (repos, flags, csetup, lib, exes, + tests, (benchname, flds) : bms) else lift $ syntaxError line_no $ "Benchmark \"" ++ benchname ++ "\" is missing required field \"type\" or the field " @@ -964,10 +970,10 @@ syntaxError line_no "'library' expects no argument" flds <- collectFields parseLibFields sec_fields skipField - (repos, flags, lib, exes, tests, bms) <- getBody + (repos, flags, csetup, lib, exes, tests, bms) <- getBody when (isJust lib) $ lift $ syntaxError line_no "There can only be one library section in a package description." - return (repos, flags, Just flds, exes, tests, bms) + return (repos, flags, csetup, Just flds, exes, tests, bms) | sec_type == "flag" -> do when (null sec_label) $ lift $ @@ -978,8 +984,8 @@ (MkFlag (FlagName (lowercase sec_label)) "" True False) sec_fields skipField - (repos, flags, lib, exes, tests, bms) <- getBody - return (repos, flag:flags, lib, exes, tests, bms) + (repos, flags, csetup, lib, exes, tests, bms) <- getBody + return (repos, flag:flags, csetup, lib, exes, tests, bms) | sec_type == "source-repository" -> do when (null sec_label) $ lift $ syntaxError line_no $ @@ -1003,9 +1009,23 @@ } sec_fields skipField - (repos, flags, lib, exes, tests, bms) <- getBody - return (repo:repos, flags, lib, exes, tests, bms) + (repos, flags, csetup, lib, exes, tests, bms) <- getBody + return (repo:repos, flags, csetup, lib, exes, tests, bms) + | sec_type == "custom-setup" -> do + unless (null sec_label) $ lift $ + syntaxError line_no "'setup' expects no argument" + flds <- lift $ parseFields + setupBInfoFieldDescrs + warnUnrec + mempty + sec_fields + skipField + (repos, flags, csetup0, lib, exes, tests, bms) <- getBody + when (isJust csetup0) $ lift $ syntaxError line_no + "There can only be one 'custom-setup' section in a package description." + return (repos, flags, Just flds, lib, exes, tests, bms) + | otherwise -> do lift $ warning $ "Ignoring unknown section type: " ++ sec_type skipField @@ -1020,7 +1040,7 @@ "If-blocks are not allowed in between stanzas: " ++ show f skipField getBody - Nothing -> return ([], [], Nothing, [], [], []) + Nothing -> return ([], [], Nothing, Nothing, [], [], []) -- Extracts all fields in a block and returns a 'CondTree'. -- @@ -1034,18 +1054,30 @@ condFlds = [ f | f@IfBlock{} <- allflds ] sections = [ s | s@Section{} <- allflds ] - -- Put these through the normal parsing pass too, so that we - -- collect the ModRenamings - let depFlds = filter isConstraint simplFlds - mapM_ (\(Section l n _ _) -> lift . warning $ "Unexpected section '" ++ n ++ "' on line " ++ show l) sections a <- parser simplFlds - deps <- liftM concat . mapM (lift . fmap (map dependency) . parseConstraint) $ depFlds + -- Dependencies must be treated specially: when we + -- parse into a CondTree, not only do we parse them into + -- the targetBuildDepends/etc field inside the + -- PackageDescription, but we also have to put the + -- combined dependencies into CondTree. + -- + -- This information is, in principle, redundant, but + -- putting it here makes it easier for the constraint + -- solver to pick a flag assignment which supports + -- all of the dependencies (because it only has + -- to check the CondTree, rather than grovel everywhere + -- inside the conditional bits). + deps <- liftM concat + . mapM (lift . parseConstraint) + . filter isConstraint + $ simplFlds + ifs <- mapM processIfs condFlds return (CondNode a deps ifs) @@ -1091,7 +1123,7 @@ PM () checkForUndefinedFlags flags mlib exes tests = do let definedFlags = map flagName flags - maybe (return ()) (checkCondTreeFlags definedFlags) mlib + traverse_ (checkCondTreeFlags definedFlags) mlib mapM_ (checkCondTreeFlags definedFlags . snd) exes mapM_ (checkCondTreeFlags definedFlags . snd) tests @@ -1248,32 +1280,3 @@ --test_findIndentTabs = findIndentTabs $ unlines $ -- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ] - --- | Dependencies plus module renamings. This is what users specify; however, --- renaming information is not used for dependency resolution. -data DependencyWithRenaming = DependencyWithRenaming Dependency ModuleRenaming - deriving (Read, Show, Eq, Typeable, Data) - -dependency :: DependencyWithRenaming -> Dependency -dependency (DependencyWithRenaming dep _) = dep - -instance Text DependencyWithRenaming where - disp (DependencyWithRenaming d rns) = disp d <+> disp rns - parse = do d <- parse - Parse.skipSpaces - rns <- parse - Parse.skipSpaces - return (DependencyWithRenaming d rns) - -buildDependsWithRenaming :: BuildInfo -> [DependencyWithRenaming] -buildDependsWithRenaming pkg = - map (\dep@(Dependency n _) -> - DependencyWithRenaming dep - (Map.findWithDefault defaultRenaming n (targetBuildRenaming pkg))) - (targetBuildDepends pkg) - -setBuildDependsWithRenaming :: [DependencyWithRenaming] -> BuildInfo -> BuildInfo -setBuildDependsWithRenaming deps pkg = pkg { - targetBuildDepends = map dependency deps, - targetBuildRenaming = Map.fromList (map (\(DependencyWithRenaming (Dependency n _) rns) -> (n, rns)) deps) - } diff --git a/Distribution/PackageDescription/PrettyPrint.hs b/Distribution/PackageDescription/PrettyPrint.hs --- a/Distribution/PackageDescription/PrettyPrint.hs +++ b/Distribution/PackageDescription/PrettyPrint.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.PackageDescription.PrettyPrint @@ -18,27 +17,18 @@ showGenericPackageDescription, ) where -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (Monoid(mempty)) -#endif import Distribution.PackageDescription - ( Benchmark(..), BenchmarkInterface(..), benchmarkType - , TestSuite(..), TestSuiteInterface(..), testType - , SourceRepo(..), - customFieldsBI, CondTree(..), Condition(..), - FlagName(..), ConfVar(..), Executable(..), Library(..), - Flag(..), PackageDescription(..), - GenericPackageDescription(..)) +import Distribution.Simple.Utils +import Distribution.ParseUtils +import Distribution.PackageDescription.Parse +import Distribution.Package +import Distribution.Text + +import Data.Monoid as Mon (Monoid(mempty)) +import Data.Maybe (isJust) import Text.PrettyPrint - (hsep, parens, char, nest, empty, - isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render) -import Distribution.Simple.Utils (writeUTF8File) -import Distribution.ParseUtils (showFreeText, FieldDescr(..), indentWith, ppField, ppFields) -import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs, - sourceRepoFieldDescrs,flagFieldDescrs) -import Distribution.Package (Dependency(..)) -import Distribution.Text (Text(..)) -import Data.Maybe (isJust, fromJust, isNothing) + (hsep, parens, char, nest, empty, isEmpty, ($$), (<+>), + colon, (<>), text, vcat, ($+$), Doc, render) -- | Recompile with false for regression testing simplifiedPrinting :: Bool @@ -226,18 +216,37 @@ else res where -- TODO: this ends up printing trailing spaces when combined with nest. - ppIf (c,thenTree,mElseTree) = - ((emptyLine $ text "if" <+> ppCondition c) $$ - nest indentWith (ppCondTree thenTree - (if simplifiedPrinting then (Just it) else Nothing) ppIt)) - $+$ (if isNothing mElseTree - then empty - else text "else" - $$ nest indentWith (ppCondTree (fromJust mElseTree) - (if simplifiedPrinting then (Just it) else Nothing) ppIt)) + ppIf (c, thenTree, Just elseTree) = ppIfElse it ppIt c thenTree elseTree + ppIf (c, thenTree, Nothing) = ppIf' it ppIt c thenTree -emptyLine :: Doc -> Doc -emptyLine d = text "" $+$ d +ppIfCondition :: (Condition ConfVar) -> Doc +ppIfCondition c = (emptyLine $ text "if" <+> ppCondition c) +ppIf' :: a -> (a -> Maybe a -> Doc) + -> Condition ConfVar + -> CondTree ConfVar [Dependency] a + -> Doc +ppIf' it ppIt c thenTree = + if isEmpty thenDoc + then Mon.mempty + else ppIfCondition c $$ nest indentWith thenDoc + where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt +ppIfElse :: a -> (a -> Maybe a -> Doc) + -> Condition ConfVar + -> CondTree ConfVar [Dependency] a + -> CondTree ConfVar [Dependency] a + -> Doc +ppIfElse it ppIt c thenTree elseTree = + case (isEmpty thenDoc, isEmpty elseDoc) of + (True, True) -> Mon.mempty + (False, True) -> ppIfCondition c $$ nest indentWith thenDoc + (True, False) -> ppIfCondition (cNot c) $$ nest indentWith elseDoc + (False, False) -> (ppIfCondition c $$ nest indentWith thenDoc) + $+$ (text "else" $$ nest indentWith elseDoc) + where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt + elseDoc = ppCondTree elseTree (if simplifiedPrinting then (Just it) else Nothing) ppIt + +emptyLine :: Doc -> Doc +emptyLine d = text "" $+$ d diff --git a/Distribution/ParseUtils.hs b/Distribution/ParseUtils.hs --- a/Distribution/ParseUtils.hs +++ b/Distribution/ParseUtils.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.ParseUtils @@ -40,21 +39,17 @@ UnrecFieldParser, warnUnrec, ignoreUnrec, ) where -import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat) +import Distribution.Compiler import Distribution.License import Distribution.Version - ( Version(..), VersionRange, anyVersion ) -import Distribution.Package ( PackageName(..), Dependency(..) ) -import Distribution.ModuleName (ModuleName) +import Distribution.Package +import Distribution.ModuleName +import qualified Distribution.Compat.MonadFail as Fail import Distribution.Compat.ReadP as ReadP hiding (get) import Distribution.ReadE import Distribution.Text - ( Text(..) ) import Distribution.Simple.Utils - ( comparing, dropWhileEndLE, intercalate, lowercase - , normaliseLineEndings ) import Language.Haskell.Extension - ( Language, Extension ) import Text.PrettyPrint hiding (braces) import Data.Char (isSpace, toLower, isAlphaNum, isDigit) @@ -62,9 +57,7 @@ import Data.Tree as Tree (Tree(..), flatten) import qualified Data.Map as Map import Control.Monad (foldM, ap) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative(..)) -#endif +import Control.Applicative as AP (Applicative(..)) import System.FilePath (normalise) import Data.List (sortBy) @@ -98,16 +91,19 @@ fmap f (ParseOk ws x) = ParseOk ws $ f x instance Applicative ParseResult where - pure = return + pure = ParseOk [] (<*>) = ap instance Monad ParseResult where - return = ParseOk [] + return = AP.pure ParseFailed err >>= _ = ParseFailed err ParseOk ws x >>= f = case f x of ParseFailed err -> ParseFailed err ParseOk ws' x' -> ParseOk (ws'++ws) x' + fail = Fail.fail + +instance Fail.MonadFail ParseResult where fail s = ParseFailed (FromString s Nothing) catchParseError :: ParseResult a -> (PError -> ParseResult a) @@ -660,8 +656,7 @@ parseOptVersion :: ReadP r Version parseOptVersion = parseQuoted ver <++ ver where ver :: ReadP r Version - ver = parse <++ return noVersion - noVersion = Version [] [] + ver = parse <++ return (Version [] []) parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) parseTestedWithQ = parseQuoted tw <++ tw diff --git a/Distribution/Simple.hs b/Distribution/Simple.hs --- a/Distribution/Simple.hs +++ b/Distribution/Simple.hs @@ -56,63 +56,48 @@ -- local import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.UserHooks -import Distribution.Package --must not specify imports, since we're exporting module. -import Distribution.PackageDescription - ( PackageDescription(..), GenericPackageDescription, Executable(..) - , updatePackageDescription, hasLibs - , HookedBuildInfo, emptyHookedBuildInfo ) +import Distribution.Package +import Distribution.PackageDescription hiding (Flag) import Distribution.PackageDescription.Parse - ( readPackageDescription, readHookedBuildInfo ) import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) import Distribution.Simple.Program - ( defaultProgramConfiguration, addKnownPrograms, builtinPrograms - , restoreProgramConfiguration, reconfigurePrograms ) -import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler) +import Distribution.Simple.Program.Db +import Distribution.Simple.PreProcess import Distribution.Simple.Setup import Distribution.Simple.Command -import Distribution.Simple.Build ( build, repl ) -import Distribution.Simple.SrcDist ( sdist ) +import Distribution.Simple.Build +import Distribution.Simple.SrcDist import Distribution.Simple.Register - ( register, unregister ) import Distribution.Simple.Configure - ( getPersistBuildConfig, maybeGetPersistBuildConfig - , writePersistBuildConfig, checkPersistBuildConfigOutdated - , configure, checkForeignDeps ) -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) -import Distribution.Simple.Bench (bench) -import Distribution.Simple.BuildPaths ( srcPref) -import Distribution.Simple.Test (test) -import Distribution.Simple.Install (install) -import Distribution.Simple.Haddock (haddock, hscolour) +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Bench +import Distribution.Simple.BuildPaths +import Distribution.Simple.Test +import Distribution.Simple.Install +import Distribution.Simple.Haddock import Distribution.Simple.Utils - (die, notice, info, warn, setupMessage, chattyTry, - defaultPackageDesc, defaultHookedPackageDesc, - rawSystemExitWithEnv, cabalVersion, topHandler ) -import Distribution.System - ( OS(..), buildOS ) +import Distribution.Utils.NubList import Distribution.Verbosity import Language.Haskell.Extension import Distribution.Version import Distribution.License import Distribution.Text - ( display ) -- Base -import System.Environment(getArgs, getProgName) -import System.Directory(removeFile, doesFileExist, - doesDirectoryExist, removeDirectoryRecursive) -import System.Exit (exitWith,ExitCode(..)) -import System.IO.Error (isDoesNotExistError) -import Control.Exception (throwIO) -import Distribution.Compat.Environment (getEnvironment) -import Distribution.Compat.Exception (catchIO) +import System.Environment (getArgs, getProgName) +import System.Directory (removeFile, doesFileExist + ,doesDirectoryExist, removeDirectoryRecursive) +import System.Exit (exitWith,ExitCode(..)) +import System.FilePath (searchPathSeparator) +import Distribution.Compat.Environment (getEnvironment) +import Distribution.Compat.GetShortPathName (getShortPathName) import Control.Monad (when) -import Data.List (intercalate, unionBy, nub, (\\)) +import Data.Foldable (traverse_) +import Data.List (unionBy, nub, (\\)) -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the @@ -196,151 +181,166 @@ configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo configureAction hooks flags args = do - let distPref = fromFlag $ configDistPref flags - pbi <- preConf hooks args flags + distPref <- findDistPrefOrDefault (configDistPref flags) + let flags' = flags { configDistPref = toFlag distPref } + pbi <- preConf hooks args flags' - (mb_pd_file, pkg_descr0) <- confPkgDescr + (mb_pd_file, pkg_descr0) <- confPkgDescr - -- get_pkg_descr (configVerbosity flags') - --let pkg_descr = updatePackageDescription pbi pkg_descr0 - let epkg_descr = (pkg_descr0, pbi) + --get_pkg_descr (configVerbosity flags') + --let pkg_descr = updatePackageDescription pbi pkg_descr0 + let epkg_descr = (pkg_descr0, pbi) - --(warns, ers) <- sanityCheckPackage pkg_descr - --errorOut (configVerbosity flags') warns ers + --(warns, ers) <- sanityCheckPackage pkg_descr + --errorOut (configVerbosity flags') warns ers - localbuildinfo0 <- confHook hooks epkg_descr flags + localbuildinfo0 <- confHook hooks epkg_descr flags' - -- remember the .cabal filename if we know it - -- and all the extra command line args - let localbuildinfo = localbuildinfo0 { - pkgDescrFile = mb_pd_file, - extraConfigArgs = args - } - writePersistBuildConfig distPref localbuildinfo + -- remember the .cabal filename if we know it + -- and all the extra command line args + let localbuildinfo = localbuildinfo0 { + pkgDescrFile = mb_pd_file, + extraConfigArgs = args + } + writePersistBuildConfig distPref localbuildinfo - let pkg_descr = localPkgDescr localbuildinfo - postConf hooks args flags pkg_descr localbuildinfo - return localbuildinfo - where - verbosity = fromFlag (configVerbosity flags) - confPkgDescr :: IO (Maybe FilePath, GenericPackageDescription) - confPkgDescr = do - mdescr <- readDesc hooks - case mdescr of - Just descr -> return (Nothing, descr) - Nothing -> do - pdfile <- defaultPackageDesc verbosity - descr <- readPackageDescription verbosity pdfile - return (Just pdfile, descr) + let pkg_descr = localPkgDescr localbuildinfo + postConf hooks args flags' pkg_descr localbuildinfo + return localbuildinfo + where + verbosity = fromFlag (configVerbosity flags) + confPkgDescr :: IO (Maybe FilePath, GenericPackageDescription) + confPkgDescr = do + mdescr <- readDesc hooks + case mdescr of + Just descr -> return (Nothing, descr) + Nothing -> do + pdfile <- defaultPackageDesc verbosity + descr <- readPackageDescription verbosity pdfile + return (Just pdfile, descr) buildAction :: UserHooks -> BuildFlags -> Args -> IO () buildAction hooks flags args = do - let distPref = fromFlag $ buildDistPref flags - verbosity = fromFlag $ buildVerbosity flags + distPref <- findDistPrefOrDefault (buildDistPref flags) + let verbosity = fromFlag $ buildVerbosity flags + flags' = flags { buildDistPref = toFlag distPref } lbi <- getBuildConfig hooks verbosity distPref progs <- reconfigurePrograms verbosity - (buildProgramPaths flags) - (buildProgramArgs flags) + (buildProgramPaths flags') + (buildProgramArgs flags') (withPrograms lbi) hookedAction preBuild buildHook postBuild (return lbi { withPrograms = progs }) - hooks flags { buildArgs = args } args + hooks flags' { buildArgs = args } args replAction :: UserHooks -> ReplFlags -> Args -> IO () replAction hooks flags args = do - let distPref = fromFlag $ replDistPref flags - verbosity = fromFlag $ replVerbosity flags + distPref <- findDistPrefOrDefault (replDistPref flags) + let verbosity = fromFlag $ replVerbosity flags + flags' = flags { replDistPref = toFlag distPref } lbi <- getBuildConfig hooks verbosity distPref progs <- reconfigurePrograms verbosity - (replProgramPaths flags) - (replProgramArgs flags) + (replProgramPaths flags') + (replProgramArgs flags') (withPrograms lbi) - pbi <- preRepl hooks args flags + pbi <- preRepl hooks args flags' let lbi' = lbi { withPrograms = progs } pkg_descr0 = localPkgDescr lbi' pkg_descr = updatePackageDescription pbi pkg_descr0 - replHook hooks pkg_descr lbi' hooks flags args - postRepl hooks args flags pkg_descr lbi' + replHook hooks pkg_descr lbi' hooks flags' args + postRepl hooks args flags' pkg_descr lbi' hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () -hscolourAction hooks flags args - = do let distPref = fromFlag $ hscolourDistPref flags - verbosity = fromFlag $ hscolourVerbosity flags - hookedAction preHscolour hscolourHook postHscolour - (getBuildConfig hooks verbosity distPref) - hooks flags args +hscolourAction hooks flags args = do + distPref <- findDistPrefOrDefault (hscolourDistPref flags) + let verbosity = fromFlag $ hscolourVerbosity flags + flags' = flags { hscolourDistPref = toFlag distPref } + hookedAction preHscolour hscolourHook postHscolour + (getBuildConfig hooks verbosity distPref) + hooks flags' args haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () haddockAction hooks flags args = do - let distPref = fromFlag $ haddockDistPref flags - verbosity = fromFlag $ haddockVerbosity flags + distPref <- findDistPrefOrDefault (haddockDistPref flags) + let verbosity = fromFlag $ haddockVerbosity flags + flags' = flags { haddockDistPref = toFlag distPref } lbi <- getBuildConfig hooks verbosity distPref progs <- reconfigurePrograms verbosity - (haddockProgramPaths flags) - (haddockProgramArgs flags) + (haddockProgramPaths flags') + (haddockProgramArgs flags') (withPrograms lbi) hookedAction preHaddock haddockHook postHaddock (return lbi { withPrograms = progs }) - hooks flags args + hooks flags' args cleanAction :: UserHooks -> CleanFlags -> Args -> IO () cleanAction hooks flags args = do - pbi <- preClean hooks args flags + distPref <- findDistPrefOrDefault (cleanDistPref flags) + let flags' = flags { cleanDistPref = toFlag distPref } - pdfile <- defaultPackageDesc verbosity - ppd <- readPackageDescription verbosity pdfile - let pkg_descr0 = flattenPackageDescription ppd - -- We don't sanity check for clean as an error - -- here would prevent cleaning: - --sanityCheckHookedBuildInfo pkg_descr0 pbi - let pkg_descr = updatePackageDescription pbi pkg_descr0 + pbi <- preClean hooks args flags' - cleanHook hooks pkg_descr () hooks flags - postClean hooks args flags pkg_descr () - where verbosity = fromFlag (cleanVerbosity flags) + pdfile <- defaultPackageDesc verbosity + ppd <- readPackageDescription verbosity pdfile + let pkg_descr0 = flattenPackageDescription ppd + -- We don't sanity check for clean as an error + -- here would prevent cleaning: + --sanityCheckHookedBuildInfo pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + cleanHook hooks pkg_descr () hooks flags' + postClean hooks args flags' pkg_descr () + where + verbosity = fromFlag (cleanVerbosity flags) + copyAction :: UserHooks -> CopyFlags -> Args -> IO () -copyAction hooks flags args - = do let distPref = fromFlag $ copyDistPref flags - verbosity = fromFlag $ copyVerbosity flags - hookedAction preCopy copyHook postCopy - (getBuildConfig hooks verbosity distPref) - hooks flags args +copyAction hooks flags args = do + distPref <- findDistPrefOrDefault (copyDistPref flags) + let verbosity = fromFlag $ copyVerbosity flags + flags' = flags { copyDistPref = toFlag distPref } + hookedAction preCopy copyHook postCopy + (getBuildConfig hooks verbosity distPref) + hooks flags' args installAction :: UserHooks -> InstallFlags -> Args -> IO () -installAction hooks flags args - = do let distPref = fromFlag $ installDistPref flags - verbosity = fromFlag $ installVerbosity flags - hookedAction preInst instHook postInst - (getBuildConfig hooks verbosity distPref) - hooks flags args +installAction hooks flags args = do + distPref <- findDistPrefOrDefault (installDistPref flags) + let verbosity = fromFlag $ installVerbosity flags + flags' = flags { installDistPref = toFlag distPref } + hookedAction preInst instHook postInst + (getBuildConfig hooks verbosity distPref) + hooks flags' args sdistAction :: UserHooks -> SDistFlags -> Args -> IO () sdistAction hooks flags args = do - let distPref = fromFlag $ sDistDistPref flags - pbi <- preSDist hooks args flags + distPref <- findDistPrefOrDefault (sDistDistPref flags) + let flags' = flags { sDistDistPref = toFlag distPref } + pbi <- preSDist hooks args flags' - mlbi <- maybeGetPersistBuildConfig distPref - pdfile <- defaultPackageDesc verbosity - ppd <- readPackageDescription verbosity pdfile - let pkg_descr0 = flattenPackageDescription ppd - sanityCheckHookedBuildInfo pkg_descr0 pbi - let pkg_descr = updatePackageDescription pbi pkg_descr0 + mlbi <- maybeGetPersistBuildConfig distPref + pdfile <- defaultPackageDesc verbosity + ppd <- readPackageDescription verbosity pdfile + let pkg_descr0 = flattenPackageDescription ppd + sanityCheckHookedBuildInfo pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 - sDistHook hooks pkg_descr mlbi hooks flags - postSDist hooks args flags pkg_descr mlbi - where verbosity = fromFlag (sDistVerbosity flags) + sDistHook hooks pkg_descr mlbi hooks flags' + postSDist hooks args flags' pkg_descr mlbi + where + verbosity = fromFlag (sDistVerbosity flags) testAction :: UserHooks -> TestFlags -> Args -> IO () testAction hooks flags args = do - let distPref = fromFlag $ testDistPref flags - verbosity = fromFlag $ testVerbosity flags + distPref <- findDistPrefOrDefault (testDistPref flags) + let verbosity = fromFlag $ testVerbosity flags + flags' = flags { testDistPref = toFlag distPref } + localBuildInfo <- getBuildConfig hooks verbosity distPref let pkg_descr = localPkgDescr localBuildInfo -- It is safe to do 'runTests' before the new test handler because the @@ -349,31 +349,34 @@ runTests hooks args False pkg_descr localBuildInfo hookedActionWithArgs preTest testHook postTest (getBuildConfig hooks verbosity distPref) - hooks flags args + hooks flags' args benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO () benchAction hooks flags args = do - let distPref = fromFlag $ benchmarkDistPref flags - verbosity = fromFlag $ benchmarkVerbosity flags + distPref <- findDistPrefOrDefault (benchmarkDistPref flags) + let verbosity = fromFlag $ benchmarkVerbosity flags + flags' = flags { benchmarkDistPref = toFlag distPref } hookedActionWithArgs preBench benchHook postBench (getBuildConfig hooks verbosity distPref) - hooks flags args + hooks flags' args registerAction :: UserHooks -> RegisterFlags -> Args -> IO () -registerAction hooks flags args - = do let distPref = fromFlag $ regDistPref flags - verbosity = fromFlag $ regVerbosity flags - hookedAction preReg regHook postReg - (getBuildConfig hooks verbosity distPref) - hooks flags args +registerAction hooks flags args = do + distPref <- findDistPrefOrDefault (regDistPref flags) + let verbosity = fromFlag $ regVerbosity flags + flags' = flags { regDistPref = toFlag distPref } + hookedAction preReg regHook postReg + (getBuildConfig hooks verbosity distPref) + hooks flags' args unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () -unregisterAction hooks flags args - = do let distPref = fromFlag $ regDistPref flags - verbosity = fromFlag $ regVerbosity flags - hookedAction preUnreg unregHook postUnreg - (getBuildConfig hooks verbosity distPref) - hooks flags args +unregisterAction hooks flags args = do + distPref <- findDistPrefOrDefault (regDistPref flags) + let verbosity = fromFlag $ regVerbosity flags + flags' = flags { regDistPref = toFlag distPref } + hookedAction preUnreg unregHook postUnreg + (getBuildConfig hooks verbosity distPref) + hooks flags' args hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo) -> (UserHooks -> PackageDescription -> LocalBuildInfo @@ -451,9 +454,9 @@ -- Since the list of unconfigured programs is not serialized, -- restore it to the same value as normally used at the beginning -- of a configure run: - configPrograms = restoreProgramConfiguration + configPrograms_ = restoreProgramConfiguration (builtinPrograms ++ hookedPrograms hooks) - (configPrograms cFlags), + `fmap` configPrograms_ cFlags, -- Use the current, not saved verbosity level: configVerbosity = Flag verbosity @@ -466,7 +469,7 @@ clean :: PackageDescription -> CleanFlags -> IO () clean pkg_descr flags = do - let distPref = fromFlag $ cleanDistPref flags + let distPref = fromFlagOrDefault defaultDistPref $ cleanDistPref flags notice verbosity "cleaning..." maybeConfig <- if fromFlag (cleanSaveConf flags) @@ -483,7 +486,7 @@ mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr) -- If the user wanted to save the config, write it back - maybe (return ()) (writePersistBuildConfig distPref) maybeConfig + traverse_ (writePersistBuildConfig distPref) maybeConfig where removeFileOrDirectory :: FilePath -> IO () @@ -607,42 +610,35 @@ runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo -> IO () runConfigureScript verbosity backwardsCompatHack flags lbi = do - env <- getEnvironment let programConfig = withPrograms lbi (ccProg, ccFlags) <- configureCCompiler verbosity programConfig + ccProgShort <- getShortPathName ccProg -- The C compiler's compilation and linker flags (e.g. -- "C compiler flags" and "Gcc Linker flags" from GHC) have already -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS -- to ccFlags -- We don't try and tell configure which ld to use, as we don't have -- a way to pass its flags too - let env' = appendToEnvironment ("CFLAGS", unwords ccFlags) - env - args' = args ++ ["--with-gcc=" ++ ccProg] - handleNoWindowsSH $ - rawSystemExitWithEnv verbosity "sh" args' env' + let extraPath = fromNubList $ configProgramPathExtra flags + let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) $ lookup "CFLAGS" env + spSep = [searchPathSeparator] + pathEnv = maybe (intercalate spSep extraPath) ((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env + overEnv = ("CFLAGS", Just cflagsEnv) : [("PATH", Just pathEnv) | not (null extraPath)] + args' = args ++ ["CC=" ++ ccProgShort] + shProg = simpleProgram "sh" + progDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb + shConfiguredProg <- lookupProgram shProg `fmap` configureProgram verbosity shProg progDb + case shConfiguredProg of + Just sh -> runProgramInvocation verbosity (programInvocation (sh {programOverrideEnv = overEnv}) args') + Nothing -> die notFoundMsg where args = "./configure" : configureArgs backwardsCompatHack flags - appendToEnvironment (key, val) [] = [(key, val)] - appendToEnvironment (key, val) (kv@(k, v) : rest) - | key == k = (key, v ++ " " ++ val) : rest - | otherwise = kv : appendToEnvironment (key, val) rest - - handleNoWindowsSH action - | buildOS /= Windows - = action - - | otherwise - = action - `catchIO` \ioe -> if isDoesNotExistError ioe - then die notFoundMsg - else throwIO ioe - - notFoundMsg = "The package has a './configure' script. This requires a " - ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin." + notFoundMsg = "The package has a './configure' script. If you are on Windows, This requires a " + ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. " + ++ "If you are not on Windows, ensure that an 'sh' command is discoverable in your path." getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo getHookedBuildInfo verbosity = do @@ -695,6 +691,5 @@ defaultRegHook pkg_descr localbuildinfo _ flags = if hasLibs pkg_descr then register pkg_descr localbuildinfo flags - else setupMessage verbosity + else setupMessage (fromFlag (regVerbosity flags)) "Package contains no library to register:" (packageId pkg_descr) - where verbosity = fromFlag (regVerbosity flags) diff --git a/Distribution/Simple/Bench.hs b/Distribution/Simple/Bench.hs --- a/Distribution/Simple/Bench.hs +++ b/Distribution/Simple/Bench.hs @@ -16,22 +16,17 @@ ) where import qualified Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(buildable) - , Benchmark(..), BenchmarkInterface(..), benchmarkType, hasBenchmarks ) -import Distribution.Simple.BuildPaths ( exeExtension ) -import Distribution.Simple.Compiler ( compilerInfo ) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler import Distribution.Simple.InstallDirs - ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) - , substPathTemplate , toPathTemplate, PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI - ( LocalBuildInfo(..) ) -import Distribution.Simple.Setup ( BenchmarkFlags(..), fromFlag ) -import Distribution.Simple.UserHooks ( Args ) -import Distribution.Simple.Utils ( die, notice, rawSystemExitCode ) +import Distribution.Simple.Setup +import Distribution.Simple.UserHooks +import Distribution.Simple.Utils import Distribution.Text -import Control.Monad ( when, unless ) -import System.Exit ( ExitCode(..), exitFailure, exitWith ) +import Control.Monad ( when, unless, forM ) +import System.Exit ( ExitCode(..), exitFailure, exitSuccess ) import System.Directory ( doesFileExist ) import System.FilePath ( (), (<.>) ) @@ -78,9 +73,9 @@ ++ show (disp $ PD.benchmarkType bm) exitFailure - when (not $ PD.hasBenchmarks pkg_descr) $ do + unless (PD.hasBenchmarks pkg_descr) $ do notice verbosity "Package has no benchmarks." - exitWith ExitSuccess + exitSuccess when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ die $ "No benchmarks enabled. Did you remember to configure with " @@ -88,7 +83,7 @@ bmsToRun <- case benchmarkNames of [] -> return enabledBenchmarks - names -> flip mapM names $ \bmName -> + names -> forM names $ \bmName -> let benchmarkMap = zip enabledNames enabledBenchmarks enabledNames = map PD.benchmarkName enabledBenchmarks allNames = map PD.benchmarkName pkgBenchmarks @@ -123,6 +118,6 @@ fromPathTemplate $ substPathTemplate env template where env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.pkgKey lbi) + (PD.package pkg_descr) (LBI.localUnitId lbi) (compilerInfo $ 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 @@ -23,6 +23,7 @@ writeAutogenFiles, ) where +import Distribution.Package import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.JHC as JHC @@ -33,65 +34,40 @@ import qualified Distribution.Simple.Build.Macros as Build.Macros import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule -import Distribution.Package - ( Package(..), PackageName(..), PackageIdentifier(..) - , Dependency(..), thisPackageVersion, mkPackageKey, packageName ) -import Distribution.Simple.Compiler - ( Compiler, CompilerFlavor(..), compilerFlavor - , PackageDB(..), PackageDBStack, packageKeySupported ) -import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..) - , TestSuite(..), TestSuiteInterface(..), Benchmark(..) - , BenchmarkInterface(..), defaultRenaming ) +import Distribution.Simple.Compiler hiding (Flag) +import Distribution.PackageDescription hiding (Flag) import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.ModuleName as ModuleName import Distribution.ModuleName (ModuleName) import Distribution.Simple.Setup - ( Flag(..), BuildFlags(..), ReplFlags(..), fromFlag ) import Distribution.Simple.BuildTarget - ( BuildTarget(..), readBuildTargets ) import Distribution.Simple.PreProcess - ( preprocessComponent, PPSuffixHandler ) import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms, pkgKey) - , 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 qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.BuildPaths - ( autogenModulesDir, autogenModuleName, cppHeaderName, exeExtension ) +import Distribution.Simple.Configure import Distribution.Simple.Register - ( registerPackage, inplaceInstalledPackageInfo ) -import Distribution.Simple.Test.LibV09 ( stubFilePath, stubName ) +import Distribution.Simple.Test.LibV09 import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, rewriteFile - , die, info, debug, warn, setupMessage ) -import Distribution.Verbosity - ( Verbosity ) +import Distribution.System import Distribution.Text - ( display ) +import Distribution.Verbosity import qualified Data.Map as Map -import Data.Maybe - ( maybeToList ) +import qualified Data.Set as Set import Data.Either ( partitionEithers ) import Data.List - ( intersect, intercalate ) + ( intersect ) import Control.Monad ( when, unless, forM_ ) import System.FilePath ( (), (<.>) ) import System.Directory - ( getCurrentDirectory, removeDirectoryRecursive, removeFile - , doesDirectoryExist, doesFileExist ) + ( getCurrentDirectory ) -- ----------------------------------------------------------------------------- -- |Build the libraries and executables in this package. @@ -178,11 +154,12 @@ -- | Start an interpreter without loading any package files. -startInterpreter :: Verbosity -> ProgramDb -> Compiler -> PackageDBStack -> IO () -startInterpreter verbosity programDb comp packageDBs = +startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform + -> PackageDBStack -> IO () +startInterpreter verbosity programDb comp platform packageDBs = case compilerFlavor comp of - GHC -> GHC.startInterpreter verbosity programDb comp packageDBs - GHCJS -> GHCJS.startInterpreter verbosity programDb comp packageDBs + GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs + GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs _ -> die "A REPL is not supported with this compiler." buildComponent :: Verbosity @@ -197,27 +174,30 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes comp@(CLib lib) clbi distPref = do preprocessComponent pkg_descr comp lbi False verbosity suffixes + extras <- preprocessExtras comp lbi info verbosity "Building library..." - buildLib verbosity numJobs pkg_descr lbi lib clbi + let libbi = libBuildInfo lib + lib' = lib { libBuildInfo = addExtraCSources libbi extras } + buildLib verbosity numJobs pkg_descr lbi lib' clbi -- Register the library in-place, so exes can depend -- on internally defined libraries. pwd <- getCurrentDirectory let -- The in place registration uses the "-inplace" suffix, not an ABI hash - ipkgid = inplacePackageId (packageId installedPkgInfo) installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr - ipkgid lib lbi clbi - - registerPackage verbosity - installedPkgInfo pkg_descr lbi True -- True meaning in place - (withPackageDB lbi) + (AbiHash "") lib' lbi clbi + registerPackage verbosity (compiler lbi) (withPrograms lbi) False + (withPackageDB lbi) installedPkgInfo buildComponent verbosity numJobs pkg_descr lbi suffixes comp@(CExe exe) clbi _ = do preprocessComponent pkg_descr comp lbi False verbosity suffixes + extras <- preprocessExtras comp lbi info verbosity $ "Building executable " ++ exeName exe ++ "..." - buildExe verbosity numJobs pkg_descr lbi exe clbi + let ebi = buildInfo exe + exe' = exe { buildInfo = addExtraCSources ebi extras } + buildExe verbosity numJobs pkg_descr lbi exe' clbi buildComponent verbosity numJobs pkg_descr lbi suffixes @@ -225,8 +205,11 @@ clbi _distPref = do let exe = testSuiteExeV10AsExe test preprocessComponent pkg_descr comp lbi False verbosity suffixes + extras <- preprocessExtras comp lbi info verbosity $ "Building test suite " ++ testName test ++ "..." - buildExe verbosity numJobs pkg_descr lbi exe clbi + let ebi = buildInfo exe + exe' = exe { buildInfo = addExtraCSources ebi extras } + buildExe verbosity numJobs pkg_descr lbi exe' clbi buildComponent verbosity numJobs pkg_descr lbi0 suffixes @@ -242,10 +225,17 @@ let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd preprocessComponent pkg_descr comp lbi False verbosity suffixes + extras <- preprocessExtras comp lbi info verbosity $ "Building test suite " ++ testName test ++ "..." buildLib verbosity numJobs pkg lbi lib libClbi - registerPackage verbosity ipi pkg lbi True $ withPackageDB lbi - buildExe verbosity numJobs pkg_descr lbi exe exeClbi + -- NB: need to enable multiple instances here, because on 7.10+ + -- the package name is the same as the library, and we still + -- want the registration to go through. + registerPackage verbosity (compiler lbi) (withPrograms lbi) True + (withPackageDB lbi) ipi + let ebi = buildInfo exe + exe' = exe { buildInfo = addExtraCSources ebi extras } + buildExe verbosity numJobs pkg_descr lbi exe' exeClbi buildComponent _ _ _ _ _ @@ -259,8 +249,11 @@ clbi _ = do let (exe, exeClbi) = benchmarkExeV10asExe bm clbi preprocessComponent pkg_descr comp lbi False verbosity suffixes + extras <- preprocessExtras comp lbi info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..." - buildExe verbosity numJobs pkg_descr lbi exe exeClbi + let ebi = buildInfo exe + exe' = exe { buildInfo = addExtraCSources ebi extras } + buildExe verbosity numJobs pkg_descr lbi exe' exeClbi buildComponent _ _ _ _ _ @@ -269,6 +262,15 @@ die $ "No support for building benchmark type " ++ display tt +-- | Add extra C sources generated by preprocessing to build +-- information. +addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo +addExtraCSources bi extras = bi { cSources = new } + where new = Set.toList $ old `Set.union` exs + old = Set.fromList $ cSources bi + exs = Set.fromList extras + + replComponent :: Verbosity -> PackageDescription -> LocalBuildInfo @@ -280,12 +282,18 @@ replComponent verbosity pkg_descr lbi suffixes comp@(CLib lib) clbi _ = do preprocessComponent pkg_descr comp lbi False verbosity suffixes - replLib verbosity pkg_descr lbi lib clbi + extras <- preprocessExtras comp lbi + let libbi = libBuildInfo lib + lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } + replLib verbosity pkg_descr lbi lib' clbi replComponent verbosity pkg_descr lbi suffixes comp@(CExe exe) clbi _ = do preprocessComponent pkg_descr comp lbi False verbosity suffixes - replExe verbosity pkg_descr lbi exe clbi + extras <- preprocessExtras comp lbi + let ebi = buildInfo exe + exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } + replExe verbosity pkg_descr lbi exe' clbi replComponent verbosity pkg_descr lbi suffixes @@ -293,7 +301,10 @@ clbi _distPref = do let exe = testSuiteExeV10AsExe test preprocessComponent pkg_descr comp lbi False verbosity suffixes - replExe verbosity pkg_descr lbi exe clbi + extras <- preprocessExtras comp lbi + let ebi = buildInfo exe + exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } + replExe verbosity pkg_descr lbi exe' clbi replComponent verbosity pkg_descr lbi0 suffixes @@ -304,7 +315,10 @@ let (pkg, lib, libClbi, lbi, _, _, _) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd preprocessComponent pkg_descr comp lbi False verbosity suffixes - replLib verbosity pkg lbi lib libClbi + extras <- preprocessExtras comp lbi + let libbi = libBuildInfo lib + lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } + replLib verbosity pkg lbi lib' libClbi replComponent _ _ _ _ @@ -318,7 +332,10 @@ clbi _ = do let (exe, exeClbi) = benchmarkExeV10asExe bm clbi preprocessComponent pkg_descr comp lbi False verbosity suffixes - replExe verbosity pkg_descr lbi exe exeClbi + extras <- preprocessExtras comp lbi + let ebi = buildInfo exe + exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } + replExe verbosity pkg_descr lbi exe' exeClbi replComponent _ _ _ _ @@ -350,12 +367,12 @@ -> (PackageDescription, Library, ComponentLocalBuildInfo, LocalBuildInfo, - IPI.InstalledPackageInfo_ ModuleName, + IPI.InstalledPackageInfo, Executable, ComponentLocalBuildInfo) testSuiteLibV09AsLibAndExe pkg_descr test@TestSuite { testInterface = TestSuiteLibV09 _ m } clbi lbi distPref pwd = - (pkg, lib, libClbi, lbi', ipi, exe, exeClbi) + (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) where bi = testBuildInfo test lib = Library { @@ -366,31 +383,31 @@ libExposed = True, libBuildInfo = bi } + -- NB: temporary hack; I have a refactor which solves this + cid = computeComponentId (package pkg_descr) + (CTestName (testName test)) + (map ((\(SimpleUnitId cid0) -> cid0) . fst) + (componentPackageDeps clbi)) + (flagAssignment lbi) + uid = SimpleUnitId cid + (pkg_name, compat_key) = computeCompatPackageKey + (compiler lbi) (package pkg_descr) + (CTestName (testName test)) uid libClbi = LibComponentLocalBuildInfo { componentPackageDeps = componentPackageDeps clbi , componentPackageRenaming = componentPackageRenaming clbi - , componentLibraries = [LibraryName (testName test)] - , componentExposedModules = [IPI.ExposedModule m Nothing Nothing] + , componentUnitId = uid + , componentCompatPackageKey = compat_key + , componentExposedModules = [IPI.ExposedModule m Nothing] } pkg = pkg_descr { - package = (package pkg_descr) { - pkgName = PackageName (testName test) - } + package = (package pkg_descr) { pkgName = pkg_name } , buildDepends = targetBuildDepends $ testBuildInfo test , executables = [] , testSuites = [] , library = Just lib } - -- Hack to make the library compile with the right package key. - -- Probably the "right" way to do this is move this information to - -- the ComponentLocalBuildInfo, but it seems odd that a single package - -- can define multiple actual packages. - lbi' = lbi { - pkgKey = mkPackageKey (packageKeySupported (compiler lbi)) - (package pkg) [] [] - } - ipkgid = inplacePackageId (packageId pkg) - ipi = inplaceInstalledPackageInfo pwd distPref pkg ipkgid lib lbi' libClbi + ipi = inplaceInstalledPackageInfo pwd distPref pkg (AbiHash "") lib lbi libClbi testDir = buildDir lbi stubName test stubName test ++ "-tmp" testLibDep = thisPackageVersion $ package pkg @@ -401,22 +418,18 @@ hsSourceDirs = [ testDir ], targetBuildDepends = testLibDep : (targetBuildDepends $ testBuildInfo test), - targetBuildRenaming = - Map.insert (packageName pkg) defaultRenaming - (targetBuildRenaming $ testBuildInfo test) + targetBuildRenaming = Map.empty } } -- | The stub executable needs a new 'ComponentLocalBuildInfo' -- that exposes the relevant test suite library. exeClbi = ExeComponentLocalBuildInfo { componentPackageDeps = - (IPI.installedPackageId ipi, packageId ipi) + (IPI.installedUnitId ipi, packageId ipi) : (filter (\(_, x) -> let PackageName name = pkgName x in name == "Cabal" || name == "base") (componentPackageDeps clbi)), - componentPackageRenaming = - Map.insert (packageName ipi) defaultRenaming - (componentPackageRenaming clbi) + componentPackageRenaming = Map.empty } testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" @@ -444,24 +457,14 @@ createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath -> IO PackageDB createInternalPackageDB verbosity lbi distPref = do - case compilerFlavor (compiler lbi) of - GHC -> createWith $ GHC.hcPkgInfo (withPrograms lbi) - GHCJS -> createWith $ GHCJS.hcPkgInfo (withPrograms lbi) - LHC -> createWith $ LHC.hcPkgInfo (withPrograms lbi) - _ -> return packageDB - where - dbPath = distPref "package.conf.inplace" - packageDB = SpecificPackageDB dbPath - createWith hpi = do - dir_exists <- doesDirectoryExist dbPath - if dir_exists - then removeDirectoryRecursive dbPath - else do file_exists <- doesFileExist dbPath - when file_exists $ removeFile dbPath - if HcPkg.useSingleFileDb hpi - then writeFile dbPath "[]" - else HcPkg.init hpi verbosity dbPath - return packageDB + existsAlready <- doesPackageDBExist dbPath + when existsAlready $ deletePackageDB dbPath + createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath + return (SpecificPackageDB dbPath) + where + dbPath = case compilerFlavor (compiler lbi) of + UHC -> UHC.inplacePackageDbPath lbi + _ -> distPref "package.conf.inplace" addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo -> ProgramDb -> ProgramDb @@ -532,12 +535,10 @@ -> IO () initialBuildSteps _distPref pkg_descr lbi verbosity = do -- check that there's something to build - let buildInfos = - map libBuildInfo (maybeToList (library pkg_descr)) ++ - map buildInfo (executables pkg_descr) - unless (any buildable buildInfos) $ do + unless (not . null $ allBuildInfo pkg_descr) $ do let name = display (packageId pkg_descr) - die ("Package " ++ name ++ " can't be built on this system.") + die $ "No libraries, executables, tests, or benchmarks " + ++ "are enabled for package " ++ name ++ "." createDirectoryIfMissingVerbose verbosity True (buildDir lbi) 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 @@ -29,11 +29,10 @@ import Distribution.Version ( Version(versionBranch) ) import Distribution.PackageDescription - ( PackageDescription ) -import Distribution.Simple.Compiler - ( packageKeySupported ) + ( PackageDescription ( package ) ) import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(compiler, pkgKey, withPrograms), externalPackageDeps ) + ( LocalBuildInfo(withPrograms), externalPackageDeps + , localComponentId, localCompatPackageKey ) import Distribution.Simple.Program.Db ( configuredPrograms ) import Distribution.Simple.Program.Types @@ -48,11 +47,12 @@ -- | The contents of the @cabal_macros.h@ for the given configured package. -- generate :: PackageDescription -> LocalBuildInfo -> String -generate _pkg_descr lbi = +generate pkg_descr lbi = "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" ++ - generatePackageVersionMacros (map snd (externalPackageDeps lbi)) ++ + generatePackageVersionMacros + (package pkg_descr : map snd (externalPackageDeps lbi)) ++ generateToolVersionMacros (configuredPrograms . withPrograms $ lbi) ++ - generatePackageKeyMacro lbi + generateComponentIdMacro 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 @@ -96,13 +96,14 @@ where (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) --- | Generate the @CURRENT_PACKAGE_KEY@ definition for the package key --- of the current package, if supported by the compiler -generatePackageKeyMacro :: LocalBuildInfo -> String -generatePackageKeyMacro lbi - | packageKeySupported (compiler lbi) = - "#define CURRENT_PACKAGE_KEY \"" ++ display (pkgKey lbi) ++ "\"\n\n" - | otherwise = "" +-- | Generate the @CURRENT_COMPONENT_ID@ definition for the component ID +-- of the current package. +generateComponentIdMacro :: LocalBuildInfo -> String +generateComponentIdMacro lbi = + concat + [ "#define CURRENT_COMPONENT_ID \"" ++ display (localComponentId lbi) ++ "\"\n\n" + , "#define CURRENT_PACKAGE_KEY \"" ++ localCompatPackageKey lbi ++ "\"\n\n" + ] fixchar :: Char -> Char fixchar '-' = '_' 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 @@ -19,25 +19,14 @@ ) where import Distribution.System - ( OS(Windows), buildOS, Arch(..), buildArch ) import Distribution.Simple.Compiler - ( CompilerFlavor(..), compilerFlavor, compilerVersion ) import Distribution.Package - ( packageId, packageName, packageVersion ) import Distribution.PackageDescription - ( PackageDescription(..), hasLibs ) import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), InstallDirs(..) - , absoluteInstallDirs, prefixRelativeInstallDirs ) -import Distribution.Simple.Setup ( CopyDest(NoCopyDest) ) import Distribution.Simple.BuildPaths - ( autogenModuleName ) import Distribution.Simple.Utils - ( shortRelativePath ) import Distribution.Text - ( display ) import Distribution.Version - ( Version(..), orLaterVersion, withinRange ) import System.FilePath ( pathSeparator ) @@ -50,7 +39,12 @@ generate :: PackageDescription -> LocalBuildInfo -> String generate pkg_descr lbi = - let pragmas + let pragmas = cpp_pragma ++ ffi_pragmas ++ warning_pragmas + + cpp_pragma | supports_cpp = "{-# LANGUAGE CPP #-}\n" + | otherwise = "" + + ffi_pragmas | absolute = "" | supports_language_pragma = "{-# LANGUAGE ForeignFunctionInterface #-}\n" @@ -58,6 +52,10 @@ "{-# OPTIONS_GHC -fffi #-}\n"++ "{-# OPTIONS_JHC -fffi #-}\n" + warning_pragmas = + "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n"++ + "{-# OPTIONS_GHC -fno-warn-implicit-prelude #-}\n" + foreign_imports | absolute = "" | otherwise = @@ -84,7 +82,21 @@ reloc_imports ++ "import Prelude\n"++ "\n"++ - "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++ + (if supports_cpp + then + ("#if defined(VERSION_base)\n"++ + "\n"++ + "#if MIN_VERSION_base(4,0,0)\n"++ + "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++ + "#else\n"++ + "catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a\n"++ + "#endif\n"++ + "\n"++ + "#else\n"++ + "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++ + "#endif\n") + else + "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n")++ "catchIO = Exception.catch\n" ++ "\n"++ "version :: Version"++ @@ -212,6 +224,8 @@ get_prefix_stuff = get_prefix_win32 buildArch path_sep = show [pathSeparator] + + supports_cpp = compilerFlavor (compiler lbi) == GHC supports_language_pragma = (compilerFlavor (compiler lbi) == GHC && diff --git a/Distribution/Simple/BuildPaths.hs b/Distribution/Simple/BuildPaths.hs --- a/Distribution/Simple/BuildPaths.hs +++ b/Distribution/Simple/BuildPaths.hs @@ -31,22 +31,17 @@ ) where -import System.FilePath ((), (<.>)) - import Distribution.Package - ( packageName ) -import Distribution.ModuleName (ModuleName) -import qualified Distribution.ModuleName as ModuleName +import Distribution.ModuleName as ModuleName import Distribution.Compiler - ( CompilerId(..) ) -import Distribution.PackageDescription (PackageDescription) +import Distribution.PackageDescription import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(buildDir), LibraryName(..) ) -import Distribution.Simple.Setup (defaultDistPref) +import Distribution.Simple.Setup import Distribution.Text - ( display ) -import Distribution.System (OS(..), buildOS) +import Distribution.System +import System.FilePath ((), (<.>)) + -- --------------------------------------------------------------------------- -- Build directories and files @@ -81,33 +76,31 @@ -- --------------------------------------------------------------------------- -- Library file names -mkLibName :: LibraryName -> String -mkLibName (LibraryName lib) = "lib" ++ lib <.> "a" +mkLibName :: UnitId -> String +mkLibName lib = "lib" ++ getHSLibraryName lib <.> "a" -mkProfLibName :: LibraryName -> String -mkProfLibName (LibraryName lib) = "lib" ++ lib ++ "_p" <.> "a" +mkProfLibName :: UnitId -> String +mkProfLibName lib = "lib" ++ getHSLibraryName lib ++ "_p" <.> "a" -- Implement proper name mangling for dynamical shared objects -- libHS- -- e.g. libHSbase-2.1-ghc6.6.1.so -mkSharedLibName :: CompilerId -> LibraryName -> String -mkSharedLibName (CompilerId compilerFlavor compilerVersion) (LibraryName lib) - = "lib" ++ lib ++ "-" ++ comp <.> dllExtension +mkSharedLibName :: CompilerId -> UnitId -> String +mkSharedLibName (CompilerId compilerFlavor compilerVersion) lib + = "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> dllExtension where comp = display compilerFlavor ++ display compilerVersion -- ------------------------------------------------------------ -- * Platform file extensions -- ------------------------------------------------------------ --- ToDo: This should be determined via autoconf (AC_EXEEXT) --- | Extension for executable files +-- | Default extension for executable files on the current platform. -- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) exeExtension :: String exeExtension = case buildOS of Windows -> "exe" _ -> "" --- TODO: This should be determined via autoconf (AC_OBJEXT) -- | Extension for object files. For GHC the extension is @\"o\"@. objExtension :: String objExtension = "o" diff --git a/Distribution/Simple/BuildTarget.hs b/Distribution/Simple/BuildTarget.hs --- a/Distribution/Simple/BuildTarget.hs +++ b/Distribution/Simple/BuildTarget.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.BuildTargets @@ -14,10 +14,14 @@ -- * Build targets BuildTarget(..), readBuildTargets, + showBuildTarget, + QualLevel(..), + buildTargetComponentName, -- * Parsing user build targets UserBuildTarget, readUserBuildTargets, + showUserBuildTarget, UserBuildTargetProblem(..), reportUserBuildTargetProblems, @@ -28,41 +32,27 @@ ) 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 Distribution.Compat.Binary (Binary) +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Compat.ReadP + ( (+++), (<++) ) + import Data.List - ( nub, stripPrefix, sortBy, groupBy, partition, intercalate ) -import Data.Ord + ( nub, stripPrefix, sortBy, groupBy, partition ) import Data.Maybe ( listToMaybe, catMaybes ) import Data.Either ( partitionEithers ) +import GHC.Generics (Generic) import qualified Data.Map as Map import Control.Monad -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative(..)) -#endif -import Control.Applicative (Alternative(..)) -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP - ( (+++), (<++) ) +import Control.Applicative as AP (Alternative(..), Applicative(..)) import Data.Char ( isSpace, isAlphaNum ) import System.FilePath as FilePath @@ -127,13 +117,19 @@ -- | A specific file within a specific component. -- | BuildTargetFile ComponentName FilePath - deriving (Show,Eq) + deriving (Eq, Show, Generic) +instance Binary BuildTarget --- ------------------------------------------------------------ --- * Do everything --- ------------------------------------------------------------ +buildTargetComponentName :: BuildTarget -> ComponentName +buildTargetComponentName (BuildTargetComponent cn) = cn +buildTargetComponentName (BuildTargetModule cn _) = cn +buildTargetComponentName (BuildTargetFile cn _) = cn +-- | Read a list of user-supplied build target strings and resolve them to +-- 'BuildTarget's according to a 'PackageDescription'. If there are problems +-- with any of the targets e.g. they don't exist or are misformatted, throw an +-- 'IOException'. readBuildTargets :: PackageDescription -> [String] -> IO [BuildTarget] readBuildTargets pkg targetStrs = do let (uproblems, utargets) = readUserBuildTargets targetStrs @@ -226,13 +222,17 @@ ++ " - build foo:Data/Foo.hsc -- file qualified by component" showUserBuildTarget :: UserBuildTarget -> String -showUserBuildTarget = intercalate ":" . components +showUserBuildTarget = intercalate ":" . getComponents where - components (UserBuildTargetSingle s1) = [s1] - components (UserBuildTargetDouble s1 s2) = [s1,s2] - components (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3] + getComponents (UserBuildTargetSingle s1) = [s1] + getComponents (UserBuildTargetDouble s1 s2) = [s1,s2] + getComponents (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3] +showBuildTarget :: QualLevel -> PackageId -> BuildTarget -> String +showBuildTarget ql pkgid bt = + showUserBuildTarget (renderBuildTarget ql bt pkgid) + -- ------------------------------------------------------------ -- * Resolving user targets to build targets -- ------------------------------------------------------------ @@ -265,7 +265,7 @@ resolveBuildTarget pkg userTarget fexists = case findMatch (matchBuildTarget pkg userTarget fexists) of Unambiguous target -> Right target - Ambiguous targets -> Left (BuildTargetAmbigious userTarget targets') + Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets') where targets' = disambiguateBuildTargets (packageId pkg) userTarget targets @@ -287,7 +287,7 @@ -- ^ [expected thing] (actually got) | BuildTargetNoSuch UserBuildTarget [(String, String)] -- ^ [(no such thing, actually got)] - | BuildTargetAmbigious UserBuildTarget [(UserBuildTarget, BuildTarget)] + | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)] deriving Show @@ -366,7 +366,7 @@ mungeThing "file" = "file target" mungeThing thing = thing - case [ (t, ts) | BuildTargetAmbigious t ts <- problems ] of + case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of [] -> return () targets -> die $ unlines @@ -734,10 +734,10 @@ -- -- | A matcher embodies a way to match some input as being some recognised --- value. In particular it deals with multiple and ambigious matches. +-- value. In particular it deals with multiple and ambiguous matches. -- -- There are various matcher primitives ('matchExactly', 'matchInexactly'), --- ways to combine matchers ('ambigiousWith', 'shadows') and finally we can +-- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can -- run a matcher against an input using 'findMatch'. -- @@ -766,7 +766,7 @@ -- | Combine two matchers. Exact matches are used over inexact matches -- but if we have multiple exact, or inexact then the we collect all the --- ambigious matches. +-- ambiguous matches. -- matchPlus :: Match a -> Match a -> Match a matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = @@ -784,7 +784,7 @@ | d1 < d2 = b | otherwise = NoMatch d1 (ms ++ ms') --- | Combine two matchers. This is similar to 'ambigiousWith' with the +-- | Combine two matchers. This is similar to 'ambiguousWith' with the -- difference that an exact match from the left matcher shadows any exact -- match on the right. Inexact matches are still collected however. -- @@ -798,11 +798,12 @@ fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) instance Applicative Match where - pure = return + pure a = ExactMatch 0 [a] (<*>) = ap instance Monad Match where - return a = ExactMatch 0 [a] + return = AP.pure + NoMatch d ms >>= _ = NoMatch d ms ExactMatch d xs >>= f = addDepth d $ foldr matchPlus matchZero (map f xs) @@ -872,18 +873,18 @@ -- possible matches. There may be 'None', a single 'Unambiguous' match or -- you may have an 'Ambiguous' match with several possibilities. -- -findMatch :: Eq b => Match b -> MaybeAmbigious b +findMatch :: Eq b => Match b -> MaybeAmbiguous b findMatch match = case match of NoMatch _ msgs -> None (nub msgs) - ExactMatch _ xs -> checkAmbigious xs - InexactMatch _ xs -> checkAmbigious xs + ExactMatch _ xs -> checkAmbiguous xs + InexactMatch _ xs -> checkAmbiguous xs where - checkAmbigious xs = case nub xs of + checkAmbiguous xs = case nub xs of [x] -> Unambiguous x xs' -> Ambiguous xs' -data MaybeAmbigious a = None [MatchError] | Unambiguous a | Ambiguous [a] +data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a] deriving Show diff --git a/Distribution/Simple/CCompiler.hs b/Distribution/Simple/CCompiler.hs --- a/Distribution/Simple/CCompiler.hs +++ b/Distribution/Simple/CCompiler.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.CCompiler @@ -47,10 +46,8 @@ filenameCDialect ) where -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid - ( Monoid(..) ) -#endif +import Distribution.Compat.Semigroup as Semi + import System.FilePath ( takeExtension ) @@ -66,15 +63,16 @@ 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 + mappend = (Semi.<>) +instance Semigroup CDialect where + C <> anything = anything + ObjectiveC <> CPlusPlus = ObjectiveCPlusPlus + CPlusPlus <> ObjectiveC = ObjectiveCPlusPlus + _ <> ObjectiveCPlusPlus = ObjectiveCPlusPlus + ObjectiveC <> _ = ObjectiveC + CPlusPlus <> _ = CPlusPlus + 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, diff --git a/Distribution/Simple/Command.hs b/Distribution/Simple/Command.hs --- a/Distribution/Simple/Command.hs +++ b/Distribution/Simple/Command.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Command @@ -6,7 +6,7 @@ -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org --- Portability : portable +-- Portability : non-portable (ExistentialQuantification) -- -- This is to do with command line handling. The Cabal command line is -- organised into a number of named sub-commands (much like darcs). The @@ -38,6 +38,11 @@ commandAddAction, noExtraFlags, + -- ** Building lists of commands + CommandType(..), + CommandSpec(..), + commandFromSpec, + -- ** Running commands commandsRun, @@ -60,19 +65,17 @@ ) where -import Control.Monad -import Data.Char (isAlpha, toLower) -import Data.List (sortBy) -import Data.Maybe -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif import qualified Distribution.GetOpt as GetOpt import Distribution.Text - ( Text(disp, parse) ) import Distribution.ParseUtils import Distribution.ReadE -import Distribution.Simple.Utils (die, intercalate) +import Distribution.Simple.Utils + +import Control.Monad +import Data.Char (isAlpha, toLower) +import Data.List (sortBy) +import Data.Maybe +import Data.Monoid as Mon import Text.PrettyPrint ( punctuate, cat, comma, text ) import Text.PrettyPrint as PP ( empty ) @@ -171,14 +174,14 @@ reqArg ad (succeedReadE mkflag) showflag -- | (String -> a) variant of "optArg" -optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) +optArg' :: Mon.Monoid b => ArgPlaceHolder -> (Maybe String -> b) -> (b -> [Maybe String]) -> MkOptDescr (a -> b) (b -> a -> a) a optArg' ad mkflag showflag = optArg ad (succeedReadE (mkflag . Just)) def showflag where def = mkflag Nothing -noArg :: (Eq b, Monoid b) => b -> MkOptDescr (a -> b) (b -> a -> a) a +noArg :: (Eq b) => b -> MkOptDescr (a -> b) (b -> a -> a) a noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags @@ -592,9 +595,26 @@ | Command name description _ NormalCommand <- cmds ] helpCommandUI :: CommandUI () -helpCommandUI = mkCommandUI - "help" - "Help about commands." - ["[FLAGS]", "COMMAND [FLAGS]"] - () - (const []) +helpCommandUI = + (mkCommandUI + "help" + "Help about commands." + ["[FLAGS]", "COMMAND [FLAGS]"] + () + (const [])) + { + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " help help\n" + ++ " Oh, appararently you already know this.\n" + } + +-- | wraps a @CommandUI@ together with a function that turns it into a @Command@. +-- By hiding the type of flags for the UI allows construction of a list of all UIs at the +-- top level of the program. That list can then be used for generation of manual page +-- as well as for executing the selected command. +data CommandSpec action + = forall flags. CommandSpec (CommandUI flags) (CommandUI flags -> Command action) CommandType + +commandFromSpec :: CommandSpec a -> Command a +commandFromSpec (CommandSpec ui action _) = action ui diff --git a/Distribution/Simple/Compiler.hs b/Distribution/Simple/Compiler.hs --- a/Distribution/Simple/Compiler.hs +++ b/Distribution/Simple/Compiler.hs @@ -53,16 +53,25 @@ parmakeSupported, reexportedModulesSupported, renamingPackageFlagsSupported, - packageKeySupported + unifiedIPIDRequired, + packageKeySupported, + unitIdSupported, + + -- * Support for profiling detail levels + ProfDetailLevel(..), + knownProfDetailLevels, + flagToProfDetailLevel, + showProfDetailLevel, ) where import Distribution.Compiler -import Distribution.Version (Version(..)) -import Distribution.Text (display) -import Language.Haskell.Extension (Language(Haskell98), Extension) +import Distribution.Version +import Distribution.Text +import Language.Haskell.Extension +import Distribution.Simple.Utils +import Distribution.Compat.Binary import Control.Monad (liftM) -import Distribution.Compat.Binary (Binary) import Data.List (nub) import qualified Data.Map as M (Map, lookup) import Data.Maybe (catMaybes, isNothing, listToMaybe) @@ -83,7 +92,7 @@ compilerProperties :: M.Map String String -- ^ A key-value map for properties not covered by the above fields. } - deriving (Generic, Show, Read) + deriving (Eq, Generic, Show, Read) instance Binary Compiler @@ -270,10 +279,18 @@ renamingPackageFlagsSupported :: Compiler -> Bool renamingPackageFlagsSupported = ghcSupported "Support thinning and renaming package flags" +-- | Does this compiler have unified IPIDs (so no package keys) +unifiedIPIDRequired :: Compiler -> Bool +unifiedIPIDRequired = ghcSupported "Requires unified installed package IDs" + -- | Does this compiler support package keys? packageKeySupported :: Compiler -> Bool packageKeySupported = ghcSupported "Uses package keys" +-- | Does this compiler support unit IDs? +unitIdSupported :: Compiler -> Bool +unitIdSupported = ghcSupported "Uses unit IDs" + -- | Utility function for GHC only features ghcSupported :: String -> Compiler -> Bool ghcSupported key comp = @@ -285,3 +302,53 @@ case M.lookup key (compilerProperties comp) of Just "YES" -> True _ -> False + +-- ------------------------------------------------------------ +-- * Profiling detail level +-- ------------------------------------------------------------ + +-- | Some compilers (notably GHC) support profiling and can instrument +-- programs so the system can account costs to different functions. There are +-- different levels of detail that can be used for this accounting. +-- For compilers that do not support this notion or the particular detail +-- levels, this is either ignored or just capped to some similar level +-- they do support. +-- +data ProfDetailLevel = ProfDetailNone + | ProfDetailDefault + | ProfDetailExportedFunctions + | ProfDetailToplevelFunctions + | ProfDetailAllFunctions + | ProfDetailOther String + deriving (Eq, Generic, Read, Show) + +instance Binary ProfDetailLevel + +flagToProfDetailLevel :: String -> ProfDetailLevel +flagToProfDetailLevel "" = ProfDetailDefault +flagToProfDetailLevel s = + case lookup (lowercase s) + [ (name, value) + | (primary, aliases, value) <- knownProfDetailLevels + , name <- primary : aliases ] + of Just value -> value + Nothing -> ProfDetailOther s + +knownProfDetailLevels :: [(String, [String], ProfDetailLevel)] +knownProfDetailLevels = + [ ("default", [], ProfDetailDefault) + , ("none", [], ProfDetailNone) + , ("exported-functions", ["exported"], ProfDetailExportedFunctions) + , ("toplevel-functions", ["toplevel", "top"], ProfDetailToplevelFunctions) + , ("all-functions", ["all"], ProfDetailAllFunctions) + ] + +showProfDetailLevel :: ProfDetailLevel -> String +showProfDetailLevel dl = case dl of + ProfDetailNone -> "none" + ProfDetailDefault -> "default" + ProfDetailExportedFunctions -> "exported-functions" + ProfDetailToplevelFunctions -> "toplevel-functions" + ProfDetailAllFunctions -> "all-functions" + ProfDetailOther other -> other + diff --git a/Distribution/Simple/Configure.hs b/Distribution/Simple/Configure.hs --- a/Distribution/Simple/Configure.hs +++ b/Distribution/Simple/Configure.hs @@ -1,1432 +1,1778 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Configure --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This deals with the /configure/ phase. It provides the 'configure' action --- which is given the package description and configure flags. It then tries --- to: configure the compiler; resolves any conditionals in the package --- description; resolve the package dependencies; check if all the extensions --- used by this package are supported by the compiler; check that all the build --- tools are available (including version checks if appropriate); checks for --- any required @pkg-config@ packages (updating the 'BuildInfo' with the --- results) --- --- Then based on all this it saves the info in the 'LocalBuildInfo' and writes --- it out to the @dist\/setup-config@ file. It also displays various details to --- the user, the amount of information displayed depending on the verbosity --- level. - -module Distribution.Simple.Configure (configure, - writePersistBuildConfig, - getConfigStateFile, - getPersistBuildConfig, - checkPersistBuildConfigOutdated, - tryGetPersistBuildConfig, - maybeGetPersistBuildConfig, - localBuildInfoFile, - getInstalledPackages, getPackageDBContents, - configCompiler, configCompilerAux, - configCompilerEx, configCompilerAuxEx, - ccLdOptionsBuildInfo, - checkForeignDeps, - interpretPackageDbFlags, - ConfigStateFileError(..), - tryGetConfigStateFile, - platformDefines, - ) - where - -import Distribution.Compiler - ( CompilerId(..) ) -import Distribution.Utils.NubList -import Distribution.Simple.Compiler - ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion - , compilerInfo - , showCompilerId, unsupportedLanguages, unsupportedExtensions - , PackageDB(..), PackageDBStack, reexportedModulesSupported - , packageKeySupported, renamingPackageFlagsSupported ) -import Distribution.Simple.PreProcess ( platformDefines ) -import Distribution.Package - ( PackageName(PackageName), PackageIdentifier(..), PackageId - , packageName, packageVersion, Package(..) - , Dependency(Dependency), simplifyDependency - , InstalledPackageId(..), thisPackageVersion - , mkPackageKey, PackageKey(..), packageKeyLibraryName ) -import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.InstalledPackageInfo (InstalledPackageInfo, emptyInstalledPackageInfo) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.PackageDescription as PD - ( PackageDescription(..), specVersion, GenericPackageDescription(..) - , Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions - , HookedBuildInfo, updatePackageDescription, allBuildInfo - , Flag(flagName), FlagName(..), TestSuite(..), Benchmark(..) - , ModuleReexport(..) , defaultRenaming ) -import Distribution.ModuleName - ( ModuleName ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription, mapTreeData ) -import Distribution.PackageDescription.Check - ( PackageCheck(..), checkPackage, checkPackageFiles ) -import Distribution.Simple.Program - ( Program(..), ProgramLocation(..), ConfiguredProgram(..) - , ProgramConfiguration, defaultProgramConfiguration - , ProgramSearchPathEntry(..), getProgramSearchPath, setProgramSearchPath - , configureAllKnownPrograms, knownPrograms, lookupKnownProgram - , userSpecifyArgss, userSpecifyPaths - , lookupProgram, requireProgram, requireProgramVersion - , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf ) -import Distribution.Simple.Setup - ( ConfigFlags(..), CopyDest(..), Flag(..), fromFlag, fromFlagOrDefault - , flagToMaybe ) -import Distribution.Simple.InstallDirs - ( InstallDirs(..), defaultInstallDirs, combineInstallDirs ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..) - , LibraryName(..) - , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId - , ComponentName(..), showComponentName, pkgEnabledComponents - , componentBuildInfo, componentName, checkComponentsCyclic ) -import Distribution.Simple.BuildPaths - ( autogenModulesDir ) -import Distribution.Simple.Utils - ( die, warn, info, setupMessage - , createDirectoryIfMissingVerbose, moreRecentFile - , intercalate, cabalVersion - , writeFileAtomic - , withTempFile ) -import Distribution.System - ( OS(..), buildOS, Platform (..), buildPlatform ) -import Distribution.Version - ( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion ) -import Distribution.Verbosity - ( Verbosity, lessVerbose ) - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.JHC as JHC -import qualified Distribution.Simple.LHC as LHC -import qualified Distribution.Simple.UHC as UHC -import qualified Distribution.Simple.HaskellSuite as HaskellSuite - --- Prefer the more generic Data.Traversable.mapM to Prelude.mapM -import Prelude hiding ( mapM ) -import Control.Exception - ( ErrorCall(..), Exception, evaluate, throw, throwIO, try ) -import Control.Monad - ( liftM, when, unless, foldM, filterM ) -import Distribution.Compat.Binary ( decodeOrFailIO, encode ) -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy.Char8 as BLC8 -import Data.List - ( (\\), nub, partition, isPrefixOf, inits, stripPrefix ) -import Data.Maybe - ( isNothing, catMaybes, fromMaybe, isJust ) -import Data.Either - ( partitionEithers ) -import qualified Data.Set as Set -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid - ( Monoid(..) ) -#endif -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Traversable - ( mapM ) -import Data.Typeable -import System.Directory - ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) -import System.FilePath - ( (), isAbsolute ) -import qualified System.Info - ( compilerName, compilerVersion ) -import System.IO - ( hPutStrLn, hClose ) -import Distribution.Text - ( Text(disp), display, simpleParse ) -import Text.PrettyPrint - ( render, (<>), ($+$), char, text, comma - , quotes, punctuate, nest, sep, hsep ) -import Distribution.Compat.Exception ( catchExit, catchIO ) - -data ConfigStateFileError - = ConfigStateFileNoHeader - | ConfigStateFileBadHeader - | ConfigStateFileNoParse - | ConfigStateFileMissing - | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo) - deriving (Typeable) - -instance Show ConfigStateFileError where - show ConfigStateFileNoHeader = - "Saved package config file header is missing. " - ++ "Try re-running the 'configure' command." - show ConfigStateFileBadHeader = - "Saved package config file header is corrupt. " - ++ "Try re-running the 'configure' command." - show ConfigStateFileNoParse = - "Saved package config file body is corrupt. " - ++ "Try re-running the 'configure' command." - show ConfigStateFileMissing = "Run the 'configure' command first." - show (ConfigStateFileBadVersion oldCabal oldCompiler _) = - "You need to re-run the 'configure' command. " - ++ "The version of Cabal being used has changed (was " - ++ display oldCabal ++ ", now " - ++ display currentCabalId ++ ")." - ++ badCompiler - where - badCompiler - | oldCompiler == currentCompilerId = "" - | otherwise = - " Additionally the compiler is different (was " - ++ display oldCompiler ++ ", now " - ++ display currentCompilerId - ++ ") which is probably the cause of the problem." - -instance Exception ConfigStateFileError - -getConfigStateFile :: FilePath -> IO LocalBuildInfo -getConfigStateFile filename = do - exists <- doesFileExist filename - unless exists $ throwIO ConfigStateFileMissing - -- Read the config file into a strict ByteString to avoid problems with - -- lazy I/O, then convert to lazy because the binary package needs that. - contents <- BS.readFile filename - let (header, body) = BLC8.span (/='\n') (BLC8.fromChunks [contents]) - - headerParseResult <- try $ evaluate $ parseHeader header - let (cabalId, compId) = - case headerParseResult of - Left (ErrorCall _) -> throw ConfigStateFileBadHeader - Right x -> x - - let getStoredValue = do - result <- decodeOrFailIO (BLC8.tail body) - case result of - Left _ -> throw ConfigStateFileNoParse - Right x -> return x - deferErrorIfBadVersion act - | cabalId /= currentCabalId = do - eResult <- try act - throw $ ConfigStateFileBadVersion cabalId compId eResult - | otherwise = act - deferErrorIfBadVersion getStoredValue - -tryGetConfigStateFile :: FilePath - -> IO (Either ConfigStateFileError LocalBuildInfo) -tryGetConfigStateFile = try . getConfigStateFile - --- |Try to read the 'localBuildInfoFile'. -tryGetPersistBuildConfig :: FilePath - -> IO (Either ConfigStateFileError LocalBuildInfo) -tryGetPersistBuildConfig = try . getPersistBuildConfig - --- | Read the 'localBuildInfoFile'. Throw an exception if the file is --- missing, if the file cannot be read, or if the file was created by an older --- version of Cabal. -getPersistBuildConfig :: FilePath -> IO LocalBuildInfo -getPersistBuildConfig = getConfigStateFile . localBuildInfoFile - --- |Try to read the 'localBuildInfoFile'. -maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo) -maybeGetPersistBuildConfig = - liftM (either (const Nothing) Just) . tryGetPersistBuildConfig - --- |After running configure, output the 'LocalBuildInfo' to the --- 'localBuildInfoFile'. -writePersistBuildConfig :: FilePath -> LocalBuildInfo -> IO () -writePersistBuildConfig distPref lbi = do - createDirectoryIfMissing False distPref - writeFileAtomic (localBuildInfoFile distPref) $ - BLC8.unlines [showHeader pkgId, encode lbi] - where - pkgId = packageId $ localPkgDescr lbi - -currentCabalId :: PackageIdentifier -currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion - -currentCompilerId :: PackageIdentifier -currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName) - System.Info.compilerVersion - -parseHeader :: ByteString -> (PackageIdentifier, PackageIdentifier) -parseHeader header = case BLC8.words header of - ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId, "using", compId] -> - fromMaybe (throw ConfigStateFileBadHeader) $ do - _ <- simpleParse (BLC8.unpack pkgId) :: Maybe PackageIdentifier - cabalId' <- simpleParse (BLC8.unpack cabalId) - compId' <- simpleParse (BLC8.unpack compId) - return (cabalId', compId') - _ -> throw ConfigStateFileNoHeader - -showHeader :: PackageIdentifier -> ByteString -showHeader pkgId = BLC8.unwords - [ "Saved", "package", "config", "for" - , BLC8.pack $ display pkgId - , "written", "by" - , BLC8.pack $ display currentCabalId - , "using" - , BLC8.pack $ display currentCompilerId - ] - --- |Check that localBuildInfoFile is up-to-date with respect to the --- .cabal file. -checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool -checkPersistBuildConfigOutdated distPref pkg_descr_file = do - pkg_descr_file `moreRecentFile` (localBuildInfoFile distPref) - --- |@dist\/setup-config@ -localBuildInfoFile :: FilePath -> FilePath -localBuildInfoFile distPref = distPref "setup-config" - --- ----------------------------------------------------------------------------- --- * Configuration --- ----------------------------------------------------------------------------- - --- |Perform the \"@.\/setup configure@\" action. --- Returns the @.setup-config@ file. -configure :: (GenericPackageDescription, HookedBuildInfo) - -> ConfigFlags -> IO LocalBuildInfo -configure (pkg_descr0, pbi) cfg - = do let distPref = fromFlag (configDistPref cfg) - buildDir' = distPref "build" - verbosity = fromFlag (configVerbosity cfg) - - setupMessage verbosity "Configuring" (packageId pkg_descr0) - - unless (configLibCoverage cfg == NoFlag) $ do - let enable | fromFlag (configLibCoverage cfg) = "enable" - | otherwise = "disable" - warn verbosity - ("The flag --" ++ enable ++ "-library-coverage is deprecated. " - ++ "Please use --" ++ enable ++ "-coverage instead.") - - createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref - - let programsConfig = mkProgramsConfig cfg (configPrograms cfg) - userInstall = fromFlag (configUserInstall cfg) - packageDbs = interpretPackageDbFlags userInstall - (configPackageDBs cfg) - - -- detect compiler - (comp, compPlatform, programsConfig') <- configCompilerEx - (flagToMaybe $ configHcFlavor cfg) - (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg) - programsConfig (lessVerbose verbosity) - let version = compilerVersion comp - flavor = compilerFlavor comp - - -- Create a PackageIndex that makes *any libraries that might be* - -- defined internally to this package look like installed packages, in - -- case an executable should refer to any of them as dependencies. - -- - -- It must be *any libraries that might be* defined rather than the - -- actual definitions, because these depend on conditionals in the .cabal - -- file, and we haven't resolved them yet. finalizePackageDescription - -- does the resolution of conditionals, and it takes internalPackageSet - -- as part of its input. - -- - -- Currently a package can define no more than one library (which has - -- the same name as the package) but we could extend this later. - -- If we later allowed private internal libraries, then here we would - -- need to pre-scan the conditional data to make a list of all private - -- libraries that could possibly be defined by the .cabal file. - let pid = packageId pkg_descr0 - internalPackage = emptyInstalledPackageInfo { - --TODO: should use a per-compiler method to map the source - -- package ID into an installed package id we can use - -- for the internal package set. The open-codes use of - -- InstalledPackageId . display here is a hack. - Installed.installedPackageId = - InstalledPackageId $ display $ pid, - Installed.sourcePackageId = pid - } - internalPackageSet = PackageIndex.fromList [internalPackage] - installedPackageSet <- getInstalledPackages (lessVerbose verbosity) comp - packageDbs programsConfig' - - (allConstraints, requiredDepsMap) <- either die return $ - combinedConstraints (configConstraints cfg) - (configDependencies cfg) - installedPackageSet - - let exactConf = fromFlagOrDefault False (configExactConfiguration cfg) - -- Constraint test function for the solver - dependencySatisfiable d@(Dependency depName verRange) - | exactConf = - -- When we're given '--exact-configuration', we assume that all - -- dependencies and flags are exactly specified on the command - -- line. Thus we only consult the 'requiredDepsMap'. Note that - -- we're not doing the version range check, so if there's some - -- dependency that wasn't specified on the command line, - -- 'finalizePackageDescription' will fail. - -- - -- TODO: mention '--exact-configuration' in the error message - -- when this fails? - (depName `Map.member` requiredDepsMap) || isInternalDep - - | otherwise = - -- Normal operation: just look up dependency in the package - -- index. - not . null . PackageIndex.lookupDependency pkgs' $ d - where - pkgs' = PackageIndex.insert internalPackage installedPackageSet - isInternalDep = pkgName pid == depName - && pkgVersion pid `withinRange` verRange - enableTest t = t { testEnabled = fromFlag (configTests cfg) } - flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t)) - (condTestSuites pkg_descr0) - enableBenchmark bm = bm { benchmarkEnabled = - fromFlag (configBenchmarks cfg) } - flaggedBenchmarks = map (\(n, bm) -> - (n, mapTreeData enableBenchmark bm)) - (condBenchmarks pkg_descr0) - pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests - , condBenchmarks = flaggedBenchmarks } - - (pkg_descr0', flags) <- - case finalizePackageDescription - (configConfigurationsFlags cfg) - dependencySatisfiable - compPlatform - (compilerInfo comp) - allConstraints - pkg_descr0'' - of Right r -> return r - Left missing -> - die $ "At least the following dependencies are missing:\n" - ++ (render . nest 4 . sep . punctuate comma - . map (disp . simplifyDependency) - $ missing) - - -- Sanity check: if '--exact-configuration' was given, ensure that the - -- complete flag assignment was specified on the command line. - when exactConf $ do - let cmdlineFlags = map fst (configConfigurationsFlags cfg) - allFlags = map flagName . genPackageFlags $ pkg_descr0 - diffFlags = allFlags \\ cmdlineFlags - when (not . null $ diffFlags) $ - die $ "'--exact-conf' was given, " - ++ "but the following flags were not specified: " - ++ intercalate ", " (map show diffFlags) - - -- add extra include/lib dirs as specified in cfg - -- we do it here so that those get checked too - let pkg_descr = addExtraIncludeLibDirs pkg_descr0' - - unless (renamingPackageFlagsSupported comp || - and [ rn == defaultRenaming - | bi <- allBuildInfo pkg_descr - , rn <- Map.elems (targetBuildRenaming bi)]) $ - die $ "Your compiler does not support thinning and renaming on " - ++ "package flags. To use this feature you probably must use " - ++ "GHC 7.9 or later." - - when (not (null flags)) $ - info verbosity $ "Flags chosen: " - ++ intercalate ", " [ name ++ "=" ++ display value - | (FlagName name, value) <- flags ] - - when (maybe False (not.null.PD.reexportedModules) (PD.library pkg_descr) - && not (reexportedModulesSupported comp)) $ do - die $ "Your compiler does not support module re-exports. To use " - ++ "this feature you probably must use GHC 7.9 or later." - - checkPackageProblems verbosity pkg_descr0 - (updatePackageDescription pbi pkg_descr) - - -- Handle hole instantiation - (holeDeps, hole_insts) <- configureInstantiateWith pkg_descr cfg installedPackageSet - - let selectDependencies :: [Dependency] -> - ([FailedDependency], [ResolvedDependency]) - selectDependencies = - (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ])) - . map (selectDependency internalPackageSet installedPackageSet - requiredDepsMap) - - (failedDeps, allPkgDeps) = - selectDependencies (buildDepends pkg_descr) - - internalPkgDeps = [ pkgid - | InternalDependency _ pkgid <- allPkgDeps ] - externalPkgDeps = [ pkg - | ExternalDependency _ pkg <- allPkgDeps ] - - when (not (null internalPkgDeps) - && not (newPackageDepsBehaviour pkg_descr)) $ - die $ "The field 'build-depends: " - ++ intercalate ", " (map (display . packageName) internalPkgDeps) - ++ "' refers to a library which is defined within the same " - ++ "package. To use this feature the package must specify at " - ++ "least 'cabal-version: >= 1.8'." - - reportFailedDependencies failedDeps - reportSelectedDependencies verbosity allPkgDeps - - let installDeps = Map.elems - . Map.fromList - . map (\v -> (Installed.installedPackageId v, v)) - $ externalPkgDeps ++ holeDeps - - packageDependsIndex <- - case PackageIndex.dependencyClosure installedPackageSet - (map Installed.installedPackageId installDeps) of - Left packageDependsIndex -> return packageDependsIndex - Right broken -> - die $ "The following installed packages are broken because other" - ++ " packages they depend on are missing. These broken " - ++ "packages must be rebuilt before they can be used.\n" - ++ unlines [ "package " - ++ display (packageId pkg) - ++ " is broken due to missing package " - ++ intercalate ", " (map display deps) - | (pkg, deps) <- broken ] - - let pseudoTopPkg = emptyInstalledPackageInfo { - Installed.installedPackageId = - InstalledPackageId (display (packageId pkg_descr)), - Installed.sourcePackageId = packageId pkg_descr, - Installed.depends = - map Installed.installedPackageId installDeps - } - case PackageIndex.dependencyInconsistencies - . PackageIndex.insert pseudoTopPkg - $ packageDependsIndex of - [] -> return () - inconsistencies -> - warn verbosity $ - "This package indirectly depends on multiple versions of the same " - ++ "package. This is highly likely to cause a compile failure.\n" - ++ unlines [ "package " ++ display pkg ++ " requires " - ++ display (PackageIdentifier name ver) - | (name, uses) <- inconsistencies - , (pkg, ver) <- uses ] - - -- Calculate the package key. We're going to store it in LocalBuildInfo - -- canonically, but ComponentsLocalBuildInfo also needs to know about it - -- XXX Do we need the internal deps? - -- NB: does *not* include holeDeps! - let pkg_key = mkPackageKey (packageKeySupported comp) - (package pkg_descr) - (map Installed.packageKey externalPkgDeps) - (map (\(k,(p,m)) -> (k,(Installed.packageKey p,m))) hole_insts) - - -- internal component graph - buildComponents <- - case mkComponentsGraph pkg_descr internalPkgDeps of - Left componentCycle -> reportComponentCycle componentCycle - Right components -> - case mkComponentsLocalBuildInfo packageDependsIndex pkg_descr - internalPkgDeps externalPkgDeps holeDeps - (Map.fromList hole_insts) - pkg_key components of - Left problems -> reportModuleReexportProblems problems - 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 langs = unsupportedLanguages comp langlist - when (not (null langs)) $ - die $ "The package " ++ display (packageId pkg_descr0) - ++ " requires the following languages which are not " - ++ "supported by " ++ display (compilerId comp) ++ ": " - ++ intercalate ", " (map display langs) - let extlist = nub $ concatMap allExtensions (allBuildInfo pkg_descr) - let exts = unsupportedExtensions comp extlist - when (not (null exts)) $ - die $ "The package " ++ display (packageId pkg_descr0) - ++ " requires the following language extensions which are not " - ++ "supported by " ++ display (compilerId comp) ++ ": " - ++ intercalate ", " (map display exts) - - -- configured known/required programs & external build tools - -- exclude build-tool deps on "internal" exes in the same package - let requiredBuildTools = - [ buildTool - | let exeNames = map exeName (executables pkg_descr) - , bi <- allBuildInfo pkg_descr - , buildTool@(Dependency (PackageName toolName) reqVer) - <- buildTools bi - , let isInternal = - toolName `elem` exeNames - -- we assume all internal build-tools are - -- versioned with the package: - && packageVersion pkg_descr `withinRange` reqVer - , not isInternal ] - - programsConfig'' <- - configureAllKnownPrograms (lessVerbose verbosity) programsConfig' - >>= configureRequiredPrograms verbosity requiredBuildTools - - (pkg_descr', programsConfig''') <- - configurePkgconfigPackages verbosity pkg_descr programsConfig'' - - split_objs <- - if not (fromFlag $ configSplitObjs cfg) - then return False - else case flavor of - GHC | version >= Version [6,5] [] -> return True - GHCJS -> return True - _ -> do warn verbosity - ("this compiler does not support " ++ - "--enable-split-objs; ignoring") - return False - - let ghciLibByDefault = - case compilerId comp of - CompilerId GHC _ -> - -- If ghc is non-dynamic, then ghci needs object files, - -- so we build one by default. - -- - -- Technically, archive files should be sufficient for ghci, - -- but because of GHC bug #8942, it has never been safe to - -- rely on them. By the time that bug was fixed, ghci had - -- been changed to read shared libraries instead of archive - -- files (see next code block). - not (GHC.isDynamic comp) - CompilerId GHCJS _ -> - not (GHCJS.isDynamic comp) - _ -> False - - let sharedLibsByDefault - | fromFlag (configDynExe cfg) = - -- build a shared library if dynamically-linked - -- executables are requested - True - | otherwise = case compilerId comp of - CompilerId GHC _ -> - -- if ghc is dynamic, then ghci needs a shared - -- library, so we build one by default. - GHC.isDynamic comp - CompilerId GHCJS _ -> - GHCJS.isDynamic comp - _ -> False - withSharedLib_ = - -- build shared libraries if required by GHC or by the - -- executable linking mode, but allow the user to force - -- building only static library archives with - -- --disable-shared. - fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg - withDynExe_ = fromFlag $ configDynExe cfg - when (withDynExe_ && not withSharedLib_) $ warn verbosity $ - "Executables will use dynamic linking, but a shared library " - ++ "is not being built. Linking will fail if any executables " - ++ "depend on the library." - - let withProfExe_ = fromFlagOrDefault False $ configProfExe cfg - withProfLib_ = fromFlagOrDefault withProfExe_ $ configProfLib cfg - when (withProfExe_ && not withProfLib_) $ warn verbosity $ - "Executables will be built with profiling, but library " - ++ "profiling is disabled. Linking will fail if any executables " - ++ "depend on the library." - - let configCoverage_ = - mappend (configCoverage cfg) (configLibCoverage cfg) - - cfg' = cfg { configCoverage = configCoverage_ } - - reloc <- - if not (fromFlag $ configRelocatable cfg) - then return False - else return True - - let lbi = LocalBuildInfo { - configFlags = cfg', - extraConfigArgs = [], -- Currently configure does not - -- take extra args, but if it - -- did they would go here. - installDirTemplates = installDirs, - compiler = comp, - hostPlatform = compPlatform, - buildDir = buildDir', - componentsConfigs = buildComponents, - installedPkgs = packageDependsIndex, - pkgDescrFile = Nothing, - localPkgDescr = pkg_descr', - pkgKey = pkg_key, - instantiatedWith = hole_insts, - withPrograms = programsConfig''', - withVanillaLib = fromFlag $ configVanillaLib cfg, - withProfLib = withProfLib_, - withSharedLib = withSharedLib_, - withDynExe = withDynExe_, - withProfExe = withProfExe_, - withOptimization = fromFlag $ configOptimization cfg, - withDebugInfo = fromFlag $ configDebugInfo cfg, - withGHCiLib = fromFlagOrDefault ghciLibByDefault $ - configGHCiLib cfg, - splitObjs = split_objs, - stripExes = fromFlag $ configStripExes cfg, - stripLibs = fromFlag $ configStripLibs cfg, - withPackageDB = packageDbs, - progPrefix = fromFlag $ configProgPrefix cfg, - progSuffix = fromFlag $ configProgSuffix cfg, - relocatable = reloc - } - - when reloc (checkRelocatable verbosity pkg_descr lbi) - - let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest - relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi - - unless (isAbsolute (prefix dirs)) $ die $ - "expected an absolute directory name for --prefix: " ++ prefix dirs - - info verbosity $ "Using " ++ display currentCabalId - ++ " compiled by " ++ display currentCompilerId - info verbosity $ "Using compiler: " ++ showCompilerId comp - info verbosity $ "Using install prefix: " ++ prefix dirs - - let dirinfo name dir isPrefixRelative = - info verbosity $ name ++ " installed in: " ++ dir ++ relNote - where relNote = case buildOS of - Windows | not (hasLibs pkg_descr) - && isNothing isPrefixRelative - -> " (fixed location)" - _ -> "" - - dirinfo "Binaries" (bindir dirs) (bindir relative) - dirinfo "Libraries" (libdir dirs) (libdir relative) - dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative) - dirinfo "Data files" (datadir dirs) (datadir relative) - dirinfo "Documentation" (docdir dirs) (docdir relative) - dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative) - - sequence_ [ reportProgram verbosity prog configuredProg - | (prog, configuredProg) <- knownPrograms programsConfig''' ] - - return lbi - - where - addExtraIncludeLibDirs pkg_descr = - let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg - , PD.includeDirs = configExtraIncludeDirs cfg} - modifyLib l = l{ libBuildInfo = libBuildInfo l - `mappend` extraBi } - modifyExecutable e = e{ buildInfo = buildInfo e - `mappend` extraBi} - in pkg_descr{ library = modifyLib `fmap` library pkg_descr - , executables = modifyExecutable `map` - executables pkg_descr} - -mkProgramsConfig :: ConfigFlags -> ProgramConfiguration -> ProgramConfiguration -mkProgramsConfig cfg initialProgramsConfig = programsConfig - where - programsConfig = userSpecifyArgss (configProgramArgs cfg) - . userSpecifyPaths (configProgramPaths cfg) - . setProgramSearchPath searchpath - $ initialProgramsConfig - searchpath = getProgramSearchPath (initialProgramsConfig) - ++ map ProgramSearchPathDir (fromNubList $ configProgramPathExtra cfg) - --- ----------------------------------------------------------------------------- --- Configuring package dependencies - -reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () -reportProgram verbosity prog Nothing - = info verbosity $ "No " ++ programName prog ++ " found" -reportProgram verbosity prog (Just configuredProg) - = info verbosity $ "Using " ++ programName prog ++ version ++ location - where location = case programLocation configuredProg of - FoundOnSystem p -> " found on system at: " ++ p - UserSpecified p -> " given by user at: " ++ p - version = case programVersion configuredProg of - Nothing -> "" - Just v -> " version " ++ display v - -hackageUrl :: String -hackageUrl = "http://hackage.haskell.org/package/" - -data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo - | InternalDependency Dependency PackageId -- should be a - -- lib name - -data FailedDependency = DependencyNotExists PackageName - | DependencyNoVersion Dependency - --- | Test for a package dependency and record the version we have installed. -selectDependency :: InstalledPackageIndex -- ^ Internally defined packages - -> InstalledPackageIndex -- ^ Installed packages - -> Map PackageName InstalledPackageInfo - -- ^ Packages for which we have been given specific deps to use - -> Dependency - -> Either FailedDependency ResolvedDependency -selectDependency internalIndex installedIndex requiredDepsMap - dep@(Dependency pkgname vr) = - -- If the dependency specification matches anything in the internal package - -- index, then we prefer that match to anything in the second. - -- For example: - -- - -- Name: MyLibrary - -- Version: 0.1 - -- Library - -- .. - -- Executable my-exec - -- build-depends: MyLibrary - -- - -- We want "build-depends: MyLibrary" always to match the internal library - -- even if there is a newer installed library "MyLibrary-0.2". - -- However, "build-depends: MyLibrary >= 0.2" should match the installed one. - case PackageIndex.lookupPackageName internalIndex pkgname of - [(_,[pkg])] | packageVersion pkg `withinRange` vr - -> Right $ InternalDependency dep (packageId pkg) - - _ -> case Map.lookup pkgname requiredDepsMap of - -- If we know the exact pkg to use, then use it. - Just pkginstance -> Right (ExternalDependency dep pkginstance) - -- Otherwise we just pick an arbitrary instance of the latest version. - Nothing -> case PackageIndex.lookupDependency installedIndex dep of - [] -> Left $ DependencyNotExists pkgname - pkgs -> Right $ ExternalDependency dep $ - case last pkgs of - (_ver, pkginstances) -> head pkginstances - -reportSelectedDependencies :: Verbosity - -> [ResolvedDependency] -> IO () -reportSelectedDependencies verbosity deps = - info verbosity $ unlines - [ "Dependency " ++ display (simplifyDependency dep) - ++ ": using " ++ display pkgid - | resolved <- deps - , let (dep, pkgid) = case resolved of - ExternalDependency dep' pkg' -> (dep', packageId pkg') - InternalDependency dep' pkgid' -> (dep', pkgid') ] - -reportFailedDependencies :: [FailedDependency] -> IO () -reportFailedDependencies [] = return () -reportFailedDependencies failed = - die (intercalate "\n\n" (map reportFailedDependency failed)) - - where - reportFailedDependency (DependencyNotExists pkgname) = - "there is no version of " ++ display pkgname ++ " installed.\n" - ++ "Perhaps you need to download and install it from\n" - ++ hackageUrl ++ display pkgname ++ "?" - - reportFailedDependency (DependencyNoVersion dep) = - "cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n" - -getInstalledPackages :: Verbosity -> Compiler - -> PackageDBStack -> ProgramConfiguration - -> IO InstalledPackageIndex -getInstalledPackages verbosity comp packageDBs progconf = do - when (null packageDBs) $ - die $ "No package databases have been specified. If you use " - ++ "--package-db=clear, you must follow it with --package-db= " - ++ "with 'global', 'user' or a specific file." - - info verbosity "Reading installed packages..." - case compilerFlavor comp of - GHC -> GHC.getInstalledPackages verbosity packageDBs progconf - GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs progconf - JHC -> JHC.getInstalledPackages verbosity packageDBs progconf - LHC -> LHC.getInstalledPackages verbosity packageDBs progconf - UHC -> UHC.getInstalledPackages verbosity comp packageDBs progconf - HaskellSuite {} -> - HaskellSuite.getInstalledPackages verbosity packageDBs progconf - flv -> die $ "don't know how to find the installed packages for " - ++ display flv - --- | Like 'getInstalledPackages', but for a single package DB. -getPackageDBContents :: Verbosity -> Compiler - -> PackageDB -> ProgramConfiguration - -> IO InstalledPackageIndex -getPackageDBContents verbosity comp packageDB progconf = do - info verbosity "Reading installed packages..." - case compilerFlavor comp of - GHC -> GHC.getPackageDBContents verbosity packageDB progconf - GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progconf - -- For other compilers, try to fall back on 'getInstalledPackages'. - _ -> getInstalledPackages verbosity comp [packageDB] progconf - - --- | The user interface specifies the package dbs to use with a combination of --- @--global@, @--user@ and @--package-db=global|user|clear|$file@. --- This function combines the global/user flag and interprets the package-db --- flag into a single package db stack. --- -interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack -interpretPackageDbFlags userInstall specificDBs = - extra initialStack specificDBs - where - initialStack | userInstall = [GlobalPackageDB, UserPackageDB] - | otherwise = [GlobalPackageDB] - - extra dbs' [] = dbs' - extra _ (Nothing:dbs) = extra [] dbs - extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs - -newPackageDepsBehaviourMinVersion :: Version -newPackageDepsBehaviourMinVersion = Version [1,7,1] [] - --- In older cabal versions, there was only one set of package dependencies for --- the whole package. In this version, we can have separate dependencies per --- target, but we only enable this behaviour if the minimum cabal version --- specified is >= a certain minimum. Otherwise, for compatibility we use the --- old behaviour. -newPackageDepsBehaviour :: PackageDescription -> Bool -newPackageDepsBehaviour pkg = - specVersion pkg >= newPackageDepsBehaviourMinVersion - --- We are given both --constraint="foo < 2.0" style constraints and also --- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581". --- --- When finalising the package we have to take into account the specific --- installed deps we've been given, and the finalise function expects --- constraints, so we have to translate these deps into version constraints. --- --- But after finalising we then have to make sure we pick the right specific --- deps in the end. So we still need to remember which installed packages to --- pick. -combinedConstraints :: [Dependency] -> - [(PackageName, InstalledPackageId)] -> - InstalledPackageIndex -> - Either String ([Dependency], - Map PackageName InstalledPackageInfo) -combinedConstraints constraints dependencies installedPackages = do - - when (not (null badInstalledPackageIds)) $ - Left $ render $ text "The following package dependencies were requested" - $+$ nest 4 (dispDependencies badInstalledPackageIds) - $+$ text "however the given installed package instance does not exist." - - when (not (null badNames)) $ - Left $ render $ text "The following package dependencies were requested" - $+$ nest 4 (dispDependencies badNames) - $+$ text "however the installed package's name does not match the name given." - - --TODO: we don't check that all dependencies are used! - - return (allConstraints, idConstraintMap) - - where - allConstraints :: [Dependency] - allConstraints = constraints - ++ [ thisPackageVersion (packageId pkg) - | (_, _, Just pkg) <- dependenciesPkgInfo ] - - idConstraintMap :: Map PackageName InstalledPackageInfo - idConstraintMap = Map.fromList - [ (packageName pkg, pkg) - | (_, _, Just pkg) <- dependenciesPkgInfo ] - - -- The dependencies along with the installed package info, if it exists - dependenciesPkgInfo :: [(PackageName, InstalledPackageId, - Maybe InstalledPackageInfo)] - dependenciesPkgInfo = - [ (pkgname, ipkgid, mpkg) - | (pkgname, ipkgid) <- dependencies - , let mpkg = PackageIndex.lookupInstalledPackageId - installedPackages ipkgid - ] - - -- If we looked up a package specified by an installed package id - -- (i.e. someone has written a hash) and didn't find it then it's - -- an error. - badInstalledPackageIds = - [ (pkgname, ipkgid) - | (pkgname, ipkgid, Nothing) <- dependenciesPkgInfo ] - - -- If someone has written e.g. - -- --dependency="foo=MyOtherLib-1.0-07...5bf30" then they have - -- probably made a mistake. - badNames = - [ (requestedPkgName, ipkgid) - | (requestedPkgName, ipkgid, Just pkg) <- dependenciesPkgInfo - , let foundPkgName = packageName pkg - , requestedPkgName /= foundPkgName ] - - dispDependencies deps = - hsep [ text "--dependency=" - <> quotes (disp pkgname <> char '=' <> disp ipkgid) - | (pkgname, ipkgid) <- deps ] - --- ----------------------------------------------------------------------------- --- Configuring hole instantiation - -configureInstantiateWith :: PackageDescription - -> ConfigFlags - -> InstalledPackageIndex -- ^ installed packages - -> IO ([InstalledPackageInfo], - [(ModuleName, (InstalledPackageInfo, ModuleName))]) -configureInstantiateWith pkg_descr cfg installedPackageSet = do - -- Holes: First, check and make sure the provided instantiation covers - -- all the holes we know about. Indefinite package installation is - -- not handled at all at this point. - -- NB: We union together /all/ of the requirements when calculating - -- the package key. - -- NB: For now, we assume that dependencies don't contribute signatures. - -- This will be handled by cabal-install; as far as ./Setup is - -- concerned, the most important thing is to be provided correctly - -- built dependencies. - let signatures = - maybe [] (\lib -> requiredSignatures lib ++ exposedSignatures lib) - (PD.library pkg_descr) - signatureSet = Set.fromList signatures - instantiateMap = Map.fromList (configInstantiateWith cfg) - missing_impls = filter (not . flip Map.member instantiateMap) signatures - hole_insts0 = filter (\(k,_) -> Set.member k signatureSet) (configInstantiateWith cfg) - - when (not (null missing_impls)) $ - die $ "Missing signature implementations for these modules: " - ++ intercalate ", " (map display missing_impls) - - -- Holes: Next, we need to make sure we have packages to actually - -- provide the implementations we're talking about. This is on top - -- of the normal dependency resolution process. - -- TODO: internal dependencies (e.g. the test package depending on the - -- main library) is not currently supported - let selectHoleDependency (k,(i,m)) = - case PackageIndex.lookupInstalledPackageId installedPackageSet i of - Just pkginst -> Right (k,(pkginst, m)) - Nothing -> Left i - (failed_hmap, hole_insts) = partitionEithers (map selectHoleDependency hole_insts0) - holeDeps = map (fst.snd) hole_insts -- could have dups - - -- Holes: Finally, any dependencies selected this way have to be - -- included in the allPkgs index, as well as the buildComponents. - -- But don't report these as potential inconsistencies! - - when (not (null failed_hmap)) $ - die $ "Could not resolve these package IDs (from signature implementations): " - ++ intercalate ", " (map display failed_hmap) - - return (holeDeps, hole_insts) - --- ----------------------------------------------------------------------------- --- Configuring program dependencies - -configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration - -> IO ProgramConfiguration -configureRequiredPrograms verbosity deps conf = - foldM (configureRequiredProgram verbosity) conf deps - -configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency - -> IO ProgramConfiguration -configureRequiredProgram verbosity conf - (Dependency (PackageName progName) verRange) = - case lookupKnownProgram progName conf of - Nothing -> die ("Unknown build tool " ++ progName) - Just prog - -- requireProgramVersion always requires the program have a version - -- but if the user says "build-depends: foo" ie no version constraint - -- then we should not fail if we cannot discover the program version. - | verRange == anyVersion -> do - (_, conf') <- requireProgram verbosity prog conf - return conf' - | otherwise -> do - (_, _, conf') <- requireProgramVersion verbosity prog verRange conf - return conf' - --- ----------------------------------------------------------------------------- --- Configuring pkg-config package dependencies - -configurePkgconfigPackages :: Verbosity -> PackageDescription - -> ProgramConfiguration - -> IO (PackageDescription, ProgramConfiguration) -configurePkgconfigPackages verbosity pkg_descr conf - | null allpkgs = return (pkg_descr, conf) - | otherwise = do - (_, _, conf') <- requireProgramVersion - (lessVerbose verbosity) pkgConfigProgram - (orLaterVersion $ Version [0,9,0] []) conf - mapM_ requirePkg allpkgs - lib' <- mapM addPkgConfigBILib (library pkg_descr) - exes' <- mapM addPkgConfigBIExe (executables pkg_descr) - tests' <- mapM addPkgConfigBITest (testSuites pkg_descr) - benches' <- mapM addPkgConfigBIBench (benchmarks pkg_descr) - let pkg_descr' = pkg_descr { library = lib', executables = exes', - testSuites = tests', benchmarks = benches' } - return (pkg_descr', conf') - - where - allpkgs = concatMap pkgconfigDepends (allBuildInfo pkg_descr) - pkgconfig = rawSystemProgramStdoutConf (lessVerbose verbosity) - pkgConfigProgram conf - - requirePkg dep@(Dependency (PackageName pkg) range) = do - version <- pkgconfig ["--modversion", pkg] - `catchIO` (\_ -> die notFound) - `catchExit` (\_ -> die notFound) - case simpleParse version of - Nothing -> die "parsing output of pkg-config --modversion failed" - Just v | not (withinRange v range) -> die (badVersion v) - | otherwise -> info verbosity (depSatisfied v) - where - notFound = "The pkg-config package '" ++ pkg ++ "'" - ++ versionRequirement - ++ " is required but it could not be found." - badVersion v = "The pkg-config package '" ++ pkg ++ "'" - ++ versionRequirement - ++ " is required but the version installed on the" - ++ " system is version " ++ display v - depSatisfied v = "Dependency " ++ display dep - ++ ": using version " ++ display v - - versionRequirement - | isAnyVersion range = "" - | otherwise = " version " ++ display range - - -- Adds pkgconfig dependencies to the build info for a component - addPkgConfigBI compBI setCompBI comp = do - bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp)) - return $ setCompBI comp (compBI comp `mappend` bi) - - -- Adds pkgconfig dependencies to the build info for a library - addPkgConfigBILib = addPkgConfigBI libBuildInfo $ - \lib bi -> lib { libBuildInfo = bi } - - -- Adds pkgconfig dependencies to the build info for an executable - addPkgConfigBIExe = addPkgConfigBI buildInfo $ - \exe bi -> exe { buildInfo = bi } - - -- Adds pkgconfig dependencies to the build info for a test suite - addPkgConfigBITest = addPkgConfigBI testBuildInfo $ - \test bi -> test { testBuildInfo = bi } - - -- Adds pkgconfig dependencies to the build info for a benchmark - addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $ - \bench bi -> bench { benchmarkBuildInfo = bi } - - pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo - pkgconfigBuildInfo [] = return mempty - pkgconfigBuildInfo pkgdeps = do - let pkgs = nub [ display pkg | Dependency pkg _ <- pkgdeps ] - ccflags <- pkgconfig ("--cflags" : pkgs) - ldflags <- pkgconfig ("--libs" : pkgs) - return (ccLdOptionsBuildInfo (words ccflags) (words ldflags)) - --- | Makes a 'BuildInfo' from C compiler and linker flags. --- --- This can be used with the output from configuration programs like pkg-config --- and similar package-specific programs like mysql-config, freealut-config etc. --- For example: --- --- > ccflags <- rawSystemProgramStdoutConf verbosity prog conf ["--cflags"] --- > ldflags <- rawSystemProgramStdoutConf verbosity prog conf ["--libs"] --- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags)) --- -ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo -ccLdOptionsBuildInfo cflags ldflags = - let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags - (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags - (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' - in mempty { - PD.includeDirs = map (drop 2) includeDirs', - PD.extraLibs = map (drop 2) extraLibs', - PD.extraLibDirs = map (drop 2) extraLibDirs', - PD.ccOptions = cflags', - PD.ldOptions = ldflags'' - } - --- ----------------------------------------------------------------------------- --- Determining the compiler details - -configCompilerAuxEx :: ConfigFlags - -> IO (Compiler, Platform, ProgramConfiguration) -configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg) - (flagToMaybe $ configHcPath cfg) - (flagToMaybe $ configHcPkg cfg) - programsConfig - (fromFlag (configVerbosity cfg)) - where - 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 - GHCJS -> GHCJS.configure verbosity hcPath hcPkg conf - JHC -> JHC.configure verbosity hcPath hcPkg conf - LHC -> do (_, _, ghcConf) <- GHC.configure verbosity Nothing hcPkg conf - LHC.configure verbosity hcPath Nothing ghcConf - UHC -> UHC.configure verbosity hcPath hcPkg conf - HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg conf - _ -> die "Unknown compiler" - return (comp, fromMaybe buildPlatform maybePlatform, programsConfig) - --- 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 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 - - -mkComponentsGraph :: PackageDescription - -> [PackageId] - -> Either [ComponentName] - [(Component, [ComponentName])] -mkComponentsGraph pkg_descr internalPkgDeps = - let graph = [ (c, componentName c, componentDeps c) - | c <- pkgEnabledComponents pkg_descr ] - in case checkComponentsCyclic graph of - Just ccycle -> Left [ cname | (_,cname,_) <- ccycle ] - Nothing -> Right [ (c, cdeps) | (c, _, cdeps) <- graph ] - 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 - -reportComponentCycle :: [ComponentName] -> IO a -reportComponentCycle cnames = - die $ "Components in the package depend on each other in a cyclic way:\n " - ++ intercalate " depends on " - [ "'" ++ showComponentName cname ++ "'" - | cname <- cnames ++ [head cnames] ] - -mkComponentsLocalBuildInfo :: InstalledPackageIndex - -> PackageDescription - -> [PackageId] -- internal package deps - -> [InstalledPackageInfo] -- external package deps - -> [InstalledPackageInfo] -- hole package deps - -> Map ModuleName (InstalledPackageInfo, ModuleName) - -> PackageKey - -> [(Component, [ComponentName])] - -> Either [(ModuleReexport, String)] -- errors - [(ComponentName, ComponentLocalBuildInfo, - [ComponentName])] -- ok -mkComponentsLocalBuildInfo installedPackages pkg_descr - internalPkgDeps externalPkgDeps holePkgDeps hole_insts - pkg_key graph = - sequence - [ do clbi <- componentLocalBuildInfo c - return (componentName c, clbi, cdeps) - | (c, cdeps) <- graph ] - where - -- The allPkgDeps contains all the package deps for the whole package - -- but we need to select the subset for this specific component. - -- we just take the subset for the package names this component - -- needs. Note, this only works because we cannot yet depend on two - -- versions of the same package. - componentLocalBuildInfo component = - case component of - CLib lib -> do - let exports = map (\n -> Installed.ExposedModule n Nothing Nothing) - (PD.exposedModules lib) - esigs = map (\n -> Installed.ExposedModule n Nothing - (fmap (\(pkg,m) -> Installed.OriginalModule - (Installed.installedPackageId pkg) m) - (Map.lookup n hole_insts))) - (PD.exposedSignatures lib) - reexports <- resolveModuleReexports installedPackages - (packageId pkg_descr) - externalPkgDeps lib - return LibComponentLocalBuildInfo { - componentPackageDeps = cpds, - componentLibraries = [ LibraryName ("HS" ++ packageKeyLibraryName (package pkg_descr) pkg_key) ], - componentPackageRenaming = cprns, - componentExposedModules = exports ++ reexports ++ esigs - } - CExe _ -> - return ExeComponentLocalBuildInfo { - componentPackageDeps = cpds, - componentPackageRenaming = cprns - } - CTest _ -> - return TestComponentLocalBuildInfo { - componentPackageDeps = cpds, - componentPackageRenaming = cprns - } - CBench _ -> - return BenchComponentLocalBuildInfo { - componentPackageDeps = cpds, - componentPackageRenaming = cprns - } - where - bi = componentBuildInfo component - dedup = Map.toList . Map.fromList - cpds = if newPackageDepsBehaviour pkg_descr - then dedup $ - [ (Installed.installedPackageId pkg, packageId pkg) - | pkg <- selectSubset bi externalPkgDeps ] - ++ [ (inplacePackageId pkgid, pkgid) - | pkgid <- selectSubset bi internalPkgDeps ] - ++ [ (Installed.installedPackageId pkg, packageId pkg) - | pkg <- holePkgDeps ] - else [ (Installed.installedPackageId pkg, packageId pkg) - | pkg <- externalPkgDeps ] - cprns = if newPackageDepsBehaviour pkg_descr - then Map.unionWith mappend - -- We need hole dependencies passed to GHC, so add them here - -- (but note that they're fully thinned out. If they - -- appeared legitimately the monoid instance will - -- fill them out. - (Map.fromList [(packageName pkg, mempty) | pkg <- holePkgDeps]) - (targetBuildRenaming bi) - -- Hack: if we have old package-deps behavior, it's impossible - -- for non-default renamings to be used, because the Cabal - -- version is too early. This is a good, because while all the - -- deps were bundled up in buildDepends, we didn't do this for - -- renamings, so it's not even clear how to get the merged - -- version. So just assume that all of them are the default.. - else Map.fromList (map (\(_,pid) -> (packageName pid, defaultRenaming)) cpds) - - selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg] - selectSubset bi pkgs = - [ pkg | pkg <- pkgs, packageName pkg `elem` names bi ] - - names bi = [ name | Dependency name _ <- targetBuildDepends bi ] - --- | Given the author-specified re-export declarations from the .cabal file, --- resolve them to the form that we need for the package database. --- --- An invariant of the package database is that we always link the re-export --- directly to its original defining location (rather than indirectly via a --- chain of re-exporting packages). --- -resolveModuleReexports :: InstalledPackageIndex - -> PackageId - -> [InstalledPackageInfo] - -> Library - -> Either [(ModuleReexport, String)] -- errors - [Installed.ExposedModule] -- ok -resolveModuleReexports installedPackages srcpkgid externalPkgDeps lib = - case partitionEithers (map resolveModuleReexport (PD.reexportedModules lib)) of - ([], ok) -> Right ok - (errs, _) -> Left errs - where - -- A mapping from visible module names to their original defining - -- module name. We also record the package name of the package which - -- *immediately* provided the module (not the original) to handle if the - -- user explicitly says which build-depends they want to reexport from. - visibleModules :: Map ModuleName [(PackageName, Installed.ExposedModule)] - visibleModules = - Map.fromListWith (++) $ - [ (Installed.exposedName exposedModule, [(exportingPackageName, - exposedModule)]) - -- The package index here contains all the indirect deps of the - -- package we're configuring, but we want just the direct deps - | let directDeps = Set.fromList (map Installed.installedPackageId externalPkgDeps) - , pkg <- PackageIndex.allPackages installedPackages - , Installed.installedPackageId pkg `Set.member` directDeps - , let exportingPackageName = packageName pkg - , exposedModule <- visibleModuleDetails pkg - ] - ++ [ (visibleModuleName, [(exportingPackageName, exposedModule)]) - | visibleModuleName <- PD.exposedModules lib - ++ otherModules (libBuildInfo lib) - , let exportingPackageName = packageName srcpkgid - definingModuleName = visibleModuleName - -- we don't know the InstalledPackageId of this package yet - -- we will fill it in later, before registration. - definingPackageId = InstalledPackageId "" - originalModule = Installed.OriginalModule definingPackageId - definingModuleName - exposedModule = Installed.ExposedModule visibleModuleName - (Just originalModule) - Nothing - ] - - -- All the modules exported from this package and their defining name and - -- package (either defined here in this package or re-exported from some - -- other package). Return an ExposedModule because we want to hold onto - -- signature information. - visibleModuleDetails :: InstalledPackageInfo -> [Installed.ExposedModule] - visibleModuleDetails pkg = do - exposedModule <- Installed.exposedModules pkg - case Installed.exposedReexport exposedModule of - -- The first case is the modules actually defined in this package. - -- In this case the reexport will point to this package. - Nothing -> return exposedModule { Installed.exposedReexport = - Just (Installed.OriginalModule (Installed.installedPackageId pkg) - (Installed.exposedName exposedModule)) } - -- On the other hand, a visible module might actually be itself - -- a re-export! In this case, the re-export info for the package - -- doing the re-export will point us to the original defining - -- module name and package, so we can reuse the entry. - Just _ -> return exposedModule - - resolveModuleReexport reexport@ModuleReexport { - moduleReexportOriginalPackage = moriginalPackageName, - moduleReexportOriginalName = originalName, - moduleReexportName = newName - } = - - let filterForSpecificPackage = - case moriginalPackageName of - Nothing -> id - Just originalPackageName -> - filter (\(pkgname, _) -> pkgname == originalPackageName) - - matches = filterForSpecificPackage - (Map.findWithDefault [] originalName visibleModules) - in - case (matches, moriginalPackageName) of - ((_, exposedModule):rest, _) - -- TODO: Refine this check for signatures - | all (\(_, exposedModule') -> Installed.exposedReexport exposedModule - == Installed.exposedReexport exposedModule') rest - -> Right exposedModule { Installed.exposedName = newName } - - ([], Just originalPackageName) - -> Left $ (,) reexport - $ "The package " ++ display originalPackageName - ++ " does not export a module " ++ display originalName - - ([], Nothing) - -> Left $ (,) reexport - $ "The module " ++ display originalName - ++ " is not exported by any suitable package (this package " - ++ "itself nor any of its 'build-depends' dependencies)." - - (ms, _) - -> Left $ (,) reexport - $ "The module " ++ display originalName ++ " is exported " - ++ "by more than one package (" - ++ intercalate ", " [ display pkgname | (pkgname,_) <- ms ] - ++ ") and so the re-export is ambiguous. The ambiguity can " - ++ "be resolved by qualifying by the package name. The " - ++ "syntax is 'packagename:moduleName [as newname]'." - - -- Note: if in future Cabal allows directly depending on multiple - -- instances of the same package (e.g. backpack) then an additional - -- ambiguity case is possible here: (_, Just originalPackageName) - -- with the module being ambigious despite being qualified by a +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Configure +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This deals with the /configure/ phase. It provides the 'configure' action +-- which is given the package description and configure flags. It then tries +-- to: configure the compiler; resolves any conditionals in the package +-- description; resolve the package dependencies; check if all the extensions +-- used by this package are supported by the compiler; check that all the build +-- tools are available (including version checks if appropriate); checks for +-- any required @pkg-config@ packages (updating the 'BuildInfo' with the +-- results) +-- +-- Then based on all this it saves the info in the 'LocalBuildInfo' and writes +-- it out to the @dist\/setup-config@ file. It also displays various details to +-- the user, the amount of information displayed depending on the verbosity +-- level. + +module Distribution.Simple.Configure (configure, + writePersistBuildConfig, + getConfigStateFile, + getPersistBuildConfig, + checkPersistBuildConfigOutdated, + tryGetPersistBuildConfig, + maybeGetPersistBuildConfig, + findDistPref, findDistPrefOrDefault, + computeComponentId, + computeCompatPackageKey, + localBuildInfoFile, + getInstalledPackages, + getInstalledPackagesMonitorFiles, + getPackageDBContents, + configCompiler, configCompilerAux, + configCompilerEx, configCompilerAuxEx, + ccLdOptionsBuildInfo, + checkForeignDeps, + interpretPackageDbFlags, + ConfigStateFileError(..), + tryGetConfigStateFile, + platformDefines, + relaxPackageDeps, + ) + where + +import Distribution.Compiler +import Distribution.Utils.NubList +import Distribution.Simple.Compiler hiding (Flag) +import Distribution.Simple.PreProcess +import Distribution.Package +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.InstalledPackageInfo (InstalledPackageInfo + ,emptyInstalledPackageInfo) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.PackageDescription as PD hiding (Flag) +import Distribution.ModuleName +import Distribution.PackageDescription.Configuration +import Distribution.PackageDescription.Check hiding (doesFileExist) +import Distribution.Simple.Program +import Distribution.Simple.Setup as Setup +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.BuildPaths +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Version +import Distribution.Verbosity + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS +import qualified Distribution.Simple.JHC as JHC +import qualified Distribution.Simple.LHC as LHC +import qualified Distribution.Simple.UHC as UHC +import qualified Distribution.Simple.HaskellSuite as HaskellSuite + +-- Prefer the more generic Data.Traversable.mapM to Prelude.mapM +import Prelude hiding ( mapM ) +import Control.Exception + ( Exception, evaluate, throw, throwIO, try ) +import Control.Exception ( ErrorCall ) +import Control.Monad + ( liftM, when, unless, foldM, filterM, mplus ) +import Distribution.Compat.Binary ( decodeOrFailIO, encode ) +import GHC.Fingerprint ( Fingerprint(..), fingerprintString ) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as BLC8 +import Data.List + ( (\\), nub, partition, isPrefixOf, inits, stripPrefix ) +import Data.Maybe + ( isNothing, catMaybes, fromMaybe, mapMaybe, isJust ) +import Data.Either + ( partitionEithers ) +import qualified Data.Set as Set +import Data.Monoid as Mon ( Monoid(..) ) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Traversable + ( mapM ) +import Data.Typeable +import Data.Char ( chr, isAlphaNum ) +import Numeric ( showIntAtBase ) +import System.Directory + ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) +import System.FilePath + ( (), isAbsolute ) +import qualified System.Info + ( compilerName, compilerVersion ) +import System.IO + ( hPutStrLn, hClose ) +import Distribution.Text + ( Text(disp), defaultStyle, display, simpleParse ) +import Text.PrettyPrint + ( Doc, (<>), (<+>), ($+$), char, comma, empty, hsep, nest + , punctuate, quotes, render, renderStyle, sep, text ) +import Distribution.Compat.Environment ( lookupEnv ) +import Distribution.Compat.Exception ( catchExit, catchIO ) + +-- | The errors that can be thrown when reading the @setup-config@ file. +data ConfigStateFileError + = ConfigStateFileNoHeader -- ^ No header found. + | ConfigStateFileBadHeader -- ^ Incorrect header. + | ConfigStateFileNoParse -- ^ Cannot parse file contents. + | ConfigStateFileMissing -- ^ No file! + | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier + (Either ConfigStateFileError LocalBuildInfo) -- ^ Mismatched version. + deriving (Typeable) + +-- | Format a 'ConfigStateFileError' as a user-facing error message. +dispConfigStateFileError :: ConfigStateFileError -> Doc +dispConfigStateFileError ConfigStateFileNoHeader = + text "Saved package config file header is missing." + <+> text "Re-run the 'configure' command." +dispConfigStateFileError ConfigStateFileBadHeader = + text "Saved package config file header is corrupt." + <+> text "Re-run the 'configure' command." +dispConfigStateFileError ConfigStateFileNoParse = + text "Saved package config file is corrupt." + <+> text "Re-run the 'configure' command." +dispConfigStateFileError ConfigStateFileMissing = + text "Run the 'configure' command first." +dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) = + text "Saved package config file is outdated:" + $+$ badCabal $+$ badCompiler + $+$ text "Re-run the 'configure' command." + where + badCabal = + text "• the Cabal version changed from" + <+> disp oldCabal <+> "to" <+> disp currentCabalId + badCompiler + | oldCompiler == currentCompilerId = empty + | otherwise = + text "• the compiler changed from" + <+> disp oldCompiler <+> "to" <+> disp currentCompilerId + +instance Show ConfigStateFileError where + show = renderStyle defaultStyle . dispConfigStateFileError + +instance Exception ConfigStateFileError + +-- | Read the 'localBuildInfoFile'. Throw an exception if the file is +-- missing, if the file cannot be read, or if the file was created by an older +-- version of Cabal. +getConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file. + -> IO LocalBuildInfo +getConfigStateFile filename = do + exists <- doesFileExist filename + unless exists $ throwIO ConfigStateFileMissing + -- Read the config file into a strict ByteString to avoid problems with + -- lazy I/O, then convert to lazy because the binary package needs that. + contents <- BS.readFile filename + let (header, body) = BLC8.span (/='\n') (BLC8.fromChunks [contents]) + + headerParseResult <- try $ evaluate $ parseHeader header + let (cabalId, compId) = + case headerParseResult of + Left (_ :: ErrorCall) -> throw ConfigStateFileBadHeader + Right x -> x + + let getStoredValue = do + result <- decodeOrFailIO (BLC8.tail body) + case result of + Left _ -> throw ConfigStateFileNoParse + Right x -> return x + deferErrorIfBadVersion act + | cabalId /= currentCabalId = do + eResult <- try act + throw $ ConfigStateFileBadVersion cabalId compId eResult + | otherwise = act + deferErrorIfBadVersion getStoredValue + +-- | Read the 'localBuildInfoFile', returning either an error or the local build +-- info. +tryGetConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file. + -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetConfigStateFile = try . getConfigStateFile + +-- | Try to read the 'localBuildInfoFile'. +tryGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. + -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetPersistBuildConfig = try . getPersistBuildConfig + +-- | Read the 'localBuildInfoFile'. Throw an exception if the file is +-- missing, if the file cannot be read, or if the file was created by an older +-- version of Cabal. +getPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. + -> IO LocalBuildInfo +getPersistBuildConfig = getConfigStateFile . localBuildInfoFile + +-- | Try to read the 'localBuildInfoFile'. +maybeGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. + -> IO (Maybe LocalBuildInfo) +maybeGetPersistBuildConfig = + liftM (either (const Nothing) Just) . tryGetPersistBuildConfig + +-- | After running configure, output the 'LocalBuildInfo' to the +-- 'localBuildInfoFile'. +writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path. + -> LocalBuildInfo -- ^ The 'LocalBuildInfo' to write. + -> IO () +writePersistBuildConfig distPref lbi = do + createDirectoryIfMissing False distPref + writeFileAtomic (localBuildInfoFile distPref) $ + BLC8.unlines [showHeader pkgId, encode lbi] + where + pkgId = packageId $ localPkgDescr lbi + +-- | Identifier of the current Cabal package. +currentCabalId :: PackageIdentifier +currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion + +-- | Identifier of the current compiler package. +currentCompilerId :: PackageIdentifier +currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName) + System.Info.compilerVersion + +-- | Parse the @setup-config@ file header, returning the package identifiers +-- for Cabal and the compiler. +parseHeader :: ByteString -- ^ The file contents. + -> (PackageIdentifier, PackageIdentifier) +parseHeader header = case BLC8.words header of + ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId, + "using", compId] -> + fromMaybe (throw ConfigStateFileBadHeader) $ do + _ <- simpleParse (BLC8.unpack pkgId) :: Maybe PackageIdentifier + cabalId' <- simpleParse (BLC8.unpack cabalId) + compId' <- simpleParse (BLC8.unpack compId) + return (cabalId', compId') + _ -> throw ConfigStateFileNoHeader + +-- | Generate the @setup-config@ file header. +showHeader :: PackageIdentifier -- ^ The processed package. + -> ByteString +showHeader pkgId = BLC8.unwords + [ "Saved", "package", "config", "for" + , BLC8.pack $ display pkgId + , "written", "by" + , BLC8.pack $ display currentCabalId + , "using" + , BLC8.pack $ display currentCompilerId + ] + +-- | Check that localBuildInfoFile is up-to-date with respect to the +-- .cabal file. +checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool +checkPersistBuildConfigOutdated distPref pkg_descr_file = do + pkg_descr_file `moreRecentFile` (localBuildInfoFile distPref) + +-- | Get the path of @dist\/setup-config@. +localBuildInfoFile :: FilePath -- ^ The @dist@ directory path. + -> FilePath +localBuildInfoFile distPref = distPref "setup-config" + +-- ----------------------------------------------------------------------------- +-- * Configuration +-- ----------------------------------------------------------------------------- + +-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken +-- from (in order of highest to lowest preference) the override prefix, the +-- \"CABAL_BUILDDIR\" environment variable, or the default prefix. +findDistPref :: FilePath -- ^ default \"dist\" prefix + -> Setup.Flag FilePath -- ^ override \"dist\" prefix + -> IO FilePath +findDistPref defDistPref overrideDistPref = do + envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR") + return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref) + where + parseEnvDistPref env = + case env of + Just distPref | not (null distPref) -> toFlag distPref + _ -> NoFlag + +-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken +-- from (in order of highest to lowest preference) the override prefix, the +-- \"CABAL_BUILDDIR\" environment variable, or 'defaultDistPref' is used. Call +-- this function to resolve a @*DistPref@ flag whenever it is not known to be +-- set. (The @*DistPref@ flags are always set to a definite value before +-- invoking 'UserHooks'.) +findDistPrefOrDefault :: Setup.Flag FilePath -- ^ override \"dist\" prefix + -> IO FilePath +findDistPrefOrDefault = findDistPref defaultDistPref + +-- |Perform the \"@.\/setup configure@\" action. +-- Returns the @.setup-config@ file. +configure :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags -> IO LocalBuildInfo +configure (pkg_descr0', pbi) cfg = do + let pkg_descr0 = + -- Ignore '--allow-newer' when we're given '--exact-configuration'. + if fromFlagOrDefault False (configExactConfiguration cfg) + then pkg_descr0' + else relaxPackageDeps + (fromMaybe AllowNewerNone $ configAllowNewer cfg) + pkg_descr0' + + setupMessage verbosity "Configuring" (packageId pkg_descr0) + + checkDeprecatedFlags verbosity cfg + checkExactConfiguration pkg_descr0 cfg + + -- Where to build the package + let buildDir :: FilePath -- e.g. dist/build + -- fromFlag OK due to Distribution.Simple calling + -- findDistPrefOrDefault to fill it in + buildDir = fromFlag (configDistPref cfg) "build" + createDirectoryIfMissingVerbose (lessVerbose verbosity) True buildDir + + -- What package database(s) to use + let packageDbs + = interpretPackageDbFlags + (fromFlag (configUserInstall cfg)) + (configPackageDBs cfg) + + -- comp: the compiler we're building with + -- compPlatform: the platform we're building for + -- programsConfig: location and args of all programs we're + -- building with + (comp, compPlatform, programsConfig) + <- configCompilerEx + (flagToMaybe (configHcFlavor cfg)) + (flagToMaybe (configHcPath cfg)) + (flagToMaybe (configHcPkg cfg)) + (mkProgramsConfig cfg (configPrograms cfg)) + (lessVerbose verbosity) + + -- The InstalledPackageIndex of all installed packages + installedPackageSet <- getInstalledPackages (lessVerbose verbosity) comp + packageDbs programsConfig + + -- The InstalledPackageIndex of all (possible) internal packages + let internalPackageSet = getInternalPackages pkg_descr0 + + -- allConstraints: The set of all 'Dependency's we have. Used ONLY + -- to 'configureFinalizedPackage'. + -- requiredDepsMap: A map from 'PackageName' to the specifically + -- required 'InstalledPackageInfo', due to --dependency + -- + -- NB: These constraints are to be applied to ALL components of + -- a package. Thus, it's not an error if allConstraints contains + -- more constraints than is necessary for a component (another + -- component might need it.) + -- + -- NB: The fact that we bundle all the constraints together means + -- that is not possible to configure a test-suite to use one + -- version of a dependency, and the executable to use another. + (allConstraints, requiredDepsMap) <- either die return $ + combinedConstraints (configConstraints cfg) + (configDependencies cfg) + installedPackageSet + + -- pkg_descr: The resolved package description, that does not contain any + -- conditionals, because we have have an assignment for + -- every flag, either picking them ourselves using a + -- simple naive algorithm, or having them be passed to + -- us by 'configConfigurationsFlags') + -- flags: The 'FlagAssignment' that the conditionals were + -- resolved with. + -- + -- NB: Why doesn't finalizing a package also tell us what the + -- dependencies are (e.g. when we run the naive algorithm, + -- we are checking if dependencies are satisfiable)? The + -- primary reason is that we may NOT have done any solving: + -- if the flags are all chosen for us, this step is a simple + -- matter of flattening according to that assignment. It's + -- cleaner to then configure the dependencies afterwards. + (pkg_descr, flags) + <- configureFinalizedPackage verbosity cfg + allConstraints + (dependencySatisfiable + (fromFlagOrDefault False (configExactConfiguration cfg)) + installedPackageSet + internalPackageSet + requiredDepsMap) + comp + compPlatform + pkg_descr0 + + checkCompilerProblems comp pkg_descr + checkPackageProblems verbosity pkg_descr0 + (updatePackageDescription pbi pkg_descr) + + -- The list of 'InstalledPackageInfo' recording the selected + -- dependencies... + -- internalPkgDeps: ...on internal packages (these are fake!) + -- externalPkgDeps: ...on external packages + -- + -- Invariant: For any package name, there is at most one package + -- in externalPackageDeps which has that name. + -- + -- NB: The dependency selection is global over ALL components + -- in the package (similar to how allConstraints and + -- requiredDepsMap are global over all components). In particular, + -- if *any* component (post-flag resolution) has an unsatisfiable + -- dependency, we will fail. This can sometimes be undesirable + -- for users, see #1786 (benchmark conflicts with executable), + (internalPkgDeps, externalPkgDeps) + <- configureDependencies + verbosity + internalPackageSet + installedPackageSet + requiredDepsMap + pkg_descr + + let installDeps = Map.elems -- deduplicate + . Map.fromList + . map (\v -> (Installed.installedUnitId v, v)) + $ externalPkgDeps + + packageDependsIndex <- + case PackageIndex.dependencyClosure installedPackageSet + (map Installed.installedUnitId installDeps) of + Left packageDependsIndex -> return packageDependsIndex + Right broken -> + die $ "The following installed packages are broken because other" + ++ " packages they depend on are missing. These broken " + ++ "packages must be rebuilt before they can be used.\n" + ++ unlines [ "package " + ++ display (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map display deps) + | (pkg, deps) <- broken ] + + let pseudoTopPkg = emptyInstalledPackageInfo { + Installed.installedUnitId = + mkLegacyUnitId (packageId pkg_descr), + Installed.sourcePackageId = packageId pkg_descr, + Installed.depends = + map Installed.installedUnitId installDeps + } + case PackageIndex.dependencyInconsistencies + . PackageIndex.insert pseudoTopPkg + $ packageDependsIndex of + [] -> return () + inconsistencies -> + warn verbosity $ + "This package indirectly depends on multiple versions of the same " + ++ "package. This is highly likely to cause a compile failure.\n" + ++ unlines [ "package " ++ display pkg ++ " requires " + ++ display (PackageIdentifier name ver) + | (name, uses) <- inconsistencies + , (pkg, ver) <- uses ] + + -- installation directories + defaultDirs <- defaultInstallDirs (compilerFlavor comp) + (fromFlag (configUserInstall cfg)) (hasLibs pkg_descr) + let installDirs = combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs cfg) + + -- check languages and extensions + let langlist = nub $ catMaybes $ map defaultLanguage + (allBuildInfo pkg_descr) + let langs = unsupportedLanguages comp langlist + when (not (null langs)) $ + die $ "The package " ++ display (packageId pkg_descr0) + ++ " requires the following languages which are not " + ++ "supported by " ++ display (compilerId comp) ++ ": " + ++ intercalate ", " (map display langs) + let extlist = nub $ concatMap allExtensions (allBuildInfo pkg_descr) + let exts = unsupportedExtensions comp extlist + when (not (null exts)) $ + die $ "The package " ++ display (packageId pkg_descr0) + ++ " requires the following language extensions which are not " + ++ "supported by " ++ display (compilerId comp) ++ ": " + ++ intercalate ", " (map display exts) + + -- configured known/required programs & external build tools + -- exclude build-tool deps on "internal" exes in the same package + let requiredBuildTools = + [ buildTool + | let exeNames = map exeName (executables pkg_descr) + , bi <- allBuildInfo pkg_descr + , buildTool@(Dependency (PackageName toolName) reqVer) + <- buildTools bi + , let isInternal = + toolName `elem` exeNames + -- we assume all internal build-tools are + -- versioned with the package: + && packageVersion pkg_descr `withinRange` reqVer + , not isInternal ] + + programsConfig' <- + configureAllKnownPrograms (lessVerbose verbosity) programsConfig + >>= configureRequiredPrograms verbosity requiredBuildTools + + (pkg_descr', programsConfig'') <- + configurePkgconfigPackages verbosity pkg_descr programsConfig' + + -- internal component graph + buildComponents <- + case mkComponentsGraph pkg_descr internalPkgDeps of + Left componentCycle -> reportComponentCycle componentCycle + Right comps -> + mkComponentsLocalBuildInfo cfg comp packageDependsIndex pkg_descr + internalPkgDeps externalPkgDeps + comps (configConfigurationsFlags cfg) + + split_objs <- + if not (fromFlag $ configSplitObjs cfg) + then return False + else case compilerFlavor comp of + GHC | compilerVersion comp >= Version [6,5] [] + -> return True + GHCJS + -> return True + _ -> do warn verbosity + ("this compiler does not support " ++ + "--enable-split-objs; ignoring") + return False + + let ghciLibByDefault = + case compilerId comp of + CompilerId GHC _ -> + -- If ghc is non-dynamic, then ghci needs object files, + -- so we build one by default. + -- + -- Technically, archive files should be sufficient for ghci, + -- but because of GHC bug #8942, it has never been safe to + -- rely on them. By the time that bug was fixed, ghci had + -- been changed to read shared libraries instead of archive + -- files (see next code block). + not (GHC.isDynamic comp) + CompilerId GHCJS _ -> + not (GHCJS.isDynamic comp) + _ -> False + + let sharedLibsByDefault + | fromFlag (configDynExe cfg) = + -- build a shared library if dynamically-linked + -- executables are requested + True + | otherwise = case compilerId comp of + CompilerId GHC _ -> + -- if ghc is dynamic, then ghci needs a shared + -- library, so we build one by default. + GHC.isDynamic comp + CompilerId GHCJS _ -> + GHCJS.isDynamic comp + _ -> False + withSharedLib_ = + -- build shared libraries if required by GHC or by the + -- executable linking mode, but allow the user to force + -- building only static library archives with + -- --disable-shared. + fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg + withDynExe_ = fromFlag $ configDynExe cfg + when (withDynExe_ && not withSharedLib_) $ warn verbosity $ + "Executables will use dynamic linking, but a shared library " + ++ "is not being built. Linking will fail if any executables " + ++ "depend on the library." + + -- The --profiling flag sets the default for both libs and exes, + -- but can be overidden by --library-profiling, or the old deprecated + -- --executable-profiling flag. + let profEnabledLibOnly = configProfLib cfg + profEnabledBoth = fromFlagOrDefault False (configProf cfg) + profEnabledLib = fromFlagOrDefault profEnabledBoth profEnabledLibOnly + profEnabledExe = fromFlagOrDefault profEnabledBoth (configProfExe cfg) + + -- The --profiling-detail and --library-profiling-detail flags behave + -- similarly + profDetailLibOnly <- checkProfDetail (configProfLibDetail cfg) + profDetailBoth <- liftM (fromFlagOrDefault ProfDetailDefault) + (checkProfDetail (configProfDetail cfg)) + let profDetailLib = fromFlagOrDefault profDetailBoth profDetailLibOnly + profDetailExe = profDetailBoth + + when (profEnabledExe && not profEnabledLib) $ + warn verbosity $ + "Executables will be built with profiling, but library " + ++ "profiling is disabled. Linking will fail if any executables " + ++ "depend on the library." + + let configCoverage_ = + mappend (configCoverage cfg) (configLibCoverage cfg) + + cfg' = cfg { configCoverage = configCoverage_ } + + reloc <- + if not (fromFlag $ configRelocatable cfg) + then return False + else return True + + let lbi = LocalBuildInfo { + configFlags = cfg', + flagAssignment = flags, + extraConfigArgs = [], -- Currently configure does not + -- take extra args, but if it + -- did they would go here. + installDirTemplates = installDirs, + compiler = comp, + hostPlatform = compPlatform, + buildDir = buildDir, + componentsConfigs = buildComponents, + installedPkgs = packageDependsIndex, + pkgDescrFile = Nothing, + localPkgDescr = pkg_descr', + withPrograms = programsConfig'', + withVanillaLib = fromFlag $ configVanillaLib cfg, + withProfLib = profEnabledLib, + withSharedLib = withSharedLib_, + withDynExe = withDynExe_, + withProfExe = profEnabledExe, + withProfLibDetail = profDetailLib, + withProfExeDetail = profDetailExe, + withOptimization = fromFlag $ configOptimization cfg, + withDebugInfo = fromFlag $ configDebugInfo cfg, + withGHCiLib = fromFlagOrDefault ghciLibByDefault $ + configGHCiLib cfg, + splitObjs = split_objs, + stripExes = fromFlag $ configStripExes cfg, + stripLibs = fromFlag $ configStripLibs cfg, + withPackageDB = packageDbs, + progPrefix = fromFlag $ configProgPrefix cfg, + progSuffix = fromFlag $ configProgSuffix cfg, + relocatable = reloc + } + + when reloc (checkRelocatable verbosity pkg_descr lbi) + + let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest + relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi + + unless (isAbsolute (prefix dirs)) $ die $ + "expected an absolute directory name for --prefix: " ++ prefix dirs + + info verbosity $ "Using " ++ display currentCabalId + ++ " compiled by " ++ display currentCompilerId + info verbosity $ "Using compiler: " ++ showCompilerId comp + info verbosity $ "Using install prefix: " ++ prefix dirs + + let dirinfo name dir isPrefixRelative = + info verbosity $ name ++ " installed in: " ++ dir ++ relNote + where relNote = case buildOS of + Windows | not (hasLibs pkg_descr) + && isNothing isPrefixRelative + -> " (fixed location)" + _ -> "" + + dirinfo "Binaries" (bindir dirs) (bindir relative) + dirinfo "Libraries" (libdir dirs) (libdir relative) + dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative) + dirinfo "Data files" (datadir dirs) (datadir relative) + dirinfo "Documentation" (docdir dirs) (docdir relative) + dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative) + + sequence_ [ reportProgram verbosity prog configuredProg + | (prog, configuredProg) <- knownPrograms programsConfig'' ] + + return lbi + + where + verbosity = fromFlag (configVerbosity cfg) + + checkProfDetail (Flag (ProfDetailOther other)) = do + warn verbosity $ + "Unknown profiling detail level '" ++ other + ++ "', using default.\n" + ++ "The profiling detail levels are: " ++ intercalate ", " + [ name | (name, _, _) <- knownProfDetailLevels ] + return (Flag ProfDetailDefault) + checkProfDetail other = return other + +mkProgramsConfig :: ConfigFlags -> ProgramConfiguration -> ProgramConfiguration +mkProgramsConfig cfg initialProgramsConfig = programsConfig + where + programsConfig = userSpecifyArgss (configProgramArgs cfg) + . userSpecifyPaths (configProgramPaths cfg) + . setProgramSearchPath searchpath + $ initialProgramsConfig + searchpath = getProgramSearchPath (initialProgramsConfig) + ++ map ProgramSearchPathDir + (fromNubList $ configProgramPathExtra cfg) + +-- ----------------------------------------------------------------------------- +-- Helper functions for configure + +-- | Check if the user used any deprecated flags. +checkDeprecatedFlags :: Verbosity -> ConfigFlags -> IO () +checkDeprecatedFlags verbosity cfg = do + unless (configProfExe cfg == NoFlag) $ do + let enable | fromFlag (configProfExe cfg) = "enable" + | otherwise = "disable" + warn verbosity + ("The flag --" ++ enable ++ "-executable-profiling is deprecated. " + ++ "Please use --" ++ enable ++ "-profiling instead.") + + unless (configLibCoverage cfg == NoFlag) $ do + let enable | fromFlag (configLibCoverage cfg) = "enable" + | otherwise = "disable" + warn verbosity + ("The flag --" ++ enable ++ "-library-coverage is deprecated. " + ++ "Please use --" ++ enable ++ "-coverage instead.") + +-- | Sanity check: if '--exact-configuration' was given, ensure that the +-- complete flag assignment was specified on the command line. +checkExactConfiguration :: GenericPackageDescription -> ConfigFlags -> IO () +checkExactConfiguration pkg_descr0 cfg = do + when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do + let cmdlineFlags = map fst (configConfigurationsFlags cfg) + allFlags = map flagName . genPackageFlags $ pkg_descr0 + diffFlags = allFlags \\ cmdlineFlags + when (not . null $ diffFlags) $ + die $ "'--exact-configuration' was given, " + ++ "but the following flags were not specified: " + ++ intercalate ", " (map show diffFlags) + +-- | Create a PackageIndex that makes *any libraries that might be* +-- defined internally to this package look like installed packages, in +-- case an executable should refer to any of them as dependencies. +-- +-- It must be *any libraries that might be* defined rather than the +-- actual definitions, because these depend on conditionals in the .cabal +-- file, and we haven't resolved them yet. finalizePackageDescription +-- does the resolution of conditionals, and it takes internalPackageSet +-- as part of its input. +-- +-- Currently a package can define no more than one library (which has +-- the same name as the package) but we could extend this later. +-- If we later allowed private internal libraries, then here we would +-- need to pre-scan the conditional data to make a list of all private +-- libraries that could possibly be defined by the .cabal file. +getInternalPackages :: GenericPackageDescription + -> InstalledPackageIndex +getInternalPackages pkg_descr0 = + let pid :: PackageIdentifier -- e.g. foo-0.1 + pid = packageId pkg_descr0 + internalPackage = emptyInstalledPackageInfo { + --TODO: should use a per-compiler method to map the source + -- package ID into an installed package id we can use + -- for the internal package set. The use of + -- mkLegacyUnitId here is a hack. + Installed.installedUnitId = mkLegacyUnitId pid, + Installed.sourcePackageId = pid + } + in PackageIndex.fromList [internalPackage] + + +-- | Returns true if a dependency is satisfiable. This is to be passed +-- to finalizePackageDescription. +dependencySatisfiable + :: Bool + -> InstalledPackageIndex -- ^ installed set + -> InstalledPackageIndex -- ^ internal set + -> Map PackageName InstalledPackageInfo -- ^ required dependencies + -> (Dependency -> Bool) +dependencySatisfiable + exact_config installedPackageSet internalPackageSet requiredDepsMap + d@(Dependency depName _) + | exact_config = + -- When we're given '--exact-configuration', we assume that all + -- dependencies and flags are exactly specified on the command + -- line. Thus we only consult the 'requiredDepsMap'. Note that + -- we're not doing the version range check, so if there's some + -- dependency that wasn't specified on the command line, + -- 'finalizePackageDescription' will fail. + -- + -- TODO: mention '--exact-configuration' in the error message + -- when this fails? + -- + -- (However, note that internal deps don't have to be + -- specified!) + (depName `Map.member` requiredDepsMap) || isInternalDep + + | otherwise = + -- Normal operation: just look up dependency in the combined + -- package index. + not . null . PackageIndex.lookupDependency pkgs $ d + where + pkgs = PackageIndex.merge internalPackageSet installedPackageSet + isInternalDep = not . null + $ PackageIndex.lookupDependency internalPackageSet d + +-- | Relax the dependencies of this package if needed. +relaxPackageDeps :: AllowNewer -> GenericPackageDescription + -> GenericPackageDescription +relaxPackageDeps AllowNewerNone gpd = gpd +relaxPackageDeps AllowNewerAll gpd = transformAllBuildDepends relaxAll gpd + where + relaxAll = \(Dependency pkgName verRange) -> + Dependency pkgName (removeUpperBound verRange) +relaxPackageDeps (AllowNewerSome allowNewerDeps') gpd = + transformAllBuildDepends relaxSome gpd + where + thisPkgName = packageName gpd + allowNewerDeps = mapMaybe f allowNewerDeps' + + f (Setup.AllowNewerDep p) = Just p + f (Setup.AllowNewerDepScoped scope p) | scope == thisPkgName = Just p + | otherwise = Nothing + + relaxSome = \d@(Dependency depName verRange) -> + if depName `elem` allowNewerDeps + then Dependency depName (removeUpperBound verRange) + else d + +-- | Finalize a generic package description. The workhorse is +-- 'finalizePackageDescription' but there's a bit of other nattering +-- about necessary. +-- +-- TODO: what exactly is the business with @flaggedTests@ and +-- @flaggedBenchmarks@? +configureFinalizedPackage + :: Verbosity + -> ConfigFlags + -> [Dependency] + -> (Dependency -> Bool) -- ^ tests if a dependency is satisfiable. + -- Might say it's satisfiable even when not. + -> Compiler + -> Platform + -> GenericPackageDescription + -> IO (PackageDescription, FlagAssignment) +configureFinalizedPackage verbosity cfg + allConstraints satisfies comp compPlatform pkg_descr0 = do + let enableTest t = t { testEnabled = fromFlag (configTests cfg) } + flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t)) + (condTestSuites pkg_descr0) + enableBenchmark bm = bm { benchmarkEnabled = + fromFlag (configBenchmarks cfg) } + flaggedBenchmarks = map (\(n, bm) -> + (n, mapTreeData enableBenchmark bm)) + (condBenchmarks pkg_descr0) + pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests + , condBenchmarks = flaggedBenchmarks } + + (pkg_descr0', flags) <- + case finalizePackageDescription + (configConfigurationsFlags cfg) + satisfies + compPlatform + (compilerInfo comp) + allConstraints + pkg_descr0'' + of Right r -> return r + Left missing -> + die $ "Encountered missing dependencies:\n" + ++ (render . nest 4 . sep . punctuate comma + . map (disp . simplifyDependency) + $ missing) + + -- add extra include/lib dirs as specified in cfg + -- we do it here so that those get checked too + let pkg_descr = addExtraIncludeLibDirs pkg_descr0' + + when (not (null flags)) $ + info verbosity $ "Flags chosen: " + ++ intercalate ", " [ name ++ "=" ++ display value + | (FlagName name, value) <- flags ] + + return (pkg_descr, flags) + where + addExtraIncludeLibDirs pkg_descr = + let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg + , extraFrameworkDirs = configExtraFrameworkDirs cfg + , PD.includeDirs = configExtraIncludeDirs cfg} + modifyLib l = l{ libBuildInfo = libBuildInfo l + `mappend` extraBi } + modifyExecutable e = e{ buildInfo = buildInfo e + `mappend` extraBi} + in pkg_descr{ library = modifyLib `fmap` library pkg_descr + , executables = modifyExecutable `map` + executables pkg_descr} + +-- | Check for use of Cabal features which require compiler support +checkCompilerProblems :: Compiler -> PackageDescription -> IO () +checkCompilerProblems comp pkg_descr = do + unless (renamingPackageFlagsSupported comp || + and [ True + | bi <- allBuildInfo pkg_descr + , _ <- Map.elems (targetBuildRenaming bi)]) $ + die $ "Your compiler does not support thinning and renaming on " + ++ "package flags. To use this feature you probably must use " + ++ "GHC 7.9 or later." + + when (maybe False (not.null.PD.reexportedModules) (PD.library pkg_descr) + && not (reexportedModulesSupported comp)) $ do + die $ "Your compiler does not support module re-exports. To use " + ++ "this feature you probably must use GHC 7.9 or later." + +-- | Select dependencies for the package. +configureDependencies + :: Verbosity + -> InstalledPackageIndex -- ^ internal packages + -> InstalledPackageIndex -- ^ installed packages + -> Map PackageName InstalledPackageInfo -- ^ required deps + -> PackageDescription + -> IO ([PackageId], [InstalledPackageInfo]) +configureDependencies verbosity + internalPackageSet installedPackageSet requiredDepsMap pkg_descr = do + let selectDependencies :: [Dependency] -> + ([FailedDependency], [ResolvedDependency]) + selectDependencies = + partitionEithers + . map (selectDependency internalPackageSet installedPackageSet + requiredDepsMap) + + (failedDeps, allPkgDeps) = + selectDependencies (buildDepends pkg_descr) + + internalPkgDeps = [ pkgid + | InternalDependency _ pkgid <- allPkgDeps ] + externalPkgDeps = [ pkg + | ExternalDependency _ pkg <- allPkgDeps ] + + when (not (null internalPkgDeps) + && not (newPackageDepsBehaviour pkg_descr)) $ + die $ "The field 'build-depends: " + ++ intercalate ", " (map (display . packageName) internalPkgDeps) + ++ "' refers to a library which is defined within the same " + ++ "package. To use this feature the package must specify at " + ++ "least 'cabal-version: >= 1.8'." + + reportFailedDependencies failedDeps + reportSelectedDependencies verbosity allPkgDeps + + return (internalPkgDeps, externalPkgDeps) + +-- ----------------------------------------------------------------------------- +-- Configuring package dependencies + +reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () +reportProgram verbosity prog Nothing + = info verbosity $ "No " ++ programName prog ++ " found" +reportProgram verbosity prog (Just configuredProg) + = info verbosity $ "Using " ++ programName prog ++ version ++ location + where location = case programLocation configuredProg of + FoundOnSystem p -> " found on system at: " ++ p + UserSpecified p -> " given by user at: " ++ p + version = case programVersion configuredProg of + Nothing -> "" + Just v -> " version " ++ display v + +hackageUrl :: String +hackageUrl = "http://hackage.haskell.org/package/" + +data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo + | InternalDependency Dependency PackageId -- should be a + -- lib name + +data FailedDependency = DependencyNotExists PackageName + | DependencyNoVersion Dependency + +-- | Test for a package dependency and record the version we have installed. +selectDependency :: InstalledPackageIndex -- ^ Internally defined packages + -> InstalledPackageIndex -- ^ Installed packages + -> Map PackageName InstalledPackageInfo + -- ^ Packages for which we have been given specific deps to + -- use + -> Dependency + -> Either FailedDependency ResolvedDependency +selectDependency internalIndex installedIndex requiredDepsMap + dep@(Dependency pkgname vr) = + -- If the dependency specification matches anything in the internal package + -- index, then we prefer that match to anything in the second. + -- For example: + -- + -- Name: MyLibrary + -- Version: 0.1 + -- Library + -- .. + -- Executable my-exec + -- build-depends: MyLibrary + -- + -- We want "build-depends: MyLibrary" always to match the internal library + -- even if there is a newer installed library "MyLibrary-0.2". + -- However, "build-depends: MyLibrary >= 0.2" should match the installed one. + case PackageIndex.lookupPackageName internalIndex pkgname of + [(_,[pkg])] | packageVersion pkg `withinRange` vr + -> Right $ InternalDependency dep (packageId pkg) + + _ -> case Map.lookup pkgname requiredDepsMap of + -- If we know the exact pkg to use, then use it. + Just pkginstance -> Right (ExternalDependency dep pkginstance) + -- Otherwise we just pick an arbitrary instance of the latest version. + Nothing -> case PackageIndex.lookupDependency installedIndex dep of + [] -> Left $ DependencyNotExists pkgname + pkgs -> Right $ ExternalDependency dep $ + case last pkgs of + (_ver, pkginstances) -> head pkginstances + +reportSelectedDependencies :: Verbosity + -> [ResolvedDependency] -> IO () +reportSelectedDependencies verbosity deps = + info verbosity $ unlines + [ "Dependency " ++ display (simplifyDependency dep) + ++ ": using " ++ display pkgid + | resolved <- deps + , let (dep, pkgid) = case resolved of + ExternalDependency dep' pkg' -> (dep', packageId pkg') + InternalDependency dep' pkgid' -> (dep', pkgid') ] + +reportFailedDependencies :: [FailedDependency] -> IO () +reportFailedDependencies [] = return () +reportFailedDependencies failed = + die (intercalate "\n\n" (map reportFailedDependency failed)) + + where + reportFailedDependency (DependencyNotExists pkgname) = + "there is no version of " ++ display pkgname ++ " installed.\n" + ++ "Perhaps you need to download and install it from\n" + ++ hackageUrl ++ display pkgname ++ "?" + + reportFailedDependency (DependencyNoVersion dep) = + "cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n" + +-- | List all installed packages in the given package databases. +getInstalledPackages :: Verbosity -> Compiler + -> PackageDBStack -- ^ The stack of package databases. + -> ProgramConfiguration + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp packageDBs progconf = do + when (null packageDBs) $ + die $ "No package databases have been specified. If you use " + ++ "--package-db=clear, you must follow it with --package-db= " + ++ "with 'global', 'user' or a specific file." + + info verbosity "Reading installed packages..." + case compilerFlavor comp of + GHC -> GHC.getInstalledPackages verbosity comp packageDBs progconf + GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs progconf + JHC -> JHC.getInstalledPackages verbosity packageDBs progconf + LHC -> LHC.getInstalledPackages verbosity packageDBs progconf + UHC -> UHC.getInstalledPackages verbosity comp packageDBs progconf + HaskellSuite {} -> + HaskellSuite.getInstalledPackages verbosity packageDBs progconf + flv -> die $ "don't know how to find the installed packages for " + ++ display flv + +-- | Like 'getInstalledPackages', but for a single package DB. +-- +-- NB: Why isn't this always a fall through to 'getInstalledPackages'? +-- That is because 'getInstalledPackages' performs some sanity checks +-- on the package database stack in question. However, when sandboxes +-- are involved these sanity checks are not desirable. +getPackageDBContents :: Verbosity -> Compiler + -> PackageDB -> ProgramConfiguration + -> IO InstalledPackageIndex +getPackageDBContents verbosity comp packageDB progconf = do + info verbosity "Reading installed packages..." + case compilerFlavor comp of + GHC -> GHC.getPackageDBContents verbosity packageDB progconf + GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progconf + -- For other compilers, try to fall back on 'getInstalledPackages'. + _ -> getInstalledPackages verbosity comp [packageDB] progconf + + +-- | A set of files (or directories) that can be monitored to detect when +-- there might have been a change in the installed packages. +-- +getInstalledPackagesMonitorFiles :: Verbosity -> Compiler + -> PackageDBStack + -> ProgramConfiguration -> Platform + -> IO [FilePath] +getInstalledPackagesMonitorFiles verbosity comp packageDBs progconf platform = + case compilerFlavor comp of + GHC -> GHC.getInstalledPackagesMonitorFiles + verbosity platform progconf packageDBs + other -> do + warn verbosity $ "don't know how to find change monitoring files for " + ++ "the installed package databases for " ++ display other + return [] + +-- | The user interface specifies the package dbs to use with a combination of +-- @--global@, @--user@ and @--package-db=global|user|clear|$file@. +-- This function combines the global/user flag and interprets the package-db +-- flag into a single package db stack. +-- +interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack +interpretPackageDbFlags userInstall specificDBs = + extra initialStack specificDBs + where + initialStack | userInstall = [GlobalPackageDB, UserPackageDB] + | otherwise = [GlobalPackageDB] + + extra dbs' [] = dbs' + extra _ (Nothing:dbs) = extra [] dbs + extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs + +newPackageDepsBehaviourMinVersion :: Version +newPackageDepsBehaviourMinVersion = Version [1,7,1] [] + +-- In older cabal versions, there was only one set of package dependencies for +-- the whole package. In this version, we can have separate dependencies per +-- target, but we only enable this behaviour if the minimum cabal version +-- specified is >= a certain minimum. Otherwise, for compatibility we use the +-- old behaviour. +newPackageDepsBehaviour :: PackageDescription -> Bool +newPackageDepsBehaviour pkg = + specVersion pkg >= newPackageDepsBehaviourMinVersion + +-- We are given both --constraint="foo < 2.0" style constraints and also +-- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581". +-- +-- When finalising the package we have to take into account the specific +-- installed deps we've been given, and the finalise function expects +-- constraints, so we have to translate these deps into version constraints. +-- +-- But after finalising we then have to make sure we pick the right specific +-- deps in the end. So we still need to remember which installed packages to +-- pick. +combinedConstraints :: [Dependency] -> + [(PackageName, UnitId)] -> + InstalledPackageIndex -> + Either String ([Dependency], + Map PackageName InstalledPackageInfo) +combinedConstraints constraints dependencies installedPackages = do + + when (not (null badUnitIds)) $ + Left $ render $ text "The following package dependencies were requested" + $+$ nest 4 (dispDependencies badUnitIds) + $+$ text "however the given installed package instance does not exist." + + when (not (null badNames)) $ + Left $ render $ text "The following package dependencies were requested" + $+$ nest 4 (dispDependencies badNames) + $+$ text ("however the installed package's name does not match " + ++ "the name given.") + + --TODO: we don't check that all dependencies are used! + + return (allConstraints, idConstraintMap) + + where + allConstraints :: [Dependency] + allConstraints = constraints + ++ [ thisPackageVersion (packageId pkg) + | (_, _, Just pkg) <- dependenciesPkgInfo ] + + idConstraintMap :: Map PackageName InstalledPackageInfo + idConstraintMap = Map.fromList + [ (packageName pkg, pkg) + | (_, _, Just pkg) <- dependenciesPkgInfo ] + + -- The dependencies along with the installed package info, if it exists + dependenciesPkgInfo :: [(PackageName, UnitId, + Maybe InstalledPackageInfo)] + dependenciesPkgInfo = + [ (pkgname, ipkgid, mpkg) + | (pkgname, ipkgid) <- dependencies + , let mpkg = PackageIndex.lookupUnitId + installedPackages ipkgid + ] + + -- If we looked up a package specified by an installed package id + -- (i.e. someone has written a hash) and didn't find it then it's + -- an error. + badUnitIds = + [ (pkgname, ipkgid) + | (pkgname, ipkgid, Nothing) <- dependenciesPkgInfo ] + + -- If someone has written e.g. + -- --dependency="foo=MyOtherLib-1.0-07...5bf30" then they have + -- probably made a mistake. + badNames = + [ (requestedPkgName, ipkgid) + | (requestedPkgName, ipkgid, Just pkg) <- dependenciesPkgInfo + , let foundPkgName = packageName pkg + , requestedPkgName /= foundPkgName ] + + dispDependencies deps = + hsep [ text "--dependency=" + <> quotes (disp pkgname <> char '=' <> disp ipkgid) + | (pkgname, ipkgid) <- deps ] + +-- ----------------------------------------------------------------------------- +-- Configuring program dependencies + +configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration + -> IO ProgramConfiguration +configureRequiredPrograms verbosity deps conf = + foldM (configureRequiredProgram verbosity) conf deps + +configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency + -> IO ProgramConfiguration +configureRequiredProgram verbosity conf + (Dependency (PackageName progName) verRange) = + case lookupKnownProgram progName conf of + Nothing -> die ("Unknown build tool " ++ progName) + Just prog + -- requireProgramVersion always requires the program have a version + -- but if the user says "build-depends: foo" ie no version constraint + -- then we should not fail if we cannot discover the program version. + | verRange == anyVersion -> do + (_, conf') <- requireProgram verbosity prog conf + return conf' + | otherwise -> do + (_, _, conf') <- requireProgramVersion verbosity prog verRange conf + return conf' + +-- ----------------------------------------------------------------------------- +-- Configuring pkg-config package dependencies + +configurePkgconfigPackages :: Verbosity -> PackageDescription + -> ProgramConfiguration + -> IO (PackageDescription, ProgramConfiguration) +configurePkgconfigPackages verbosity pkg_descr conf + | null allpkgs = return (pkg_descr, conf) + | otherwise = do + (_, _, conf') <- requireProgramVersion + (lessVerbose verbosity) pkgConfigProgram + (orLaterVersion $ Version [0,9,0] []) conf + mapM_ requirePkg allpkgs + lib' <- mapM addPkgConfigBILib (library pkg_descr) + exes' <- mapM addPkgConfigBIExe (executables pkg_descr) + tests' <- mapM addPkgConfigBITest (testSuites pkg_descr) + benches' <- mapM addPkgConfigBIBench (benchmarks pkg_descr) + let pkg_descr' = pkg_descr { library = lib', executables = exes', + testSuites = tests', benchmarks = benches' } + return (pkg_descr', conf') + + where + allpkgs = concatMap pkgconfigDepends (allBuildInfo pkg_descr) + pkgconfig = rawSystemProgramStdoutConf (lessVerbose verbosity) + pkgConfigProgram conf + + requirePkg dep@(Dependency (PackageName pkg) range) = do + version <- pkgconfig ["--modversion", pkg] + `catchIO` (\_ -> die notFound) + `catchExit` (\_ -> die notFound) + case simpleParse version of + Nothing -> die "parsing output of pkg-config --modversion failed" + Just v | not (withinRange v range) -> die (badVersion v) + | otherwise -> info verbosity (depSatisfied v) + where + notFound = "The pkg-config package '" ++ pkg ++ "'" + ++ versionRequirement + ++ " is required but it could not be found." + badVersion v = "The pkg-config package '" ++ pkg ++ "'" + ++ versionRequirement + ++ " is required but the version installed on the" + ++ " system is version " ++ display v + depSatisfied v = "Dependency " ++ display dep + ++ ": using version " ++ display v + + versionRequirement + | isAnyVersion range = "" + | otherwise = " version " ++ display range + + -- Adds pkgconfig dependencies to the build info for a component + addPkgConfigBI compBI setCompBI comp = do + bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp)) + return $ setCompBI comp (compBI comp `mappend` bi) + + -- Adds pkgconfig dependencies to the build info for a library + addPkgConfigBILib = addPkgConfigBI libBuildInfo $ + \lib bi -> lib { libBuildInfo = bi } + + -- Adds pkgconfig dependencies to the build info for an executable + addPkgConfigBIExe = addPkgConfigBI buildInfo $ + \exe bi -> exe { buildInfo = bi } + + -- Adds pkgconfig dependencies to the build info for a test suite + addPkgConfigBITest = addPkgConfigBI testBuildInfo $ + \test bi -> test { testBuildInfo = bi } + + -- Adds pkgconfig dependencies to the build info for a benchmark + addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $ + \bench bi -> bench { benchmarkBuildInfo = bi } + + pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo + pkgconfigBuildInfo [] = return Mon.mempty + pkgconfigBuildInfo pkgdeps = do + let pkgs = nub [ display pkg | Dependency pkg _ <- pkgdeps ] + ccflags <- pkgconfig ("--cflags" : pkgs) + ldflags <- pkgconfig ("--libs" : pkgs) + return (ccLdOptionsBuildInfo (words ccflags) (words ldflags)) + +-- | Makes a 'BuildInfo' from C compiler and linker flags. +-- +-- This can be used with the output from configuration programs like pkg-config +-- and similar package-specific programs like mysql-config, freealut-config etc. +-- For example: +-- +-- > ccflags <- rawSystemProgramStdoutConf verbosity prog conf ["--cflags"] +-- > ldflags <- rawSystemProgramStdoutConf verbosity prog conf ["--libs"] +-- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags)) +-- +ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo +ccLdOptionsBuildInfo cflags ldflags = + let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags + (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags + (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' + in mempty { + PD.includeDirs = map (drop 2) includeDirs', + PD.extraLibs = map (drop 2) extraLibs', + PD.extraLibDirs = map (drop 2) extraLibDirs', + PD.ccOptions = cflags', + PD.ldOptions = ldflags'' + } + +-- ----------------------------------------------------------------------------- +-- Determining the compiler details + +configCompilerAuxEx :: ConfigFlags + -> IO (Compiler, Platform, ProgramConfiguration) +configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg) + (flagToMaybe $ configHcPath cfg) + (flagToMaybe $ configHcPkg cfg) + programsConfig + (fromFlag (configVerbosity cfg)) + where + 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 + GHCJS -> GHCJS.configure verbosity hcPath hcPkg conf + JHC -> JHC.configure verbosity hcPath hcPkg conf + LHC -> do (_, _, ghcConf) <- GHC.configure verbosity Nothing hcPkg conf + LHC.configure verbosity hcPath Nothing ghcConf + UHC -> UHC.configure verbosity hcPath hcPkg conf + HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg conf + _ -> die "Unknown compiler" + return (comp, fromMaybe buildPlatform maybePlatform, programsConfig) + +-- 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 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 + + +mkComponentsGraph :: PackageDescription + -> [PackageId] + -> Either [ComponentName] + [(Component, [ComponentName])] +mkComponentsGraph pkg_descr internalPkgDeps = + let graph = [ (c, componentName c, componentDeps c) + | c <- pkgEnabledComponents pkg_descr ] + in case checkComponentsCyclic graph of + Just ccycle -> Left [ cname | (_,cname,_) <- ccycle ] + Nothing -> Right [ (c, cdeps) | (c, _, cdeps) <- graph ] + 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 + +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] ] + +-- | This method computes a default, "good enough" 'ComponentId' +-- for a package. The intent is that cabal-install (or the user) will +-- specify a more detailed IPID via the @--ipid@ flag if necessary. +computeComponentId :: PackageIdentifier + -> ComponentName + -- TODO: careful here! + -> [ComponentId] -- IPIDs of the component dependencies + -> FlagAssignment + -> ComponentId +computeComponentId pid cname dep_ipids flagAssignment = do + -- show is found to be faster than intercalate and then replacement of + -- special character used in intercalating. We cannot simply hash by + -- doubly concating list, as it just flatten out the nested list, so + -- different sources can produce same hash + let hash = hashToBase62 $ + -- For safety, include the package + version here + -- for GHC 7.10, where just the hash is used as + -- the package key + (display pid) + ++ (show $ dep_ipids) + ++ show flagAssignment + ComponentId $ + display pid + ++ "-" ++ hash + ++ (case cname of + CLibName -> "" + -- TODO: these could result in non-parseable IPIDs + -- since the component name format is very flexible + CExeName s -> "-" ++ s ++ ".exe" + CTestName s -> "-" ++ s ++ ".test" + CBenchName s -> "-" ++ s ++ ".bench") + +hashToBase62 :: String -> String +hashToBase62 s = showFingerprint $ fingerprintString s + where + showIntAtBase62 x = showIntAtBase 62 representBase62 x "" + representBase62 x + | x < 10 = chr (48 + x) + | x < 36 = chr (65 + x - 10) + | x < 62 = chr (97 + x - 36) + | otherwise = '@' + showFingerprint (Fingerprint a b) = showIntAtBase62 a ++ showIntAtBase62 b + +-- | In GHC 8.0, the string we pass to GHC to use for symbol +-- names for a package can be an arbitrary, IPID-compatible string. +-- However, prior to GHC 8.0 there are some restrictions on what +-- format this string can be (due to how ghc-pkg parsed the key): +-- +-- 1. In GHC 7.10, the string had either be of the form +-- foo_ABCD, where foo is a non-semantic alphanumeric/hyphenated +-- prefix and ABCD is two base-64 encoded 64-bit integers, +-- or a GHC 7.8 style identifier. +-- +-- 2. In GHC 7.8, the string had to be a valid package identifier +-- like foo-0.1. +-- +-- So, the problem is that Cabal, in general, has a general IPID, +-- but needs to figure out a package key / package ID that the +-- old ghc-pkg will actually accept. But there's an EVERY WORSE +-- problem: if ghc-pkg decides to parse an identifier foo-0.1-xxx +-- as if it were a package identifier, which means it will SILENTLY +-- DROP the "xxx" (because it's a tag, and Cabal does not allow tags.) +-- So we must CONNIVE to ensure that we don't pick something that +-- looks like this. +-- +-- So this function attempts to define a mapping into the old formats. +-- +-- The mapping for GHC 7.8 and before: +-- +-- * For CLibName, we unconditionally use the 'PackageIdentifier'. +-- +-- * For sub-components, we create a new 'PackageIdentifier' which +-- is encoded in the following way. The test suite "qux" in package +-- "foobar-0.2" gets this package identifier "z-foobar-z-test-qux-0.2". +-- These package IDs have the form: +-- +-- cpid ::= "z-" package-id "-z-" component-type "-" component-name +-- component-type ::= "test" | "bench" | "exe" | "lib" +-- package-id and component-name have "-" ( "z" + ) "-" +-- segments encoded by adding an extra "z". +-- +-- The mapping for GHC 7.10: +-- +-- * For CLibName: +-- If the IPID is of the form foo-0.1-ABCDEF where foo_ABCDEF would +-- validly parse as a package key, we pass "ABCDEF". (NB: not +-- all hashes parse this way, because GHC 7.10 mandated that +-- these hashes be two base-62 encoded 64 bit integers), +-- but hashes that Cabal generated using 'computeComponentId' +-- are guaranteed to have this form. +-- +-- If it is not of this form, we rehash the IPID into the +-- correct form and pass that. +-- +-- * For sub-components, we rehash the IPID into the correct format +-- and pass that. +-- +computeCompatPackageKey + :: Compiler + -> PackageIdentifier + -> ComponentName + -> UnitId + -> (PackageName, String) +computeCompatPackageKey comp pid cname uid@(SimpleUnitId (ComponentId str)) + | not (packageKeySupported comp || unitIdSupported comp) = + -- NB: the package ID in the database entry has to follow this + let zdashcode s = go s (Nothing :: Maybe Int) [] + where go [] _ r = reverse r + go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r) + go ('-':z) _ r = go z (Just 0) ('-':r) + go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r) + go (c:z) _ r = go z Nothing (c:r) + cname_str = case cname of + CLibName -> error "computeCompatPackageKey" + CTestName n -> "-z-test-" ++ zdashcode n + CBenchName n -> "-z-bench-" ++ zdashcode n + CExeName n -> "-z-exe-" ++ zdashcode n + package_name + | cname == CLibName = pkgName pid + | otherwise = PackageName $ "z-" + ++ zdashcode (display (pkgName pid)) + ++ zdashcode cname_str + old_style_key + | cname == CLibName = display pid + | otherwise = display package_name ++ "-" + ++ display (pkgVersion pid) + in (package_name, old_style_key) + | not (unifiedIPIDRequired comp) = + let mb_verbatim_key + = case simpleParse str :: Maybe PackageId of + -- Something like 'foo-0.1', use it verbatim. + -- (NB: hash tags look like tags, so they are parsed, + -- so the extra equality check tests if a tag was dropped.) + Just pid0 | display pid0 == str -> Just str + _ -> Nothing + mb_truncated_key + = let cand = reverse (takeWhile isAlphaNum (reverse str)) + in if length cand == 22 && all isAlphaNum cand + then Just cand + else Nothing + rehashed_key = hashToBase62 str + in (pkgName pid, fromMaybe rehashed_key + (mb_verbatim_key `mplus` mb_truncated_key)) + | otherwise = (pkgName pid, display uid) + +mkComponentsLocalBuildInfo :: ConfigFlags + -> Compiler + -> InstalledPackageIndex + -> PackageDescription + -> [PackageId] -- internal package deps + -> [InstalledPackageInfo] -- external package deps + -> [(Component, [ComponentName])] + -> FlagAssignment + -> IO [(ComponentName, ComponentLocalBuildInfo, + [ComponentName])] +mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr + internalPkgDeps externalPkgDeps + graph flagAssignment = do + -- Pre-compute library hash so we can setup internal deps + -- TODO configIPID should have name changed + let cid = case configIPID cfg of + Flag cid0 -> + -- Hack to reuse install dirs machinery + -- NB: no real IPID available at this point + let env = packageTemplateEnv (package pkg_descr) + (mkUnitId "") + str = fromPathTemplate + (InstallDirs.substPathTemplate env + (toPathTemplate cid0)) + in ComponentId str + _ -> + computeComponentId (package pkg_descr) CLibName + (getDeps CLibName) flagAssignment + uid = SimpleUnitId cid + (_, compat_key) = computeCompatPackageKey comp + (package pkg_descr) CLibName uid + sequence + [ do clbi <- componentLocalBuildInfo uid compat_key c + return (componentName c, clbi, cdeps) + | (c, cdeps) <- graph ] + where + getDeps cname = + let externalPkgs = maybe [] (\lib -> selectSubset + (componentBuildInfo lib) + externalPkgDeps) + (lookupComponent pkg_descr cname) + in map Installed.installedComponentId externalPkgs + + -- 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 uid compat_key component = + case component of + CLib lib -> do + let exports = map (\n -> Installed.ExposedModule n Nothing) + (PD.exposedModules lib) + let mb_reexports = resolveModuleReexports installedPackages + (packageId pkg_descr) + uid + externalPkgDeps lib + reexports <- case mb_reexports of + Left problems -> reportModuleReexportProblems problems + Right r -> return r + + return LibComponentLocalBuildInfo { + componentPackageDeps = cpds, + componentUnitId = uid, + componentCompatPackageKey = compat_key, + componentPackageRenaming = cprns, + componentExposedModules = exports ++ reexports + } + CExe _ -> + return ExeComponentLocalBuildInfo { + componentPackageDeps = cpds, + componentPackageRenaming = cprns + } + CTest _ -> + return TestComponentLocalBuildInfo { + componentPackageDeps = cpds, + componentPackageRenaming = cprns + } + CBench _ -> + return BenchComponentLocalBuildInfo { + componentPackageDeps = cpds, + componentPackageRenaming = cprns + } + where + bi = componentBuildInfo component + dedup = Map.toList . Map.fromList + cpds = if newPackageDepsBehaviour pkg_descr + then dedup $ + [ (Installed.installedUnitId pkg, packageId pkg) + | pkg <- selectSubset bi externalPkgDeps ] + ++ [ (uid, pkgid) + | pkgid <- selectSubset bi internalPkgDeps ] + else [ (Installed.installedUnitId pkg, packageId pkg) + | pkg <- externalPkgDeps ] + cprns = if newPackageDepsBehaviour pkg_descr + then targetBuildRenaming bi + -- Hack: if we have old package-deps behavior, it's impossible + -- for non-default renamings to be used, because the Cabal + -- version is too early. This is a good, because while all the + -- deps were bundled up in buildDepends, we didn't do this for + -- renamings, so it's not even clear how to get the merged + -- version. So just assume that all of them are the default.. + else Map.fromList (map (\(_,pid) -> + (packageName pid, defaultRenaming)) cpds) + + selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg] + selectSubset bi pkgs = + [ pkg | pkg <- pkgs, packageName pkg `elem` names bi ] + + names bi = [ name | Dependency name _ <- targetBuildDepends bi ] + +-- | Given the author-specified re-export declarations from the .cabal file, +-- resolve them to the form that we need for the package database. +-- +-- An invariant of the package database is that we always link the re-export +-- directly to its original defining location (rather than indirectly via a +-- chain of re-exporting packages). +-- +resolveModuleReexports :: InstalledPackageIndex + -> PackageId + -> UnitId + -> [InstalledPackageInfo] + -> Library + -> Either [(ModuleReexport, String)] -- errors + [Installed.ExposedModule] -- ok +resolveModuleReexports installedPackages srcpkgid key externalPkgDeps lib = + case partitionEithers + (map resolveModuleReexport (PD.reexportedModules lib)) of + ([], ok) -> Right ok + (errs, _) -> Left errs + where + -- A mapping from visible module names to their original defining + -- module name. We also record the package name of the package which + -- *immediately* provided the module (not the original) to handle if the + -- user explicitly says which build-depends they want to reexport from. + visibleModules :: Map ModuleName [(PackageName, Installed.ExposedModule)] + visibleModules = + Map.fromListWith (++) $ + [ (Installed.exposedName exposedModule, [(exportingPackageName, + exposedModule)]) + -- The package index here contains all the indirect deps of the + -- package we're configuring, but we want just the direct deps + | let directDeps = Set.fromList + (map Installed.installedUnitId externalPkgDeps) + , pkg <- PackageIndex.allPackages installedPackages + , Installed.installedUnitId pkg `Set.member` directDeps + , let exportingPackageName = packageName pkg + , exposedModule <- visibleModuleDetails pkg + ] + ++ [ (visibleModuleName, [(exportingPackageName, exposedModule)]) + | visibleModuleName <- PD.exposedModules lib + ++ otherModules (libBuildInfo lib) + , let exportingPackageName = packageName srcpkgid + definingModuleName = visibleModuleName + definingPackageId = key + originalModule = Installed.OriginalModule definingPackageId + definingModuleName + exposedModule = Installed.ExposedModule visibleModuleName + (Just originalModule) + ] + + -- All the modules exported from this package and their defining name and + -- package (either defined here in this package or re-exported from some + -- other package). Return an ExposedModule because we want to hold onto + -- signature information. + visibleModuleDetails :: InstalledPackageInfo -> [Installed.ExposedModule] + visibleModuleDetails pkg = do + exposedModule <- Installed.exposedModules pkg + case Installed.exposedReexport exposedModule of + -- The first case is the modules actually defined in this package. + -- In this case the reexport will point to this package. + Nothing -> return exposedModule { + Installed.exposedReexport = + Just (Installed.OriginalModule + (Installed.installedUnitId pkg) + (Installed.exposedName exposedModule)) } + -- On the other hand, a visible module might actually be itself + -- a re-export! In this case, the re-export info for the package + -- doing the re-export will point us to the original defining + -- module name and package, so we can reuse the entry. + Just _ -> return exposedModule + + resolveModuleReexport reexport@ModuleReexport { + moduleReexportOriginalPackage = moriginalPackageName, + moduleReexportOriginalName = originalName, + moduleReexportName = newName + } = + + let filterForSpecificPackage = + case moriginalPackageName of + Nothing -> id + Just originalPackageName -> + filter (\(pkgname, _) -> pkgname == originalPackageName) + + matches = filterForSpecificPackage + (Map.findWithDefault [] originalName visibleModules) + in + case (matches, moriginalPackageName) of + ((_, exposedModule):rest, _) + -- TODO: Refine this check for signatures + | all (\(_, exposedModule') -> + Installed.exposedReexport exposedModule + == Installed.exposedReexport exposedModule') rest + -> Right exposedModule { Installed.exposedName = newName } + + ([], Just originalPackageName) + -> Left $ (,) reexport + $ "The package " ++ display originalPackageName + ++ " does not export a module " ++ display originalName + + ([], Nothing) + -> Left $ (,) reexport + $ "The module " ++ display originalName + ++ " is not exported by any suitable package (this package " + ++ "itself nor any of its 'build-depends' dependencies)." + + (ms, _) + -> Left $ (,) reexport + $ "The module " ++ display originalName ++ " is exported " + ++ "by more than one package (" + ++ intercalate ", " [ display pkgname | (pkgname,_) <- ms ] + ++ ") and so the re-export is ambiguous. The ambiguity can " + ++ "be resolved by qualifying by the package name. The " + ++ "syntax is 'packagename:moduleName [as newname]'." + + -- Note: if in future Cabal allows directly depending on multiple + -- instances of the same package (e.g. backpack) then an additional + -- ambiguity case is possible here: (_, Just originalPackageName) + -- with the module being ambiguous despite being qualified by a -- package name. Presumably by that time we'll have a mechanism to -- qualify the instance we're referring to. diff --git a/Distribution/Simple/GHC.hs b/Distribution/Simple/GHC.hs --- a/Distribution/Simple/GHC.hs +++ b/Distribution/Simple/GHC.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternGuards #-} + ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.GHC @@ -33,7 +34,10 @@ module Distribution.Simple.GHC ( getGhcInfo, - configure, getInstalledPackages, getPackageDBContents, + configure, + getInstalledPackages, + getInstalledPackagesMonitorFiles, + getPackageDBContents, buildLib, buildExe, replLib, replExe, startInterpreter, @@ -42,80 +46,59 @@ hcPkgInfo, registerPackage, componentGhcOptions, + componentCcGhcOptions, getLibDir, isDynamic, getGlobalPackageDB, pkgRoot ) where -import qualified Distribution.Simple.GHC.IPI641 as IPI641 +import Control.Applicative -- 7.10 -Werror workaround +import Prelude -- https://ghc.haskell.org/trac/ghc/wiki/Migration/7.10#GHCsaysTheimportof...isredundant + import qualified Distribution.Simple.GHC.IPI642 as IPI642 import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.Simple.GHC.ImplInfo import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) - , allExtensions, libModules, exeModules - , hcOptions, hcSharedOptions, hcProfOptions ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo_(..) ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) - , absoluteInstallDirs, depLibraryPaths ) import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package - ( PackageName(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program - ( Program(..), ConfiguredProgram(..), ProgramConfiguration - , ProgramSearchPath - , rawSystemProgramStdout, rawSystemProgramStdoutConf - , getProgramInvocationOutput, requireProgramVersion, requireProgram - , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram - , ghcProgram, ghcPkgProgram, hsc2hsProgram, ldProgram ) import qualified Distribution.Simple.Program.HcPkg as HcPkg import qualified Distribution.Simple.Program.Ar as Ar import qualified Distribution.Simple.Program.Ld as Ld import qualified Distribution.Simple.Program.Strip as Strip import Distribution.Simple.Program.GHC import Distribution.Simple.Setup - ( toFlag, fromFlag, fromFlagOrDefault, configCoverage, configDistPref ) import qualified Distribution.Simple.Setup as Cabal - ( Flag(..) ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion - , PackageDB(..), PackageDBStack, AbiTag(..) ) +import Distribution.Simple.Compiler hiding (Flag) import Distribution.Version - ( Version(..), anyVersion, orLaterVersion ) import Distribution.System - ( Platform(..), OS(..) ) import Distribution.Verbosity import Distribution.Text - ( display ) import Distribution.Utils.NubList - ( NubListR, overNubListR, toNubListR ) -import Language.Haskell.Extension (Extension(..), KnownExtension(..)) +import Language.Haskell.Extension import Control.Monad ( unless, when ) import Data.Char ( isDigit, isSpace ) import Data.List -import qualified Data.Map as M ( fromList ) +import qualified Data.Map as M ( fromList, lookup ) import Data.Maybe ( catMaybes ) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid ( Monoid(..) ) -#endif +import Data.Monoid as Mon ( Monoid(..) ) import Data.Version ( showVersion ) import System.Directory - ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing ) -import System.FilePath ( (), (<.>), takeExtension, - takeDirectory, replaceExtension, - splitExtension, isRelative ) + ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing + , canonicalizePath ) +import System.FilePath ( (), (<.>), takeExtension + , takeDirectory, replaceExtension + , isRelative ) import qualified System.Info -- ----------------------------------------------------------------------------- @@ -146,18 +129,32 @@ ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " " ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion - -- Likewise we try to find the matching hsc2hs program. + -- Likewise we try to find the matching hsc2hs and haddock programs. let hsc2hsProgram' = hsc2hsProgram { programFindLocation = guessHsc2hsFromGhcPath ghcProg } - conf3 = addKnownProgram hsc2hsProgram' conf2 + haddockProgram' = haddockProgram { + programFindLocation = guessHaddockFromGhcPath ghcProg + } + conf3 = addKnownProgram haddockProgram' $ + addKnownProgram hsc2hsProgram' conf2 languages <- Internal.getLanguages verbosity implInfo ghcProg - extensions <- Internal.getExtensions verbosity implInfo ghcProg + extensions0 <- Internal.getExtensions verbosity implInfo ghcProg ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg let ghcInfoMap = M.fromList ghcInfo + -- starting with GHC 8.0, `TemplateHaskell` will be omitted from + -- `--supported-extensions` when it's not available. + -- for older GHCs we can use the "Have interpreter" property to + -- filter out `TemplateHaskell` + extensions | ghcVersion < Version [8] [] + , Just "NO" <- M.lookup "Have interpreter" ghcInfoMap + = filter ((/= EnableExtension TemplateHaskell) . fst) + extensions0 + | otherwise = extensions0 + let comp = Compiler { compilerId = CompilerId GHC ghcVersion, compilerAbiTag = NoAbiTag, @@ -167,7 +164,8 @@ compilerProperties = ghcInfoMap } compPlatform = Internal.targetPlatform ghcInfo - conf4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap conf3 -- configure gcc and ld + -- configure gcc and ld + conf4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap conf3 return (comp, compPlatform, conf4) -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find @@ -180,30 +178,42 @@ -- guessToolFromGhcPath :: Program -> ConfiguredProgram -> Verbosity -> ProgramSearchPath - -> IO (Maybe FilePath) + -> IO (Maybe (FilePath, [FilePath])) guessToolFromGhcPath tool ghcProg verbosity searchpath = do let toolname = programName tool - path = programPath ghcProg - dir = takeDirectory path - versionSuffix = takeVersionSuffix (dropExeExtension path) - guessNormal = dir toolname <.> exeExtension - guessGhcVersioned = dir (toolname ++ "-ghc" ++ versionSuffix) - <.> exeExtension - guessVersioned = dir (toolname ++ versionSuffix) - <.> exeExtension - guesses | null versionSuffix = [guessNormal] - | otherwise = [guessGhcVersioned, - guessVersioned, - guessNormal] + given_path = programPath ghcProg + given_dir = takeDirectory given_path + real_path <- canonicalizePath given_path + let real_dir = takeDirectory real_path + versionSuffix path = takeVersionSuffix (dropExeExtension path) + given_suf = versionSuffix given_path + real_suf = versionSuffix real_path + guessNormal dir = dir toolname <.> exeExtension + guessGhcVersioned dir suf = dir (toolname ++ "-ghc" ++ suf) + <.> exeExtension + guessVersioned dir suf = dir (toolname ++ suf) + <.> exeExtension + mkGuesses dir suf | null suf = [guessNormal dir] + | otherwise = [guessGhcVersioned dir suf, + guessVersioned dir suf, + guessNormal dir] + guesses = mkGuesses given_dir given_suf ++ + if real_path == given_path + then [] + else mkGuesses real_dir real_suf info verbosity $ "looking for tool " ++ toolname - ++ " near compiler in " ++ dir + ++ " near compiler in " ++ given_dir + debug verbosity $ "candidate locations: " ++ show guesses exists <- mapM doesFileExist guesses case [ file | (file, True) <- zip guesses exists ] of -- If we can't find it near ghc, fall back to the usual -- method. [] -> programFindLocation tool verbosity searchpath (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp - return (Just fp) + let lookedAt = map fst + . takeWhile (\(_file, exist) -> not exist) + $ zip guesses exists + return (Just (fp, lookedAt)) where takeVersionSuffix :: FilePath -> String takeVersionSuffix = takeWhileEndLE isSuffixChar @@ -211,12 +221,6 @@ isSuffixChar :: Char -> Bool isSuffixChar c = isDigit c || c == '.' || c == '-' - dropExeExtension :: FilePath -> FilePath - dropExeExtension filepath = - case splitExtension filepath of - (filepath', extension) | extension == exeExtension -> filepath' - | otherwise -> filepath - -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a -- corresponding ghc-pkg, we try looking for both a versioned and unversioned -- ghc-pkg in the same dir, that is: @@ -226,7 +230,8 @@ -- > /usr/local/bin/ghc-pkg(.exe) -- guessGhcPkgFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) + -> Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a @@ -238,9 +243,23 @@ -- > /usr/local/bin/hsc2hs(.exe) -- guessHsc2hsFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) + -> Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding haddock, we try looking for both a versioned and unversioned +-- haddock in the same dir, that is: +-- +-- > /usr/local/bin/haddock-ghc-6.6.1(.exe) +-- > /usr/local/bin/haddock-6.6.1(.exe) +-- > /usr/local/bin/haddock(.exe) +-- +guessHaddockFromGhcPath :: ConfiguredProgram + -> Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram + getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg where @@ -255,11 +274,12 @@ toPackageIndex verbosity pkgss conf -- | Given a package DB stack, return all installed packages. -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration +getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack + -> ProgramConfiguration -> IO InstalledPackageIndex -getInstalledPackages verbosity packagedbs conf = do +getInstalledPackages verbosity comp packagedbs conf = do checkPackageDbEnvVar - checkPackageDbStack packagedbs + checkPackageDbStack comp packagedbs pkgss <- getInstalledPackages' verbosity packagedbs conf index <- toPackageIndex verbosity pkgss conf return $! hackRtsPackage index @@ -286,7 +306,7 @@ topDir <- getLibDir' verbosity ghcProg let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) | (_, pkgs) <- pkgss ] - return $! (mconcat indices) + return $! mconcat indices where Just ghcProg = lookupProgram ghcProgram conf @@ -309,19 +329,51 @@ dropWhileEndLE isSpace `fmap` rawSystemProgramStdout verbosity ghcProg ["--print-global-package-db"] +-- | Return the 'FilePath' to the per-user GHC package database. +getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath +getUserPackageDB _verbosity ghcProg (Platform arch os) = do + -- It's rather annoying that we have to reconstruct this, because ghc + -- hides this information from us otherwise. But for certain use cases + -- like change monitoring it really can't remain hidden. + appdir <- getAppUserDataDirectory "ghc" + return (appdir platformAndVersion packageConfFileName) + where + platformAndVersion = intercalate "-" [ Internal.showArchString arch + , Internal.showOsString os + , display ghcVersion ] + packageConfFileName + | ghcVersion >= Version [6,12] [] = "package.conf.d" + | otherwise = "package.conf" + Just ghcVersion = programVersion ghcProg + checkPackageDbEnvVar :: IO () checkPackageDbEnvVar = Internal.checkPackageDbEnvVar "GHC" "GHC_PACKAGE_PATH" -checkPackageDbStack :: PackageDBStack -> IO () -checkPackageDbStack (GlobalPackageDB:rest) +checkPackageDbStack :: Compiler -> PackageDBStack -> IO () +checkPackageDbStack comp = if flagPackageConf implInfo + then checkPackageDbStackPre76 + else checkPackageDbStackPost76 + where implInfo = ghcVersionImplInfo (compilerVersion comp) + +checkPackageDbStackPost76 :: PackageDBStack -> IO () +checkPackageDbStackPost76 (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () -checkPackageDbStack rest +checkPackageDbStackPost76 rest + | GlobalPackageDB `elem` rest = + die $ "If the global package db is specified, it must be " + ++ "specified first and cannot be specified multiple times" +checkPackageDbStackPost76 _ = return () + +checkPackageDbStackPre76 :: PackageDBStack -> IO () +checkPackageDbStackPre76 (GlobalPackageDB:rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStackPre76 rest | GlobalPackageDB `notElem` rest = die $ "With current ghc versions the global package db is always used " - ++ "and must be listed first. This ghc limitation may be lifted in " - ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977" -checkPackageDbStack _ = + ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6," + ++ "see http://hackage.haskell.org/trac/ghc/ticket/5977" +checkPackageDbStackPre76 _ = die $ "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times" @@ -372,14 +424,41 @@ = \file content -> case reads content of [(pkgs, _)] -> return (map IPI642.toCurrent pkgs) _ -> failToRead file + -- We dropped support for 6.4.2 and earlier. | otherwise - = \file content -> case reads content of - [(pkgs, _)] -> return (map IPI641.toCurrent pkgs) - _ -> failToRead file + = \file _ -> failToRead file Just ghcProg = lookupProgram ghcProgram conf Just ghcVersion = programVersion ghcProg failToRead file = die $ "cannot read ghc package database " ++ file +getInstalledPackagesMonitorFiles :: Verbosity -> Platform + -> ProgramConfiguration + -> [PackageDB] + -> IO [FilePath] +getInstalledPackagesMonitorFiles verbosity platform progdb = + mapM getPackageDBPath + where + getPackageDBPath :: PackageDB -> IO FilePath + getPackageDBPath GlobalPackageDB = + selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg + + getPackageDBPath UserPackageDB = + selectMonitorFile =<< getUserPackageDB verbosity ghcProg platform + + getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path + + -- GHC has old style file dbs, and new style directory dbs. + -- Note that for dir style dbs, we only need to monitor the cache file, not + -- the whole directory. The ghc program itself only reads the cache file + -- so it's safe to only monitor this one file. + selectMonitorFile path = do + isFileStyle <- doesFileExist path + if isFileStyle then return path + else return (path "package.cache") + + Just ghcProg = lookupProgram ghcProgram progdb + + -- ----------------------------------------------------------------------------- -- Building @@ -395,12 +474,10 @@ -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () buildOrReplLib forRepl verbosity numJobs 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 + let libName = componentUnitId clbi + libTargetDir + | componentUnitId clbi == localUnitId lbi = buildDir lbi + | otherwise = buildDir lbi display libName whenVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) whenProfLib = when (withProfLib lbi) @@ -411,11 +488,10 @@ comp = compiler lbi ghcVersion = compilerVersion comp implInfo = getImplInfo comp - (Platform _hostArch hostOS) = hostPlatform lbi - hole_insts = map (\(k,(p,n)) -> (k,(InstalledPackageInfo.packageKey p,n))) (instantiatedWith lbi) + platform@(Platform _hostArch hostOS) = hostPlatform lbi (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) - let runGhcProg = runGHC verbosity ghcProg comp + let runGhcProg = runGHC verbosity ghcProg comp platform libBi <- hackThreadedFlag verbosity comp (withProfLib lbi) (libBuildInfo lib) @@ -435,6 +511,7 @@ cname = display $ PD.package $ localPkgDescr lbi distPref = fromFlag $ configDistPref $ configFlags lbi hpcdir way + | forRepl = Mon.mempty -- HPC is not supported in ghci | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname | otherwise = mempty @@ -446,14 +523,14 @@ vanillaOpts = baseOpts `mappend` mempty { ghcOptMode = toFlag GhcModeMake, ghcOptNumJobs = numJobs, - ghcOptPackageKey = toFlag (pkgKey lbi), - ghcOptSigOf = hole_insts, ghcOptInputModules = toNubListR $ libModules lib, ghcOptHPCDir = hpcdir Hpc.Vanilla } profOpts = vanillaOpts `mappend` mempty { ghcOptProfilingMode = toFlag True, + ghcOptProfilingAuto = Internal.profDetailLevelFlag True + (withProfLibDetail lbi), ghcOptHiSuffix = toFlag "p_hi", ghcOptObjSuffix = toFlag "p_o", ghcOptExtra = toNubListR $ hcProfOptions GHC libBi, @@ -469,17 +546,20 @@ ghcOptHPCDir = hpcdir Hpc.Dyn } linkerOpts = mempty { - ghcOptLinkOptions = toNubListR $ PD.ldOptions libBi, - ghcOptLinkLibs = toNubListR $ extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, + ghcOptLinkOptions = toNubListR $ PD.ldOptions libBi, + ghcOptLinkLibs = toNubListR $ extraLibs libBi, + ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, + ghcOptLinkFrameworks = toNubListR $ + PD.frameworks libBi, + ghcOptLinkFrameworkDirs = toNubListR $ + PD.extraFrameworkDirs libBi, ghcOptInputFiles = toNubListR [libTargetDir x | x <- cObjs] } replOpts = vanillaOpts { ghcOptExtra = overNubListR Internal.filterGhciFlags $ - (ghcOptExtra vanillaOpts), + ghcOptExtra vanillaOpts, ghcOptNumJobs = mempty } `mappend` linkerOpts @@ -506,7 +586,7 @@ then do runGhcProg vanillaSharedOpts case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of - (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> do + (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> -- When the vanilla and shared library builds are done -- in one pass, only one set of HPC module interfaces -- are generated. This set should suffice for both @@ -574,17 +654,17 @@ libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest sharedLibInstallPath = libInstallPath mkSharedLibName cid libName - stubObjs <- fmap catMaybes $ sequence + stubObjs <- catMaybes <$> sequence [ findFileWithExtension [objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files , x <- libModules lib ] - stubProfObjs <- fmap catMaybes $ sequence + stubProfObjs <- catMaybes <$> sequence [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files , x <- libModules lib ] - stubSharedObjs <- fmap catMaybes $ sequence + stubSharedObjs <- catMaybes <$> sequence [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files @@ -593,12 +673,12 @@ hObjs <- Internal.getHaskellObjects implInfo lib lbi libTargetDir objExtension True hProfObjs <- - if (withProfLib lbi) + if withProfLib lbi then Internal.getHaskellObjects implInfo lib lbi libTargetDir ("p_" ++ objExtension) True else return [] hSharedObjs <- - if (withSharedLib lbi) + if withSharedLib lbi then Internal.getHaskellObjects implInfo lib lbi libTargetDir ("dyn_" ++ objExtension) False else return [] @@ -631,14 +711,15 @@ ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptInputFiles = toNubListR dynamicObjectFiles, ghcOptOutputFile = toFlag sharedLibFilePath, + ghcOptExtra = toNubListR $ + hcSharedOptions GHC libBi, -- For dynamic libs, Mac OS/X needs to know the install location -- at build time. This only applies to GHC < 7.8 - see the -- discussion in #1660. - ghcOptDylibName = if (hostOS == OSX - && ghcVersion < Version [7,8] []) + ghcOptDylibName = if hostOS == OSX + && ghcVersion < Version [7,8] [] then toFlag sharedLibInstallPath else mempty, - ghcOptPackageKey = toFlag (pkgKey lbi), ghcOptNoAutoLinkPackages = toFlag True, ghcOptPackageDBs = withPackageDB lbi, ghcOptPackages = toNubListR $ @@ -646,15 +727,17 @@ ghcOptLinkLibs = toNubListR $ extraLibs libBi, ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, + ghcOptLinkFrameworkDirs = + toNubListR $ PD.extraFrameworkDirs libBi, ghcOptRPaths = rpaths } info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) - whenVanillaLib False $ do + whenVanillaLib False $ Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles - whenProfLib $ do + whenProfLib $ Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles whenGHCiLib $ do @@ -666,16 +749,16 @@ runGhcProg ghcSharedLinkArgs -- | Start a REPL without loading any source files. -startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler +startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler -> Platform -> PackageDBStack -> IO () -startInterpreter verbosity conf comp packageDBs = do +startInterpreter verbosity conf comp platform packageDBs = do let replOpts = mempty { ghcOptMode = toFlag GhcModeInteractive, ghcOptPackageDBs = packageDBs } - checkPackageDbStack packageDBs + checkPackageDbStack comp packageDBs (ghcProg, _) <- requireProgram verbosity ghcProgram conf - runGHC verbosity ghcProg comp replOpts + runGHC verbosity ghcProg comp platform replOpts -- | Build an executable with GHC. -- @@ -693,8 +776,9 @@ (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) let comp = compiler lbi + platform = hostPlatform lbi implInfo = getImplInfo comp - runGhcProg = runGHC verbosity ghcProg comp + runGhcProg = runGHC verbosity ghcProg comp platform exeBi <- hackThreadedFlag verbosity comp (withProfExe lbi) (buildInfo exe) @@ -705,7 +789,7 @@ then exeExtension else "") - let targetDir = (buildDir lbi) exeName' + let targetDir = buildDir lbi exeName' let exeDir = targetDir (exeName' ++ "-tmp") createDirectoryIfMissingVerbose verbosity True targetDir createDirectoryIfMissingVerbose verbosity True exeDir @@ -717,6 +801,7 @@ let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi distPref = fromFlag $ configDistPref $ configFlags lbi hpcdir way + | forRepl = mempty -- HPC is not supported in ghci | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName' | otherwise = mempty @@ -744,9 +829,12 @@ } profOpts = baseOpts `mappend` mempty { ghcOptProfilingMode = toFlag True, + ghcOptProfilingAuto = Internal.profDetailLevelFlag False + (withProfExeDetail lbi), ghcOptHiSuffix = toFlag "p_hi", ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = toNubListR $ hcProfOptions GHC exeBi, + ghcOptExtra = toNubListR + (hcProfOptions GHC exeBi), ghcOptHPCDir = hpcdir Hpc.Prof } dynOpts = baseOpts `mappend` mempty { @@ -764,10 +852,13 @@ ghcOptHPCDir = hpcdir Hpc.Dyn } linkerOpts = mempty { - ghcOptLinkOptions = toNubListR $ PD.ldOptions exeBi, - ghcOptLinkLibs = toNubListR $ extraLibs exeBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs exeBi, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi, + ghcOptLinkOptions = toNubListR $ PD.ldOptions exeBi, + ghcOptLinkLibs = toNubListR $ extraLibs exeBi, + ghcOptLinkLibPath = toNubListR $ extraLibDirs exeBi, + ghcOptLinkFrameworks = toNubListR $ + PD.frameworks exeBi, + ghcOptLinkFrameworkDirs = toNubListR $ + PD.extraFrameworkDirs exeBi, ghcOptInputFiles = toNubListR [exeDir x | x <- cObjs] } @@ -816,10 +907,11 @@ | isGhcDynamic = doingTH && (withProfExe lbi || withStaticExe) | otherwise = doingTH && (withProfExe lbi || withDynExe lbi) - linkOpts = commonOpts `mappend` - linkerOpts `mappend` - mempty { ghcOptLinkNoHsMain = toFlag (not isHaskellMain) } `mappend` - (if withDynExe lbi then dynLinkerOpts else mempty) + linkOpts = + commonOpts `mappend` + linkerOpts `mappend` + mempty { ghcOptLinkNoHsMain = toFlag (not isHaskellMain) } `mappend` + (if withDynExe lbi then dynLinkerOpts else mempty) -- Build static/dynamic object files for TH, if needed. when compileForTH $ @@ -844,7 +936,7 @@ odir = fromFlag (ghcOptObjDir opts) createDirectoryIfMissingVerbose verbosity True odir needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ + when needsRecomp $ runGhcProg opts | filename <- cSrcs ] @@ -908,7 +1000,9 @@ supportRPaths IRIX = False supportRPaths HaLVM = False supportRPaths IOS = False + supportRPaths Android = False supportRPaths Ghcjs = False + supportRPaths Hurd = False supportRPaths (OtherOS _) = False -- Do _not_ add a default case so that we get a warning here when a new OS -- is added. @@ -942,11 +1036,11 @@ (compiler lbi) (withProfLib lbi) (libBuildInfo lib) let comp = compiler lbi + platform = hostPlatform lbi vanillaArgs = (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi)) `mappend` mempty { ghcOptMode = toFlag GhcModeAbiHash, - ghcOptPackageKey = toFlag (pkgKey lbi), ghcOptInputModules = toNubListR $ exposedModules lib } sharedArgs = vanillaArgs `mappend` mempty { @@ -956,19 +1050,23 @@ ghcOptObjSuffix = toFlag "dyn_o", ghcOptExtra = toNubListR $ hcSharedOptions GHC libBi } - profArgs = vanillaArgs `mappend` mempty { + profArgs = vanillaArgs `mappend` mempty { ghcOptProfilingMode = toFlag True, + ghcOptProfilingAuto = Internal.profDetailLevelFlag True + (withProfLibDetail lbi), ghcOptHiSuffix = toFlag "p_hi", ghcOptObjSuffix = toFlag "p_o", ghcOptExtra = toNubListR $ hcProfOptions GHC libBi - } - ghcArgs = if withVanillaLib lbi then vanillaArgs - else if withSharedLib lbi then sharedArgs - else if withProfLib lbi then profArgs - else error "libAbiHash: Can't find an enabled library way" - -- + } + ghcArgs + | withVanillaLib lbi = vanillaArgs + | withSharedLib lbi = sharedArgs + | withProfLib lbi = profArgs + | otherwise = error "libAbiHash: Can't find an enabled library way" + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) - hash <- getProgramInvocationOutput verbosity (ghcInvocation ghcProg comp ghcArgs) + hash <- getProgramInvocationOutput verbosity + (ghcInvocation ghcProg comp platform ghcArgs) return (takeWhile (not . isSpace) hash) componentGhcOptions :: Verbosity -> LocalBuildInfo @@ -976,6 +1074,16 @@ -> GhcOptions componentGhcOptions = Internal.componentGhcOptions +componentCcGhcOptions :: Verbosity -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath + -> GhcOptions +componentCcGhcOptions verbosity lbi = + Internal.componentCcGhcOptions verbosity implInfo lbi + where + comp = compiler lbi + implInfo = getImplInfo comp + -- ----------------------------------------------------------------------------- -- Installing @@ -1020,22 +1128,24 @@ whenShared $ copyModuleFiles "dyn_hi" -- copy the built library files over: - whenVanilla $ mapM_ (installOrdinary builtDir targetDir) vanillaLibNames - whenProf $ mapM_ (installOrdinary builtDir targetDir) profileLibNames - whenGHCi $ mapM_ (installOrdinary builtDir targetDir) ghciLibNames - whenShared $ mapM_ (installShared builtDir dynlibTargetDir) sharedLibNames + whenVanilla $ installOrdinary builtDir targetDir vanillaLibName + whenProf $ installOrdinary builtDir targetDir profileLibName + whenGHCi $ installOrdinary builtDir targetDir ghciLibName + whenShared $ installShared builtDir dynlibTargetDir sharedLibName where install isShared srcDir dstDir name = do let src = srcDir name dst = dstDir name createDirectoryIfMissingVerbose verbosity True dstDir + if isShared - then do when (stripLibs lbi) $ Strip.stripLib verbosity - (hostPlatform lbi) (withPrograms lbi) src - installExecutableFile verbosity src dst + then installExecutableFile verbosity src dst else installOrdinaryFile verbosity src dst + when (stripLibs lbi) $ Strip.stripLib verbosity + (hostPlatform lbi) (withPrograms lbi) dst + installOrdinary = install False installShared = install True @@ -1044,11 +1154,11 @@ >>= installOrdinaryFiles verbosity targetDir cid = compilerId (compiler lbi) - libNames = componentLibraries clbi - vanillaLibNames = map mkLibName libNames - profileLibNames = map mkProfLibName libNames - ghciLibNames = map Internal.mkGHCiLibName libNames - sharedLibNames = map (mkSharedLibName cid) libNames + libName = componentUnitId clbi + vanillaLibName = mkLibName libName + profileLibName = mkProfLibName libName + ghciLibName = Internal.mkGHCiLibName libName + sharedLibName = (mkSharedLibName cid) libName hasLib = not $ null (libModules lib) && null (cSources (libBuildInfo lib)) @@ -1065,7 +1175,10 @@ , HcPkg.noPkgDbStack = v < [6,9] , HcPkg.noVerboseFlag = v < [6,11] , HcPkg.flagPackageConf = v < [7,5] - , HcPkg.useSingleFileDb = v < [7,9] + , HcPkg.supportsDirDbs = v >= [6,8] + , HcPkg.requiresDirDbs = v >= [7,10] + , HcPkg.nativeMultiInstance = v >= [7,10] + , HcPkg.recacheMultiInstance = v >= [6,12] } where v = versionBranch ver @@ -1074,16 +1187,20 @@ registerPackage :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo + -> ProgramConfiguration -> Bool -> PackageDBStack + -> InstalledPackageInfo -> IO () -registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = - HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity - packageDbs (Right installedPkgInfo) +registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo + | multiInstance + = HcPkg.registerMultiInstance (hcPkgInfo progdb) verbosity + packageDbs installedPkgInfo + | otherwise + = HcPkg.reregister (hcPkgInfo progdb) verbosity + packageDbs (Right installedPkgInfo) + pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath pkgRoot verbosity lbi = pkgRoot' where @@ -1093,7 +1210,8 @@ pkgRoot' UserPackageDB = do appDir <- getAppUserDataDirectory "ghc" let ver = compilerVersion (compiler lbi) - subdir = System.Info.arch ++ '-':System.Info.os ++ '-':showVersion ver + subdir = System.Info.arch ++ '-':System.Info.os + ++ '-':showVersion ver rootDir = appDir subdir -- We must create the root directory for the user package database if it -- does not yet exists. Otherwise '${pkgroot}' will resolve to a diff --git a/Distribution/Simple/GHC/IPI641.hs b/Distribution/Simple/GHC/IPI641.hs deleted file mode 100644 --- a/Distribution/Simple/GHC/IPI641.hs +++ /dev/null @@ -1,106 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.GHC.IPI641 --- Copyright : (c) The University of Glasgow 2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- - -module Distribution.Simple.GHC.IPI641 ( - InstalledPackageInfo(..), - toCurrent, - ) where - -import qualified Distribution.InstalledPackageInfo as Current -import qualified Distribution.Package as Current hiding (depends, installedPackageId) -import Distribution.Text (display) - -import Distribution.Simple.GHC.IPI642 - ( PackageIdentifier, convertPackageId - , License, convertLicense, convertModuleName ) - --- | This is the InstalledPackageInfo type used by ghc-6.4 and 6.4.1. --- --- It's here purely for the 'Read' instance so that we can read the package --- database used by those ghc versions. It is a little hacky to read the --- package db directly, but we do need the info and until ghc-6.9 there was --- no better method. --- --- In ghc-6.4.2 the format changed a bit. See "Distribution.Simple.GHC.IPI642" --- -data InstalledPackageInfo = InstalledPackageInfo { - package :: PackageIdentifier, - license :: License, - copyright :: String, - maintainer :: String, - author :: String, - stability :: String, - homepage :: String, - pkgUrl :: String, - description :: String, - category :: String, - exposed :: Bool, - exposedModules :: [String], - hiddenModules :: [String], - importDirs :: [FilePath], - libraryDirs :: [FilePath], - hsLibraries :: [String], - extraLibraries :: [String], - includeDirs :: [FilePath], - includes :: [String], - depends :: [PackageIdentifier], - hugsOptions :: [String], - ccOptions :: [String], - ldOptions :: [String], - frameworkDirs :: [FilePath], - frameworks :: [String], - haddockInterfaces :: [FilePath], - haddockHTMLs :: [FilePath] - } - deriving Read - -mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId -mkInstalledPackageId = Current.InstalledPackageId . display - -toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo -toCurrent ipi@InstalledPackageInfo{} = - let pid = convertPackageId (package ipi) - mkExposedModule m = Current.ExposedModule m Nothing Nothing - in Current.InstalledPackageInfo { - Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)), - Current.sourcePackageId = pid, - Current.packageKey = Current.OldPackageKey pid, - Current.license = convertLicense (license ipi), - Current.copyright = copyright ipi, - Current.maintainer = maintainer ipi, - Current.author = author ipi, - Current.stability = stability ipi, - Current.homepage = homepage ipi, - Current.pkgUrl = pkgUrl ipi, - Current.synopsis = "", - Current.description = description ipi, - Current.category = category ipi, - Current.exposed = exposed ipi, - Current.exposedModules = map (mkExposedModule . convertModuleName) (exposedModules ipi), - Current.instantiatedWith = [], - Current.hiddenModules = map convertModuleName (hiddenModules ipi), - Current.trusted = Current.trusted Current.emptyInstalledPackageInfo, - Current.importDirs = importDirs ipi, - Current.libraryDirs = libraryDirs ipi, - Current.dataDir = "", - Current.hsLibraries = hsLibraries ipi, - Current.extraLibraries = extraLibraries ipi, - Current.extraGHCiLibraries = [], - Current.includeDirs = includeDirs ipi, - Current.includes = includes ipi, - Current.depends = map (mkInstalledPackageId.convertPackageId) (depends ipi), - Current.ccOptions = ccOptions ipi, - Current.ldOptions = ldOptions ipi, - Current.frameworkDirs = frameworkDirs ipi, - Current.frameworks = frameworks ipi, - Current.haddockInterfaces = haddockInterfaces ipi, - Current.haddockHTMLs = haddockHTMLs ipi, - Current.pkgRoot = Nothing - } diff --git a/Distribution/Simple/GHC/IPI642.hs b/Distribution/Simple/GHC/IPI642.hs --- a/Distribution/Simple/GHC/IPI642.hs +++ b/Distribution/Simple/GHC/IPI642.hs @@ -11,22 +11,11 @@ module Distribution.Simple.GHC.IPI642 ( InstalledPackageInfo(..), toCurrent, - - -- Don't use these, they're only for conversion purposes - PackageIdentifier, convertPackageId, - License, convertLicense, - convertModuleName ) where import qualified Distribution.InstalledPackageInfo as Current -import qualified Distribution.Package as Current hiding (depends, installedPackageId) -import qualified Distribution.License as Current - -import Distribution.Version (Version) -import Distribution.ModuleName (ModuleName) -import Distribution.Text (simpleParse,display) - -import Data.Maybe +import qualified Distribution.Package as Current hiding (installedUnitId) +import Distribution.Simple.GHC.IPIConvert -- | This is the InstalledPackageInfo type used by ghc-6.4.2 and later. -- @@ -70,43 +59,15 @@ } deriving Read -data PackageIdentifier = PackageIdentifier { - pkgName :: String, - pkgVersion :: Version - } - deriving Read - -data License = GPL | LGPL | BSD3 | BSD4 - | PublicDomain | AllRightsReserved | OtherLicense - deriving Read - -convertPackageId :: PackageIdentifier -> Current.PackageIdentifier -convertPackageId PackageIdentifier { pkgName = n, pkgVersion = v } = - Current.PackageIdentifier (Current.PackageName n) v - -mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId -mkInstalledPackageId = Current.InstalledPackageId . display - -convertModuleName :: String -> ModuleName -convertModuleName s = fromJust $ simpleParse s - -convertLicense :: License -> Current.License -convertLicense GPL = Current.GPL Nothing -convertLicense LGPL = Current.LGPL Nothing -convertLicense BSD3 = Current.BSD3 -convertLicense BSD4 = Current.BSD4 -convertLicense PublicDomain = Current.PublicDomain -convertLicense AllRightsReserved = Current.AllRightsReserved -convertLicense OtherLicense = Current.OtherLicense - toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo toCurrent ipi@InstalledPackageInfo{} = let pid = convertPackageId (package ipi) - mkExposedModule m = Current.ExposedModule m Nothing Nothing + mkExposedModule m = Current.ExposedModule m Nothing in Current.InstalledPackageInfo { - Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)), Current.sourcePackageId = pid, - Current.packageKey = Current.OldPackageKey pid, + Current.installedUnitId = Current.mkLegacyUnitId pid, + Current.compatPackageKey = "", + Current.abiHash = Current.AbiHash "", -- bogus but old GHCs don't care. Current.license = convertLicense (license ipi), Current.copyright = copyright ipi, Current.maintainer = maintainer ipi, @@ -120,7 +81,6 @@ Current.exposed = exposed ipi, Current.exposedModules = map (mkExposedModule . convertModuleName) (exposedModules ipi), Current.hiddenModules = map convertModuleName (hiddenModules ipi), - Current.instantiatedWith = [], Current.trusted = Current.trusted Current.emptyInstalledPackageInfo, Current.importDirs = importDirs ipi, Current.libraryDirs = libraryDirs ipi, @@ -130,7 +90,7 @@ Current.extraGHCiLibraries = extraGHCiLibraries ipi, Current.includeDirs = includeDirs ipi, Current.includes = includes ipi, - Current.depends = map (mkInstalledPackageId.convertPackageId) (depends ipi), + Current.depends = map (Current.mkLegacyUnitId . convertPackageId) (depends ipi), Current.ccOptions = ccOptions ipi, Current.ldOptions = ldOptions ipi, Current.frameworkDirs = frameworkDirs ipi, diff --git a/Distribution/Simple/GHC/IPIConvert.hs b/Distribution/Simple/GHC/IPIConvert.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/GHC/IPIConvert.hs @@ -0,0 +1,50 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC.IPI642 +-- Copyright : (c) The University of Glasgow 2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Helper functions for 'Distribution.Simple.GHC.IPI642'. +module Distribution.Simple.GHC.IPIConvert ( + PackageIdentifier, convertPackageId, + License, convertLicense, + convertModuleName + ) where + +import qualified Distribution.Package as Current hiding (installedUnitId) +import qualified Distribution.License as Current + +import Distribution.Version +import Distribution.ModuleName +import Distribution.Text + +import Data.Maybe + +data PackageIdentifier = PackageIdentifier { + pkgName :: String, + pkgVersion :: Version + } + deriving Read + +convertPackageId :: PackageIdentifier -> Current.PackageIdentifier +convertPackageId PackageIdentifier { pkgName = n, pkgVersion = v } = + Current.PackageIdentifier (Current.PackageName n) v + +data License = GPL | LGPL | BSD3 | BSD4 + | PublicDomain | AllRightsReserved | OtherLicense + deriving Read + +convertModuleName :: String -> ModuleName +convertModuleName s = fromJust $ simpleParse s + +convertLicense :: License -> Current.License +convertLicense GPL = Current.GPL Nothing +convertLicense LGPL = Current.LGPL Nothing +convertLicense BSD3 = Current.BSD3 +convertLicense BSD4 = Current.BSD4 +convertLicense PublicDomain = Current.PublicDomain +convertLicense AllRightsReserved = Current.AllRightsReserved +convertLicense OtherLicense = Current.OtherLicense diff --git a/Distribution/Simple/GHC/ImplInfo.hs b/Distribution/Simple/GHC/ImplInfo.hs --- a/Distribution/Simple/GHC/ImplInfo.hs +++ b/Distribution/Simple/GHC/ImplInfo.hs @@ -15,9 +15,7 @@ ) where import Distribution.Simple.Compiler - ( Compiler(..), CompilerFlavor(..) - , compilerFlavor, compilerVersion, compilerCompatVersion ) -import Distribution.Version ( Version(..) ) +import Distribution.Version {- | Information about features and quirks of a GHC-based implementation. @@ -47,6 +45,7 @@ , reportsNoExt :: Bool -- ^ --supported-languages gives Ext and NoExt , alwaysNondecIndent :: Bool -- ^ NondecreasingIndentation is always on , flagGhciScript :: Bool -- ^ -ghci-script flag supported + , flagProfAuto :: Bool -- ^ new style -fprof-auto* flags , flagPackageConf :: Bool -- ^ use package-conf instead of package-db , flagDebugInfo :: Bool -- ^ -g flag supported } @@ -80,6 +79,7 @@ , reportsNoExt = v >= [7] , alwaysNondecIndent = v < [7,1] , flagGhciScript = v >= [7,2] + , flagProfAuto = v >= [7,4] , flagPackageConf = v < [7,5] , flagDebugInfo = v >= [7,10] } @@ -100,6 +100,7 @@ , reportsNoExt = True , alwaysNondecIndent = False , flagGhciScript = True + , flagProfAuto = True , flagPackageConf = False , flagDebugInfo = False } diff --git a/Distribution/Simple/GHC/Internal.hs b/Distribution/Simple/GHC/Internal.hs --- a/Distribution/Simple/GHC/Internal.hs +++ b/Distribution/Simple/GHC/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.GHC.Internal @@ -24,55 +24,42 @@ getHaskellObjects, mkGhcOptPackages, substTopDir, - checkPackageDbEnvVar + checkPackageDbEnvVar, + profDetailLevelFlag, + showArchString, + showOsString, ) where -import Distribution.Simple.GHC.ImplInfo ( GhcImplInfo (..) ) +import Distribution.Simple.GHC.ImplInfo import Distribution.Package - ( InstalledPackageId, PackageId ) import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo_(..) ) -import Distribution.PackageDescription as PD - ( BuildInfo(..), Library(..), libModules - , hcOptions, usedExtensions, ModuleRenaming, lookupRenaming ) -import Distribution.Compat.Exception ( catchExit, catchIO ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), Compiler(..), DebugInfoLevel(..), OptimisationLevel(..) ) +import Distribution.PackageDescription as PD hiding (Flag) +import Distribution.Compat.Exception +import Distribution.Lex +import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.Program.GHC import Distribution.Simple.Setup - ( toFlag ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program - ( Program(..), ConfiguredProgram(..), ProgramConfiguration - , ProgramLocation(..), ProgramSearchPath, ProgramSearchPathEntry(..) - , rawSystemProgram, rawSystemProgramStdout, programPath - , addKnownProgram, arProgram, ldProgram, gccProgram, stripProgram - , getProgramOutput ) -import Distribution.Simple.Program.Types ( suppressOverrideArgs ) import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) - , LibraryName(..) ) import Distribution.Simple.Utils import Distribution.Simple.BuildPaths -import Distribution.System ( buildOS, OS(..), Platform, platformFromTriple ) +import Distribution.System import Distribution.Text ( display, simpleParse ) import Distribution.Utils.NubList ( toNubListR ) import Distribution.Verbosity import Language.Haskell.Extension - ( Language(..), Extension(..), KnownExtension(..) ) import qualified Data.Map as M import Data.Char ( isSpace ) import Data.Maybe ( fromMaybe, maybeToList, isJust ) import Control.Monad ( unless, when ) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid ( Monoid(..) ) -#endif +import Data.Monoid as Mon ( Monoid(..) ) import System.Directory ( getDirectoryContents, getTemporaryDirectory ) import System.Environment ( getEnv ) -import System.FilePath ( (), (<.>), takeExtension, takeDirectory ) +import System.FilePath ( (), (<.>), takeExtension + , takeDirectory, takeFileName) import System.IO ( hClose, hPutStrLn ) targetPlatform :: [(String, String)] -> Maybe Platform @@ -87,18 +74,18 @@ -> ProgramConfiguration configureToolchain implInfo ghcProg ghcInfo = addKnownProgram gccProgram { - programFindLocation = findProg gccProgram extraGccPath, + programFindLocation = findProg gccProgramName extraGccPath, programPostConf = configureGcc } . addKnownProgram ldProgram { - programFindLocation = findProg ldProgram extraLdPath, + programFindLocation = findProg ldProgramName extraLdPath, programPostConf = configureLd } . addKnownProgram arProgram { - programFindLocation = findProg arProgram extraArPath + programFindLocation = findProg arProgramName extraArPath } . addKnownProgram stripProgram { - programFindLocation = findProg stripProgram extraStripPath + programFindLocation = findProg stripProgramName extraStripPath } where compilerDir = takeDirectory (programPath ghcProg) @@ -109,6 +96,14 @@ isWindows = case buildOS of Windows -> True; _ -> False binPrefix = "" + maybeName :: Program -> Maybe FilePath -> String + maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName) + + gccProgramName = maybeName gccProgram mbGccLocation + ldProgramName = maybeName ldProgram mbLdLocation + arProgramName = maybeName arProgram mbArLocation + stripProgramName = maybeName stripProgram mbStripLocation + mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath] mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath] | otherwise = mbDir @@ -128,10 +123,11 @@ let b = mingwBinDir binPrefix in (b, b, b, b) - findProg :: Program -> [FilePath] - -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) - findProg prog extraPath v searchpath = - programFindLocation prog v searchpath' + findProg :: String -> [FilePath] + -> Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) + findProg progName extraPath v searchpath = + findProgramOnSearchPath v searchpath' progName where searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath @@ -146,12 +142,19 @@ gccLinkerFlags = getFlags "Gcc Linker flags" ldLinkerFlags = getFlags "Ld Linker flags" - getFlags key = case M.lookup key ghcInfo of - Nothing -> [] - Just flags -> - case reads flags of - [(args, "")] -> args - _ -> [] -- XXX Should should be an error really + -- It appears that GHC 7.6 and earlier encode the tokenized flags as a + -- [String] in these settings whereas later versions just encode the flags as + -- String. + -- + -- We first try to parse as a [String] and if this fails then tokenize the + -- flags ourself. + getFlags :: String -> [String] + getFlags key = + case M.lookup key ghcInfo of + Nothing -> [] + Just flags + | (flags', ""):_ <- reads flags -> flags' + | otherwise -> tokenizeQuotedWords flags configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram configureGcc v gccProg = do @@ -363,6 +366,10 @@ ghcOptVerbosity = toFlag verbosity, ghcOptHideAllPackages = toFlag True, ghcOptCabal = toFlag True, + ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo { componentCompatPackageKey = pk } + -> toFlag pk + _ -> Mon.mempty, ghcOptPackageDBs = withPackageDB lbi, ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, ghcOptSplitObjs = toFlag (splitObjs lbi), @@ -411,8 +418,8 @@ supported "-unreg" = False supported _ = True -mkGHCiLibName :: LibraryName -> String -mkGHCiLibName (LibraryName lib) = lib <.> "o" +mkGHCiLibName :: UnitId -> String +mkGHCiLibName lib = getHSLibraryName lib <.> "o" ghcLookupProperty :: String -> Compiler -> Bool ghcLookupProperty prop comp = @@ -442,7 +449,7 @@ | x <- libModules lib ] mkGhcOptPackages :: ComponentLocalBuildInfo - -> [(InstalledPackageId, PackageId, ModuleRenaming)] + -> [(UnitId, PackageId, ModuleRenaming)] mkGhcOptPackages clbi = map (\(i,p) -> (i,p,lookupRenaming p (componentPackageRenaming clbi))) (componentPackageDeps clbi) @@ -484,9 +491,38 @@ unless (mPP == mcsPP) abort where lookupEnv :: String -> IO (Maybe String) - lookupEnv name = (Just `fmap` getEnv name) `catchIO` const (return Nothing) + lookupEnv name = (Just `fmap` getEnv name) + `catchIO` const (return Nothing) abort = die $ "Use of " ++ compilerName ++ "'s environment variable " ++ packagePathEnvVar ++ " is incompatible with Cabal. Use the " ++ "flag --package-db to specify a package database (it can be " ++ "used multiple times)." + +profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto +profDetailLevelFlag forLib mpl = + case mpl of + ProfDetailNone -> mempty + ProfDetailDefault | forLib -> toFlag GhcProfAutoExported + | otherwise -> toFlag GhcProfAutoToplevel + ProfDetailExportedFunctions -> toFlag GhcProfAutoExported + ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel + ProfDetailAllFunctions -> toFlag GhcProfAutoAll + ProfDetailOther _ -> mempty + +-- | GHC's rendering of it's host or target 'Arch' as used in its platform +-- strings and certain file locations (such as user package db location). +-- +showArchString :: Arch -> String +showArchString PPC = "powerpc" +showArchString PPC64 = "powerpc64" +showArchString other = display other + +-- | GHC's rendering of it's host or target 'OS' as used in its platform +-- strings and certain file locations (such as user package db location). +-- +showOsString :: OS -> String +showOsString Windows = "mingw32" +showOsString OSX = "darwin" +showOsString Solaris = "solaris2" +showOsString other = display other diff --git a/Distribution/Simple/GHCJS.hs b/Distribution/Simple/GHCJS.hs --- a/Distribution/Simple/GHCJS.hs +++ b/Distribution/Simple/GHCJS.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - module Distribution.Simple.GHCJS ( configure, getInstalledPackages, getPackageDBContents, buildLib, buildExe, @@ -16,70 +14,40 @@ runCmd ) where -import Distribution.Simple.GHC.ImplInfo ( getImplInfo, ghcjsVersionImplInfo ) +import Distribution.Simple.GHC.ImplInfo import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), Executable(..) - , Library(..), libModules, exeModules - , hcOptions, hcProfOptions, hcSharedOptions - , allExtensions ) import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo_(..) ) +import Distribution.Package import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) - , LibraryName(..) ) import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Simple.Program - ( Program(..), ConfiguredProgram(..), ProgramConfiguration - , ProgramSearchPath - , rawSystemProgramConf - , rawSystemProgramStdout, rawSystemProgramStdoutConf - , getProgramInvocationOutput - , requireProgramVersion, requireProgram - , userMaybeSpecifyPath, programPath - , lookupProgram, addKnownPrograms - , ghcjsProgram, ghcjsPkgProgram, c2hsProgram, hsc2hsProgram - , ldProgram, haddockProgram, stripProgram ) import qualified Distribution.Simple.Program.HcPkg as HcPkg import qualified Distribution.Simple.Program.Ar as Ar import qualified Distribution.Simple.Program.Ld as Ld import qualified Distribution.Simple.Program.Strip as Strip import Distribution.Simple.Program.GHC -import Distribution.Simple.Setup - ( toFlag, fromFlag, configCoverage, configDistPref ) +import Distribution.Simple.Setup hiding ( Flag ) import qualified Distribution.Simple.Setup as Cabal - ( Flag(..) ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..) - , PackageDB(..), PackageDBStack, AbiTag(..) ) +import Distribution.Simple.Compiler hiding ( Flag ) import Distribution.Version - ( Version(..), anyVersion, orLaterVersion ) import Distribution.System - ( Platform(..) ) import Distribution.Verbosity import Distribution.Utils.NubList - ( overNubListR, toNubListR ) -import Distribution.Text ( display ) -import Language.Haskell.Extension ( Extension(..) - , KnownExtension(..)) +import Distribution.Text +import Language.Haskell.Extension import Control.Monad ( unless, when ) import Data.Char ( isSpace ) import qualified Data.Map as M ( fromList ) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid ( Monoid(..) ) -#endif +import Data.Monoid as Mon ( Monoid(..) ) import System.Directory ( doesFileExist ) -import System.FilePath ( (), (<.>), takeExtension, - takeDirectory, replaceExtension, - splitExtension ) +import System.FilePath ( (), (<.>), takeExtension + , takeDirectory, replaceExtension ) configure :: Verbosity -> Maybe FilePath -> Maybe FilePath -> ProgramConfiguration @@ -156,24 +124,24 @@ ghcjsNativeToo = Internal.ghcLookupProperty "Native Too" guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe FilePath) + -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe FilePath) + -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram guessC2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe FilePath) + -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) guessC2hsFromGhcjsPath = guessToolFromGhcjsPath c2hsProgram guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe FilePath) + -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram guessToolFromGhcjsPath :: Program -> ConfiguredProgram -> Verbosity -> ProgramSearchPath - -> IO (Maybe FilePath) + -> IO (Maybe (FilePath, [FilePath])) guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath = do let toolname = programName tool path = programPath ghcjsProg @@ -198,19 +166,15 @@ -- method. [] -> programFindLocation tool verbosity searchpath (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp - return (Just fp) + let lookedAt = map fst + . takeWhile (\(_file, exist) -> not exist) + $ zip guesses exists + return (Just (fp, lookedAt)) where takeVersionSuffix :: FilePath -> String takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") . reverse - dropExeExtension :: FilePath -> FilePath - dropExeExtension filepath = - case splitExtension filepath of - (filepath', extension) | extension == exeExtension -> filepath' - | otherwise -> filepath - - -- | Given a single package DB, return all installed packages. getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration -> IO InstalledPackageIndex @@ -302,11 +266,8 @@ -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () buildOrReplLib forRepl verbosity numJobs _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 + let libName = componentUnitId clbi + libTargetDir = buildDir lbi whenVanillaLib forceVanilla = when (not forRepl && (forceVanilla || withVanillaLib lbi)) whenProfLib = when (not forRepl && withProfLib lbi) @@ -314,14 +275,13 @@ when (not forRepl && (forceShared || withSharedLib lbi)) whenGHCiLib = when (not forRepl && withGHCiLib lbi && withVanillaLib lbi) ifReplLib = when forRepl - comp = compiler lbi - implInfo = getImplInfo comp - hole_insts = map (\(k,(p,n)) -> (k,(InstalledPackageInfo.packageKey p,n))) - (instantiatedWith lbi) + comp = compiler lbi + platform = hostPlatform lbi + implInfo = getImplInfo comp nativeToo = ghcjsNativeToo comp (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) - let runGhcjsProg = runGHC verbosity ghcjsProg comp + let runGhcjsProg = runGHC verbosity ghcjsProg comp platform libBi = libBuildInfo lib isGhcjsDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp @@ -339,7 +299,7 @@ distPref = fromFlag $ configDistPref $ configFlags lbi hpcdir way | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname - | otherwise = mempty + | otherwise = Mon.mempty createDirectoryIfMissingVerbose verbosity True libTargetDir -- TODO: do we need to put hs-boot files into place for mutually recursive @@ -349,15 +309,13 @@ baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir linkJsLibOpts = mempty { ghcOptExtra = toNubListR $ - [ "-link-js-lib" , (\(LibraryName l) -> l) libName + [ "-link-js-lib" , getHSLibraryName libName , "-js-lib-outputdir", libTargetDir ] ++ concatMap (\x -> ["-js-lib-src",x]) jsSrcs } vanillaOptsNoJsLib = baseOpts `mappend` mempty { ghcOptMode = toFlag GhcModeMake, ghcOptNumJobs = numJobs, - ghcOptPackageKey = toFlag (pkgKey lbi), - ghcOptSigOf = hole_insts, ghcOptInputModules = toNubListR $ libModules lib, ghcOptHPCDir = hpcdir Hpc.Vanilla } @@ -507,7 +465,8 @@ ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptInputFiles = toNubListR dynamicObjectFiles, ghcOptOutputFile = toFlag sharedLibFilePath, - ghcOptPackageKey = toFlag (pkgKey lbi), + ghcOptExtra = toNubListR $ + ghcjsSharedOptions libBi, ghcOptNoAutoLinkPackages = toFlag True, ghcOptPackageDBs = withPackageDB lbi, ghcOptPackages = toNubListR $ @@ -531,16 +490,16 @@ runGhcjsProg ghcSharedLinkArgs -- | Start a REPL without loading any source files. -startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler +startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler -> Platform -> PackageDBStack -> IO () -startInterpreter verbosity conf comp packageDBs = do +startInterpreter verbosity conf comp platform packageDBs = do let replOpts = mempty { ghcOptMode = toFlag GhcModeInteractive, ghcOptPackageDBs = packageDBs } checkPackageDbStack packageDBs (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram conf - runGHC verbosity ghcjsProg comp replOpts + runGHC verbosity ghcjsProg comp platform replOpts buildExe, replExe :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo @@ -556,8 +515,9 @@ (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) let comp = compiler lbi + platform = hostPlatform lbi implInfo = getImplInfo comp - runGhcjsProg = runGHC verbosity ghcjsProg comp + runGhcjsProg = runGHC verbosity ghcjsProg comp platform exeBi = buildInfo exe -- exeNameReal, the name that GHC really uses (with .exe on Windows) @@ -728,9 +688,9 @@ whenProf $ copyModuleFiles "js_p_hi" whenShared $ copyModuleFiles "js_dyn_hi" - whenVanilla $ mapM_ (installOrdinary builtDir targetDir . toJSLibName) vanillaLibNames - whenProf $ mapM_ (installOrdinary builtDir targetDir . toJSLibName) profileLibNames - whenShared $ mapM_ (installShared builtDir dynlibTargetDir . toJSLibName) sharedLibNames + whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName + whenProf $ installOrdinary builtDir targetDir $ toJSLibName profileLibName + whenShared $ installShared builtDir dynlibTargetDir $ toJSLibName sharedLibName when (ghcjsNativeToo $ compiler lbi) $ do -- copy .hi files over: @@ -739,35 +699,41 @@ whenShared $ copyModuleFiles "dyn_hi" -- copy the built library files over: - whenVanilla $ mapM_ (installOrdinary builtDir targetDir) vanillaLibNames - whenProf $ mapM_ (installOrdinary builtDir targetDir) profileLibNames - whenGHCi $ mapM_ (installOrdinary builtDir targetDir) ghciLibNames - whenShared $ mapM_ (installShared builtDir dynlibTargetDir) sharedLibNames + whenVanilla $ installOrdinaryNative builtDir targetDir vanillaLibName + whenProf $ installOrdinaryNative builtDir targetDir profileLibName + whenGHCi $ installOrdinaryNative builtDir targetDir ghciLibName + whenShared $ installSharedNative builtDir dynlibTargetDir sharedLibName where - install isShared srcDir dstDir name = do + install isShared isJS srcDir dstDir name = do let src = srcDir name dst = dstDir name createDirectoryIfMissingVerbose verbosity True dstDir + if isShared - then do when (stripLibs lbi) $ Strip.stripLib verbosity - (hostPlatform lbi) (withPrograms lbi) src - installExecutableFile verbosity src dst + then installExecutableFile verbosity src dst else installOrdinaryFile verbosity src dst - installOrdinary = install False - installShared = install True + when (stripLibs lbi && not isJS) $ + Strip.stripLib verbosity + (hostPlatform lbi) (withPrograms lbi) dst + installOrdinary = install False True + installShared = install True True + + installOrdinaryNative = install False False + installSharedNative = install True False + copyModuleFiles ext = findModuleFiles [builtDir] [ext] (libModules lib) >>= installOrdinaryFiles verbosity targetDir cid = compilerId (compiler lbi) - libNames = componentLibraries clbi - vanillaLibNames = map mkLibName libNames - profileLibNames = map mkProfLibName libNames - ghciLibNames = map Internal.mkGHCiLibName libNames - sharedLibNames = map (mkSharedLibName cid) libNames + libName = componentUnitId clbi + vanillaLibName = mkLibName libName + profileLibName = mkProfLibName libName + ghciLibName = Internal.mkGHCiLibName libName + sharedLibName = (mkSharedLibName cid) libName hasLib = not $ null (libModules lib) && null (cSources (libBuildInfo lib)) @@ -807,12 +773,12 @@ let libBi = libBuildInfo lib comp = compiler lbi + platform = hostPlatform lbi vanillaArgs = (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi)) `mappend` mempty { ghcOptMode = toFlag GhcModeAbiHash, - ghcOptPackageKey = toFlag (pkgKey lbi), - ghcOptInputModules = toNubListR $ exposedModules lib + ghcOptInputModules = toNubListR $ PD.exposedModules lib } profArgs = adjustExts "js_p_hi" "js_p_o" vanillaArgs `mappend` mempty { ghcOptProfilingMode = toFlag True, @@ -823,7 +789,8 @@ else error "libAbiHash: Can't find an enabled library way" -- (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) - getProgramInvocationOutput verbosity (ghcInvocation ghcjsProg comp ghcArgs) + getProgramInvocationOutput verbosity + (ghcInvocation ghcjsProg comp platform ghcArgs) adjustExts :: String -> String -> GhcOptions -> GhcOptions adjustExts hiSuf objSuf opts = @@ -833,16 +800,20 @@ } registerPackage :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo + -> ProgramConfiguration -> Bool -> PackageDBStack + -> InstalledPackageInfo -> IO () -registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = - HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity packageDbs - (Right installedPkgInfo) +registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo + | multiInstance + = HcPkg.registerMultiInstance (hcPkgInfo progdb) verbosity + packageDbs installedPkgInfo + | otherwise + = HcPkg.reregister (hcPkgInfo progdb) verbosity + packageDbs (Right installedPkgInfo) + componentGhcOptions :: Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> GhcOptions @@ -882,7 +853,10 @@ , HcPkg.noPkgDbStack = False , HcPkg.noVerboseFlag = False , HcPkg.flagPackageConf = False - , HcPkg.useSingleFileDb = v < [7,9] + , HcPkg.supportsDirDbs = True + , HcPkg.requiresDirDbs = v >= [7,10] + , HcPkg.nativeMultiInstance = v >= [7,10] + , HcPkg.recacheMultiInstance = True } where v = versionBranch ver diff --git a/Distribution/Simple/Haddock.hs b/Distribution/Simple/Haddock.hs --- a/Distribution/Simple/Haddock.hs +++ b/Distribution/Simple/Haddock.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveGeneric #-} + ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Haddock @@ -24,61 +26,27 @@ import qualified Distribution.Simple.GHCJS as GHCJS -- local +import Distribution.Compat.Semigroup as Semi import Distribution.Package - ( PackageIdentifier(..) - , Package(..) - , PackageName(..), packageName ) import qualified Distribution.ModuleName as ModuleName -import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), usedExtensions - , hcSharedOptions - , Library(..), hasLibs, Executable(..) - , TestSuite(..), TestSuiteInterface(..) - , Benchmark(..), BenchmarkInterface(..) ) -import Distribution.Simple.Compiler - ( Compiler, compilerInfo, CompilerFlavor(..) - , compilerFlavor, compilerCompatVersion ) +import Distribution.PackageDescription as PD hiding (Flag) +import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.Program.GHC - ( GhcOptions(..), GhcDynLinkMode(..), renderGhcOptions ) import Distribution.Simple.Program - ( ConfiguredProgram(..), lookupProgramVersion, requireProgramVersion - , rawSystemProgram, rawSystemProgramStdout - , hscolourProgram, haddockProgram ) import Distribution.Simple.PreProcess - ( PPSuffixHandler, preprocessComponent) import Distribution.Simple.Setup - ( defaultHscolourFlags - , Flag(..), toFlag, flagToMaybe, flagToList, fromFlag - , HaddockFlags(..), HscolourFlags(..) ) -import Distribution.Simple.Build (initialBuildSteps) +import Distribution.Simple.Build import Distribution.Simple.InstallDirs - ( InstallDirs(..) - , PathTemplateEnv, PathTemplate, PathTemplateVariable(..) - , toPathTemplate, fromPathTemplate - , substPathTemplate, initialPathTemplateEnv ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..) - , withAllComponentsInBuildOrder ) +import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate) import Distribution.Simple.BuildPaths - ( haddockName, hscolourPref, autogenModulesDir) -import Distribution.Simple.PackageIndex (dependencyClosure) import qualified Distribution.Simple.PackageIndex as PackageIndex import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo_(..) ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) +import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import Distribution.Simple.Utils - ( die, copyFileTo, warn, notice, intercalate, setupMessage - , createDirectoryIfMissingVerbose - , TempFileOptions(..), defaultTempFileOptions - , withTempFileEx, copyFileVerbose - , withTempDirectoryEx, matchFileGlob - , findFileWithExtension, findFile ) +import Distribution.System import Distribution.Text - ( display, simpleParse ) import Distribution.Utils.NubList - ( toNubListR ) - +import Distribution.Version import Distribution.Verbosity import Language.Haskell.Extension @@ -86,15 +54,14 @@ import Control.Monad ( when, forM_ ) import Data.Char ( isSpace ) import Data.Either ( rights ) -import Data.Monoid -import Data.Foldable ( foldl' ) +import Data.Foldable ( traverse_, foldl' ) import Data.Maybe ( fromMaybe, listToMaybe ) +import GHC.Generics ( Generic ) import System.Directory (doesFileExist) import System.FilePath ( (), (<.>) , normalise, splitPath, joinPath, isAbsolute ) import System.IO (hClose, hPutStr, hPutStrLn, hSetEncoding, utf8) -import Distribution.Version -- ------------------------------------------------------------------------------ -- Types @@ -133,7 +100,7 @@ -- ^ To find the correct GHC, required. argTargets :: [FilePath] -- ^ Modules to process. -} +} deriving Generic -- | The FilePath of a directory, it's a monoid under '()'. newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord) @@ -163,7 +130,28 @@ ++ "a library. Perhaps you want to use the --executables, --tests or" ++ " --benchmarks flags." -haddock pkg_descr lbi suffixes flags = do +haddock pkg_descr lbi suffixes flags' = do + let verbosity = flag haddockVerbosity + comp = compiler lbi + platform = hostPlatform lbi + + flags + | fromFlag (haddockForHackage flags') = flags' + { haddockHoogle = Flag True + , haddockHtml = Flag True + , haddockHtmlLocation = Flag (pkg_url ++ "/docs") + , haddockContents = Flag (toPathTemplate pkg_url) + , haddockHscolour = Flag True + } + | otherwise = flags' + pkg_url = "/package/$pkg-$version" + flag f = fromFlag $ f flags + + tmpFileOpts = defaultTempFileOptions + { optKeepTempFiles = flag haddockKeepTempFiles } + htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation + $ flags + setupMessage verbosity "Running Haddock for" (packageId pkg_descr) (confHaddock, version, _) <- requireProgramVersion verbosity haddockProgram @@ -199,7 +187,8 @@ let commonArgs = mconcat [ libdirArgs , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags - , fromPackageDescription pkg_descr ] + , fromPackageDescription forDist pkg_descr ] + forDist = fromFlagOrDefault False (haddockForHackage flags) let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do @@ -212,7 +201,8 @@ exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate version let exeArgs' = commonArgs `mappend` exeArgs - runHaddock verbosity tmpFileOpts comp confHaddock exeArgs' + runHaddock verbosity tmpFileOpts comp platform + confHaddock exeArgs' Nothing -> do warn (fromFlag $ haddockVerbosity flags) "Unsupported component, skipping..." @@ -224,7 +214,7 @@ libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate version let libArgs' = commonArgs `mappend` libArgs - runHaddock verbosity tmpFileOpts comp confHaddock libArgs' + runHaddock verbosity tmpFileOpts comp platform confHaddock libArgs' CExe _ -> when (flag haddockExecutables) $ doExe component CTest _ -> when (flag haddockTestSuites) $ doExe component CBench _ -> when (flag haddockBenchmarks) $ doExe component @@ -232,14 +222,6 @@ forM_ (extraDocFiles pkg_descr) $ \ fpath -> do files <- matchFileGlob fpath forM_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs) - where - verbosity = flag haddockVerbosity - keepTempFiles = flag haddockKeepTempFiles - comp = compiler lbi - tmpFileOpts = defaultTempFileOptions { optKeepTempFiles = keepTempFiles } - flag f = fromFlag $ f flags - htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation - $ flags -- ------------------------------------------------------------------------------ -- Contributions to HaddockArgs. @@ -267,12 +249,11 @@ argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags } -fromPackageDescription :: PackageDescription -> HaddockArgs -fromPackageDescription pkg_descr = +fromPackageDescription :: Bool -> PackageDescription -> HaddockArgs +fromPackageDescription forDist pkg_descr = mempty { argInterfaceFile = Flag $ haddockName pkg_descr, argPackageName = Flag $ packageId $ pkg_descr, - argOutputDir = Dir $ "doc" "html" - display (packageName pkg_descr), + argOutputDir = Dir $ "doc" "html" name, argPrologue = Flag $ if null desc then synopsis pkg_descr else desc, argTitle = Flag $ showPkg ++ subtitle @@ -280,6 +261,9 @@ where desc = PD.description pkg_descr showPkg = display (packageId pkg_descr) + name + | forDist = showPkg ++ "-docs" + | otherwise = display (packageName pkg_descr) subtitle | null (synopsis pkg_descr) = "" | otherwise = ": " ++ synopsis pkg_descr @@ -311,8 +295,7 @@ -- haddock to write them elsewhere. ghcOptObjDir = toFlag tmp, ghcOptHiDir = toFlag tmp, - ghcOptStubDir = toFlag tmp, - ghcOptPackageKey = toFlag $ pkgKey lbi + ghcOptStubDir = toFlag tmp } `mappend` getGhcCppOpts haddockVersion bi sharedOpts = vanillaOpts { ghcOptDynLinkMode = toFlag GhcDynamicOnly, @@ -411,7 +394,7 @@ -> IO HaddockArgs getInterfaces verbosity lbi clbi htmlTemplate = do (packageFlags, warnings) <- haddockPackageFlags lbi clbi htmlTemplate - maybe (return ()) (warn verbosity) warnings + traverse_ (warn verbosity) warnings return $ mempty { argInterfaces = packageFlags } @@ -446,13 +429,14 @@ runHaddock :: Verbosity -> TempFileOptions -> Compiler + -> Platform -> ConfiguredProgram -> HaddockArgs -> IO () -runHaddock verbosity tmpFileOpts comp confHaddock args = do +runHaddock verbosity tmpFileOpts comp platform confHaddock args = do let haddockVersion = fromMaybe (error "unable to determine haddock version") (programVersion confHaddock) - renderArgs verbosity tmpFileOpts haddockVersion comp args $ + renderArgs verbosity tmpFileOpts haddockVersion comp platform args $ \(flags,result)-> do rawSystemProgram verbosity confHaddock flags @@ -464,10 +448,11 @@ -> TempFileOptions -> Version -> Compiler + -> Platform -> HaddockArgs -> (([String], FilePath) -> IO a) -> IO a -renderArgs verbosity tmpFileOpts version comp args k = do +renderArgs verbosity tmpFileOpts version comp platform args k = do let haddockSupportsUTF8 = version >= Version [2,14,4] [] haddockSupportsResponseFiles = version > Version [2,16,2] [] createDirectoryIfMissingVerbose verbosity True outputDir @@ -478,8 +463,8 @@ hPutStrLn h $ fromFlag $ argPrologue args hClose h let pflag = "--prologue=" ++ prologueFileName - renderedArgs = pflag : renderPureArgs version comp args - if haddockSupportsResponseFiles + renderedArgs = pflag : renderPureArgs version comp platform args + if haddockSupportsResponseFiles then withTempFileEx tmpFileOpts outputDir "haddock-response.txt" $ \responseFileName hf -> do @@ -516,8 +501,8 @@ | otherwise = c:cs escapeArg = reverse . foldl' escape [] -renderPureArgs :: Version -> Compiler -> HaddockArgs -> [String] -renderPureArgs version comp args = concat +renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String] +renderPureArgs version comp platform args = concat [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) f) . fromFlag . argInterfaceFile $ args @@ -559,7 +544,7 @@ . fromFlag . argTitle $ args , [ "--optghc=" ++ opt | (opts, _ghcVer) <- flagToList (argGhcOptions args) - , opt <- renderGhcOptions comp opts ] + , opt <- renderGhcOptions comp platform opts ] , maybe [] (\l -> ["-B"++l]) $ flagToMaybe (argGhcLibDir args) -- error if Nothing? @@ -631,7 +616,7 @@ haddockPackageFlags lbi clbi htmlTemplate = do let allPkgs = installedPkgs lbi directDeps = map fst (componentPackageDeps clbi) - transitiveDeps <- case dependencyClosure allPkgs directDeps of + transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of Left x -> return x Right inf -> die $ "internal error when calculating transitive " ++ "package dependencies.\nDebug info: " ++ show inf @@ -646,7 +631,9 @@ haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv haddockTemplateEnv lbi pkg_id = (PrefixVar, prefix (installDirTemplates lbi)) - : initialPathTemplateEnv pkg_id (pkgKey lbi) (compilerInfo (compiler lbi)) + -- We want the legacy unit ID here, because it gives us nice paths + -- (Haddock people don't care about the dependencies) + : initialPathTemplateEnv pkg_id (mkLegacyUnitId pkg_id) (compilerInfo (compiler lbi)) (hostPlatform lbi) -- ------------------------------------------------------------------------------ @@ -776,44 +763,15 @@ -- ------------------------------------------------------------------------------ -- Boilerplate Monoid instance. instance Monoid HaddockArgs where - mempty = HaddockArgs { - argInterfaceFile = mempty, - argPackageName = mempty, - argHideModules = mempty, - argIgnoreExports = mempty, - argLinkSource = mempty, - argCssFile = mempty, - argContents = mempty, - argVerbose = mempty, - argOutput = mempty, - argInterfaces = mempty, - argOutputDir = mempty, - argTitle = mempty, - argPrologue = mempty, - argGhcOptions = mempty, - argGhcLibDir = mempty, - argTargets = mempty - } - mappend a b = HaddockArgs { - argInterfaceFile = mult argInterfaceFile, - argPackageName = mult argPackageName, - argHideModules = mult argHideModules, - argIgnoreExports = mult argIgnoreExports, - argLinkSource = mult argLinkSource, - argCssFile = mult argCssFile, - argContents = mult argContents, - argVerbose = mult argVerbose, - argOutput = mult argOutput, - argInterfaces = mult argInterfaces, - argOutputDir = mult argOutputDir, - argTitle = mult argTitle, - argPrologue = mult argPrologue, - argGhcOptions = mult argGhcOptions, - argGhcLibDir = mult argGhcLibDir, - argTargets = mult argTargets - } - where mult f = f a `mappend` f b + mempty = gmempty + mappend = (Semi.<>) +instance Semigroup HaddockArgs where + (<>) = gmappend + instance Monoid Directory where mempty = Dir "." - mappend (Dir m) (Dir n) = Dir $ m n + mappend = (Semi.<>) + +instance Semigroup Directory where + Dir m <> Dir n = Dir $ m n diff --git a/Distribution/Simple/HaskellSuite.hs b/Distribution/Simple/HaskellSuite.hs --- a/Distribution/Simple/HaskellSuite.hs +++ b/Distribution/Simple/HaskellSuite.hs @@ -1,10 +1,6 @@ -{-# LANGUAGE CPP #-} module Distribution.Simple.HaskellSuite where import Control.Monad -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Data.Maybe import Data.Version import qualified Data.Map as M (empty) @@ -24,7 +20,6 @@ import Distribution.Compat.Exception import Language.Haskell.Extension import Distribution.Simple.Program.Builtin - (haskellSuiteProgram, haskellSuitePkgProgram) configure :: Verbosity -> Maybe FilePath -> Maybe FilePath @@ -60,7 +55,7 @@ let haskellSuiteProgram' = haskellSuiteProgram - { programFindLocation = \v _p -> findProgramLocation v hcPath } + { programFindLocation = \v p -> findProgramOnSearchPath v p hcPath } -- NB: cannot call requireProgram right away — it'd think that -- the program is already configured and won't reconfigure it again. @@ -106,7 +101,7 @@ getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Compiler.Flag)] getExtensions verbosity prog = do extStrs <- - lines <$> + lines `fmap` rawSystemStdout verbosity (programPath prog) ["--supported-extensions"] return [ (ext, "-X" ++ display ext) | Just ext <- map simpleParse extStrs ] @@ -114,7 +109,7 @@ getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Compiler.Flag)] getLanguages verbosity prog = do langStrs <- - lines <$> + lines `fmap` rawSystemStdout verbosity (programPath prog) ["--supported-languages"] return [ (ext, "-G" ++ display ext) | Just ext <- map simpleParse langStrs ] @@ -190,8 +185,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 let conf = withPrograms lbi runDbProgram verbosity haskellSuitePkgProgram conf $ [ "install-library" @@ -203,14 +199,12 @@ registerPackage :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo - -> Bool + -> ProgramConfiguration -> PackageDBStack + -> InstalledPackageInfo -> IO () -registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do - (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram (withPrograms lbi) +registerPackage verbosity progdb packageDbs installedPkgInfo = do + (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb runProgramInvocation verbosity $ (programInvocation hspkg diff --git a/Distribution/Simple/Install.hs b/Distribution/Simple/Install.hs --- a/Distribution/Simple/Install.hs +++ b/Distribution/Simple/Install.hs @@ -16,13 +16,9 @@ install, ) where -import Distribution.PackageDescription ( - PackageDescription(..), BuildInfo(..), Library(..), - hasLibs, withLib, hasExes, withExe ) +import Distribution.PackageDescription import Distribution.Package (Package(..)) -import Distribution.Simple.LocalBuildInfo ( - LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs, - substPathTemplate, withLibLBI) +import Distribution.Simple.LocalBuildInfo import Distribution.Simple.BuildPaths (haddockName, haddockPref) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose @@ -69,6 +65,8 @@ htmldir = htmlPref, haddockdir = interfacePref, includedir = incPref}) + -- Using the library clbi for binPref is a hack; + -- binPref should be computed per executable = absoluteInstallDirs pkg_descr lbi copydest --TODO: decide if we need the user to be able to control the libdir @@ -79,6 +77,8 @@ progPrefixPref = substPathTemplate (packageId pkg_descr) lbi (progPrefix lbi) progSuffixPref = substPathTemplate (packageId pkg_descr) lbi (progSuffix lbi) + unless (hasLibs pkg_descr || hasExes pkg_descr) $ + die "No executables and no library found. Nothing to do." docExists <- doesDirectoryExist $ haddockPref distPref pkg_descr info verbosity ("directory " ++ haddockPref distPref pkg_descr ++ " does exist: " ++ show docExists) @@ -124,32 +124,33 @@ -- 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 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 - GHCJS-> do withLibLBI pkg_descr lbi $ - GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr - withExe pkg_descr $ - GHCJS.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr - LHC -> do withLibLBI pkg_descr lbi $ - LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr - withExe pkg_descr $ - LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr - JHC -> do withLib pkg_descr $ - JHC.installLib verbosity libPref buildPref pkg_descr - withExe pkg_descr $ - JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr - UHC -> do withLib pkg_descr $ UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr - HaskellSuite {} -> - withLib pkg_descr $ - HaskellSuite.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr - _ -> die $ "installing with " - ++ display (compilerFlavor (compiler lbi)) - ++ " is not implemented" + withLibLBI pkg_descr lbi $ + case compilerFlavor (compiler lbi) of + GHC -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + LHC -> LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + JHC -> JHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + UHC -> UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + HaskellSuite _ -> HaskellSuite.installLib + verbosity lbi libPref dynlibPref buildPref pkg_descr + _ -> \_ _ -> die $ "installing with " + ++ display (compilerFlavor (compiler lbi)) + ++ " is not implemented" + + withExe pkg_descr $ + case compilerFlavor (compiler lbi) of + GHC -> GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr + GHCJS -> GHCJS.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr + LHC -> LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr + JHC -> JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr + UHC -> \_ -> return () + HaskellSuite {} -> \_ -> return () + _ -> \_ -> die $ "installing with " + ++ display (compilerFlavor (compiler lbi)) + ++ " is not implemented" -- 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,4 +1,6 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- @@ -45,25 +47,19 @@ import Distribution.Compat.Binary (Binary) +import Distribution.Compat.Semigroup as Semi +import Distribution.Package +import Distribution.System +import Distribution.Compiler +import Distribution.Text + import Data.List (isPrefixOf) import Data.Maybe (fromMaybe) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (Monoid(..)) -#endif import GHC.Generics (Generic) import System.Directory (getAppUserDataDirectory) import System.FilePath ((), isPathSeparator, pathSeparator) import System.FilePath (dropDrive) -import Distribution.Package - ( PackageIdentifier, PackageKey, packageName, packageVersion, packageKeyLibraryName ) -import Distribution.System - ( OS(..), buildOS, Platform(..) ) -import Distribution.Compiler - ( AbiTag(..), abiTagString, CompilerInfo(..), CompilerFlavor(..) ) -import Distribution.Text - ( display ) - #if mingw32_HOST_OS import Foreign import Foreign.C @@ -95,46 +91,16 @@ htmldir :: dir, haddockdir :: dir, sysconfdir :: dir - } deriving (Generic, Read, Show) + } deriving (Eq, Read, Show, Functor, Generic) instance Binary dir => Binary (InstallDirs dir) -instance Functor InstallDirs where - fmap f dirs = InstallDirs { - prefix = f (prefix dirs), - bindir = f (bindir dirs), - libdir = f (libdir dirs), - libsubdir = f (libsubdir dirs), - dynlibdir = f (dynlibdir dirs), - libexecdir = f (libexecdir dirs), - includedir = f (includedir dirs), - datadir = f (datadir dirs), - datasubdir = f (datasubdir dirs), - docdir = f (docdir dirs), - mandir = f (mandir dirs), - htmldir = f (htmldir dirs), - haddockdir = f (haddockdir dirs), - sysconfdir = f (sysconfdir dirs) - } +instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where + mempty = gmempty + mappend = (Semi.<>) -instance Monoid dir => Monoid (InstallDirs dir) where - mempty = InstallDirs { - prefix = mempty, - bindir = mempty, - libdir = mempty, - libsubdir = mempty, - dynlibdir = mempty, - libexecdir = mempty, - includedir = mempty, - datadir = mempty, - datasubdir = mempty, - docdir = mempty, - mandir = mempty, - htmldir = mempty, - haddockdir = mempty, - sysconfdir = mempty - } - mappend = combineInstallDirs mappend +instance Semigroup dir => Semigroup (InstallDirs dir) where + (<>) = gmappend combineInstallDirs :: (a -> b -> c) -> InstallDirs a @@ -286,13 +252,13 @@ -- substituting for all the variables in the abstract paths, to get real -- absolute path. absoluteInstallDirs :: PackageIdentifier - -> PackageKey + -> UnitId -> CompilerInfo -> CopyDest -> Platform -> InstallDirs PathTemplate -> InstallDirs FilePath -absoluteInstallDirs pkgId pkg_key compilerId copydest platform dirs = +absoluteInstallDirs pkgId libname compilerId copydest platform dirs = (case copydest of CopyTo destdir -> fmap ((destdir ) . dropDrive) _ -> id) @@ -300,7 +266,7 @@ . fmap fromPathTemplate $ substituteInstallDirTemplates env dirs where - env = initialPathTemplateEnv pkgId pkg_key compilerId platform + env = initialPathTemplateEnv pkgId libname compilerId platform -- |The location prefix for the /copy/ command. @@ -316,12 +282,12 @@ -- independent\" package). -- prefixRelativeInstallDirs :: PackageIdentifier - -> PackageKey + -> UnitId -> CompilerInfo -> Platform -> InstallDirTemplates -> InstallDirs (Maybe FilePath) -prefixRelativeInstallDirs pkgId pkg_key compilerId platform dirs = +prefixRelativeInstallDirs pkgId libname compilerId platform dirs = fmap relative . appendSubdirs combinePathTemplate $ -- substitute the path template into each other, except that we map @@ -331,7 +297,7 @@ prefix = PathTemplate [Variable PrefixVar] } where - env = initialPathTemplateEnv pkgId pkg_key compilerId platform + env = initialPathTemplateEnv pkgId libname compilerId platform -- If it starts with $prefix then it's relative and produce the relative -- path by stripping off $prefix/ or $prefix @@ -348,7 +314,8 @@ -- | An abstract path, possibly containing variables that need to be -- substituted for to get a real 'FilePath'. -- -newtype PathTemplate = PathTemplate [PathComponent] deriving (Eq, Generic, Ord) +newtype PathTemplate = PathTemplate [PathComponent] + deriving (Eq, Ord, Generic) instance Binary PathTemplate @@ -371,8 +338,7 @@ | PkgNameVar -- ^ The @$pkg@ package name path variable | PkgVerVar -- ^ The @$version@ package version path variable | PkgIdVar -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@ - | PkgKeyVar -- ^ The @$pkgkey@ package key path variable - | LibNameVar -- ^ The @$libname@ expanded package key path variable + | LibNameVar -- ^ The @$libname@ path variable | CompilerVar -- ^ The compiler name and version, eg @ghc-6.6.1@ | OSVar -- ^ The operating system name, eg @windows@ or @linux@ | ArchVar -- ^ The CPU architecture name, eg @i386@ or @x86_64@ @@ -415,22 +381,21 @@ -- | The initial environment has all the static stuff but no paths initialPathTemplateEnv :: PackageIdentifier - -> PackageKey + -> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv -initialPathTemplateEnv pkgId pkg_key compiler platform = - packageTemplateEnv pkgId pkg_key +initialPathTemplateEnv pkgId libname compiler platform = + packageTemplateEnv pkgId libname ++ compilerTemplateEnv compiler ++ platformTemplateEnv platform ++ abiTemplateEnv compiler platform -packageTemplateEnv :: PackageIdentifier -> PackageKey -> PathTemplateEnv -packageTemplateEnv pkgId pkg_key = +packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv +packageTemplateEnv pkgId libname = [(PkgNameVar, PathTemplate [Ordinary $ display (packageName pkgId)]) ,(PkgVerVar, PathTemplate [Ordinary $ display (packageVersion pkgId)]) - ,(PkgKeyVar, PathTemplate [Ordinary $ display pkg_key]) - ,(LibNameVar, PathTemplate [Ordinary $ packageKeyLibraryName pkgId pkg_key]) + ,(LibNameVar, PathTemplate [Ordinary $ display libname]) ,(PkgIdVar, PathTemplate [Ordinary $ display pkgId]) ] @@ -479,8 +444,7 @@ instance Show PathTemplateVariable where show PrefixVar = "prefix" - show PkgKeyVar = "pkgkey" - show LibNameVar = "libname" + show LibNameVar = "libname" show BindirVar = "bindir" show LibdirVar = "libdir" show LibsubdirVar = "libsubdir" @@ -517,8 +481,8 @@ ,("docdir", DocdirVar) ,("htmldir", HtmldirVar) ,("pkgid", PkgIdVar) - ,("pkgkey", PkgKeyVar) ,("libname", LibNameVar) + ,("pkgkey", LibNameVar) -- backwards compatibility ,("pkg", PkgNameVar) ,("version", PkgVerVar) ,("compiler", CompilerVar) diff --git a/Distribution/Simple/JHC.hs b/Distribution/Simple/JHC.hs --- a/Distribution/Simple/JHC.hs +++ b/Distribution/Simple/JHC.hs @@ -16,40 +16,23 @@ installLib, installExe ) where -import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), Executable(..) - , Library(..), libModules, hcOptions, usedExtensions ) +import Distribution.PackageDescription as PD hiding (Flag) import Distribution.InstalledPackageInfo - ( emptyInstalledPackageInfo, ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) import Distribution.Simple.BuildPaths - ( autogenModulesDir, exeExtension ) import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..), AbiTag(..) - , PackageDBStack, Flag, languageToFlags, extensionsToFlags ) import Language.Haskell.Extension - ( Language(Haskell98), Extension(..), KnownExtension(..)) import Distribution.Simple.Program - ( ConfiguredProgram(..), jhcProgram, ProgramConfiguration - , userMaybeSpecifyPath, requireProgramVersion, lookupProgram - , rawSystemProgram, rawSystemProgramStdoutConf ) import Distribution.Version - ( Version(..), orLaterVersion ) import Distribution.Package - ( Package(..), InstalledPackageId(InstalledPackageId), - pkgName, pkgVersion, ) import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, writeFileAtomic - , installOrdinaryFile, installExecutableFile - , intercalate ) -import System.FilePath ( () ) import Distribution.Verbosity import Distribution.Text - ( Text(parse), display ) + +import System.FilePath ( () ) import Distribution.Compat.ReadP ( readP_to_S, string, skipSpaces ) import Distribution.System ( Platform ) @@ -116,8 +99,7 @@ return $ PackageIndex.fromList $ map (\p -> emptyInstalledPackageInfo { - InstalledPackageInfo.installedPackageId = - InstalledPackageId (display p), + InstalledPackageInfo.installedUnitId = mkLegacyUnitId p, InstalledPackageInfo.sourcePackageId = p }) $ concatMap parseLine $ @@ -181,8 +163,16 @@ ,sline "hidden-modules" (comma . otherModules . libBuildInfo . lib) ] -installLib :: Verbosity -> FilePath -> FilePath -> PackageDescription -> Library -> IO () -installLib verb dest build_dir pkg_descr _ = do +installLib :: Verbosity + -> LocalBuildInfo + -> FilePath + -> FilePath + -> FilePath + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () +installLib verb _lbi dest _dyn_dest build_dir pkg_descr _lib _clbi = do let p = display (packageId pkg_descr)++".hl" createDirectoryIfMissingVerbose verb True dest installOrdinaryFile verb (build_dir p) (dest p) diff --git a/Distribution/Simple/LHC.hs b/Distribution/Simple/LHC.hs --- a/Distribution/Simple/LHC.hs +++ b/Distribution/Simple/LHC.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.LHC @@ -41,67 +40,37 @@ ghcVerbosityOptions ) where -import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), Executable(..) - , Library(..), libModules, hcOptions, hcProfOptions, hcSharedOptions - , usedExtensions, allExtensions ) +import Distribution.PackageDescription as PD hiding (Flag) import Distribution.InstalledPackageInfo - ( InstalledPackageInfo - , parseInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo_(..) ) import Distribution.Simple.PackageIndex import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.ParseUtils ( ParseResult(..) ) import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..), - LibraryName(..) ) -import Distribution.Simple.InstallDirs import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package - ( Package(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program - ( Program(..), ConfiguredProgram(..), ProgramConfiguration - , ProgramSearchPath, ProgramLocation(..) - , rawSystemProgram, rawSystemProgramConf - , rawSystemProgramStdout, rawSystemProgramStdoutConf - , requireProgramVersion - , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram - , arProgram, ldProgram - , gccProgram, stripProgram - , lhcProgram, lhcPkgProgram ) import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion - , OptimisationLevel(..), PackageDB(..), PackageDBStack, AbiTag(..) - , Flag, languageToFlags, extensionsToFlags ) import Distribution.Version - ( Version(..), orLaterVersion ) -import Distribution.System - ( OS(..), buildOS ) import Distribution.Verbosity import Distribution.Text - ( display, simpleParse ) +import Distribution.Compat.Exception +import Distribution.System import Language.Haskell.Extension - ( Language(Haskell98), Extension(..), KnownExtension(..) ) import Control.Monad ( unless, when ) +import Data.Monoid as Mon import Data.List import qualified Data.Map as M ( empty ) import Data.Maybe ( catMaybes ) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid ( Monoid(..) ) -#endif import System.Directory ( removeFile, renameFile, getDirectoryContents, doesFileExist, getTemporaryDirectory ) import System.FilePath ( (), (<.>), takeExtension, takeDirectory, replaceExtension ) import System.IO (hClose, hPutStrLn) -import Distribution.Compat.Exception (catchExit, catchIO) -import Distribution.System ( Platform ) -- ----------------------------------------------------------------------------- -- Configuring @@ -162,10 +131,11 @@ -- on Windows finding and configuring ghc's gcc and ld is a bit special findProg :: Program -> FilePath - -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) + -> Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) findProg prog location | isWindows = \verbosity searchpath -> do exists <- doesFileExist location - if exists then return (Just 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 searchpath | otherwise = programFindLocation prog @@ -231,7 +201,7 @@ pkgss <- getInstalledPackages' lhcPkg verbosity packagedbs conf let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) | (_, pkgs) <- pkgss ] - return $! (mconcat indexes) + return $! (Mon.mconcat indexes) where -- On Windows, various fields have $topdir/foo rather than full @@ -319,12 +289,8 @@ buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () buildLib verbosity pkg_descr lbi lib clbi = do - libName <- case componentLibraries clbi of - [libName] -> return libName - [] -> die "No library name found when building library" - _ -> die "Multiple library names found when building library" - - let pref = buildDir lbi + let libName = componentUnitId clbi + pref = buildDir lbi pkgid = packageId pkg_descr runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) @@ -687,8 +653,8 @@ _ -> ["-optc-O2"]) ++ ["-odir", odir] -mkGHCiLibName :: LibraryName -> String -mkGHCiLibName (LibraryName lib) = lib <.> "o" +mkGHCiLibName :: UnitId -> String +mkGHCiLibName lib = getHSLibraryName lib <.> "o" -- ----------------------------------------------------------------------------- -- Installing @@ -755,18 +721,18 @@ flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase srcFile] -- copy the built library files over: - ifVanilla $ mapM_ (copy builtDir targetDir) vanillaLibNames - ifProf $ mapM_ (copy builtDir targetDir) profileLibNames - ifGHCi $ mapM_ (copy builtDir targetDir) ghciLibNames - ifShared $ mapM_ (copy builtDir dynlibTargetDir) sharedLibNames + ifVanilla $ copy builtDir targetDir vanillaLibName + ifProf $ copy builtDir targetDir profileLibName + ifGHCi $ copy builtDir targetDir ghciLibName + ifShared $ copy builtDir dynlibTargetDir sharedLibName where cid = compilerId (compiler lbi) - libNames = componentLibraries clbi - vanillaLibNames = map mkLibName libNames - profileLibNames = map mkProfLibName libNames - ghciLibNames = map mkGHCiLibName libNames - sharedLibNames = map (mkSharedLibName cid) libNames + libName = componentUnitId clbi + vanillaLibName = mkLibName libName + profileLibName = mkProfLibName libName + ghciLibName = mkGHCiLibName libName + sharedLibName = mkSharedLibName cid libName hasLib = not $ null (libModules lib) && null (cSources (libBuildInfo lib)) @@ -782,14 +748,12 @@ registerPackage :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo - -> Bool + -> ProgramConfiguration -> PackageDBStack + -> InstalledPackageInfo -> IO () -registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = - HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity packageDbs +registerPackage verbosity progdb packageDbs installedPkgInfo = + HcPkg.reregister (hcPkgInfo progdb) verbosity packageDbs (Right installedPkgInfo) hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo @@ -797,7 +761,10 @@ , HcPkg.noPkgDbStack = False , HcPkg.noVerboseFlag = False , HcPkg.flagPackageConf = False - , HcPkg.useSingleFileDb = True + , HcPkg.supportsDirDbs = True + , HcPkg.requiresDirDbs = True + , HcPkg.nativeMultiInstance = False -- ? + , HcPkg.recacheMultiInstance = False -- ? } where Just lhcPkgProg = lookupProgram lhcPkgProgram conf diff --git a/Distribution/Simple/LocalBuildInfo.hs b/Distribution/Simple/LocalBuildInfo.hs --- a/Distribution/Simple/LocalBuildInfo.hs +++ b/Distribution/Simple/LocalBuildInfo.hs @@ -20,14 +20,15 @@ module Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), externalPackageDeps, - inplacePackageId, + localComponentId, + localUnitId, + localCompatPackageKey, -- * Buildable package components Component(..), ComponentName(..), showComponentName, ComponentLocalBuildInfo(..), - LibraryName(..), foldComponent, componentName, componentBuildInfo, @@ -62,30 +63,16 @@ prefixRelativeInstallDirs, substPathTemplate, ) import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Simple.Program (ProgramConfiguration) -import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Simple.Program import Distribution.PackageDescription - ( PackageDescription(..), withLib, Library(libBuildInfo), withExe - , Executable(exeName, buildInfo), withTest, TestSuite(..) - , BuildInfo(buildable), Benchmark(..), ModuleRenaming(..) ) import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package - ( PackageId, Package(..), InstalledPackageId(..), PackageKey - , PackageName ) import Distribution.Simple.Compiler - ( Compiler, compilerInfo, PackageDBStack, DebugInfoLevel - , OptimisationLevel ) import Distribution.Simple.PackageIndex - ( InstalledPackageIndex, allPackages ) -import Distribution.ModuleName ( ModuleName ) import Distribution.Simple.Setup - ( ConfigFlags ) import Distribution.Simple.Utils - ( shortRelativePath ) import Distribution.Text - ( display ) import Distribution.System - ( Platform (..) ) import Data.Array ((!)) import Distribution.Compat.Binary (Binary) @@ -104,6 +91,8 @@ configFlags :: ConfigFlags, -- ^ Options passed to the configuration step. -- Needed to re-run configuration when .cabal is out of date + flagAssignment :: FlagAssignment, + -- ^ The final set of flags which were picked for this package extraConfigArgs :: [String], -- ^ Extra args on the command line for the configuration step. -- Needed to re-run configuration when .cabal is out of date @@ -128,10 +117,6 @@ localPkgDescr :: PackageDescription, -- ^ The resolved package description, that does not contain -- any conditionals. - pkgKey :: PackageKey, - -- ^ The package key for the current build, calculated from - -- the package ID and the dependency graph. - instantiatedWith :: [(ModuleName, (InstalledPackageInfo, ModuleName))], withPrograms :: ProgramConfiguration, -- ^Location and args for all programs withPackageDB :: PackageDBStack, -- ^What package database to use, global\/user withVanillaLib:: Bool, -- ^Whether to build normal libs. @@ -139,6 +124,8 @@ withSharedLib :: Bool, -- ^Whether to build shared versions of libs. withDynExe :: Bool, -- ^Whether to link executables dynamically withProfExe :: Bool, -- ^Whether to build executables for profiling. + withProfLibDetail :: ProfDetailLevel, -- ^Level of automatic profile detail. + withProfExeDetail :: ProfDetailLevel, -- ^Level of automatic profile detail. withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). withDebugInfo :: DebugInfoLevel, -- ^Whether to emit debug info (if available). withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. @@ -152,9 +139,37 @@ instance Binary LocalBuildInfo +-- | Extract the 'ComponentId' from the library component of a +-- 'LocalBuildInfo' if it exists, or make a fake component ID based +-- on the package ID. +localComponentId :: LocalBuildInfo -> ComponentId +localComponentId lbi + = case localUnitId lbi of + SimpleUnitId cid -> cid + +-- | Extract the 'UnitId' from the library component of a +-- 'LocalBuildInfo' if it exists, or make a fake unit ID based on +-- the package ID. +localUnitId :: LocalBuildInfo -> UnitId +localUnitId lbi = + foldr go (mkLegacyUnitId (package (localPkgDescr lbi))) (componentsConfigs lbi) + where go (_, clbi, _) old_uid = case clbi of + LibComponentLocalBuildInfo { componentUnitId = uid } -> uid + _ -> old_uid + +-- | Extract the compatibility 'ComponentId' from the library component of a +-- 'LocalBuildInfo' if it exists, or make a fake compatibility package +-- key based on the package ID. +localCompatPackageKey :: LocalBuildInfo -> String +localCompatPackageKey lbi = + foldr go (display (package (localPkgDescr lbi))) (componentsConfigs lbi) + where go (_, clbi, _) old_pk = case clbi of + LibComponentLocalBuildInfo { componentCompatPackageKey = pk } -> pk + _ -> old_pk + -- | 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 :: LocalBuildInfo -> [(UnitId, PackageId)] externalPackageDeps lbi = -- TODO: what about non-buildable components? nub [ (ipkgid, pkgid) @@ -166,12 +181,6 @@ -- defined in the same package). internal pkgid = pkgid == packageId (localPkgDescr lbi) --- | The installed package Id we use for local packages registered in the local --- package db. This is what is used for intra-package deps between components. --- -inplacePackageId :: PackageId -> InstalledPackageId -inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace") - -- ----------------------------------------------------------------------------- -- Buildable components @@ -201,21 +210,22 @@ -- 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)], + componentPackageDeps :: [(UnitId, PackageId)], + componentUnitId :: UnitId, + componentCompatPackageKey :: String, componentExposedModules :: [Installed.ExposedModule], - componentPackageRenaming :: Map PackageName ModuleRenaming, - componentLibraries :: [LibraryName] + componentPackageRenaming :: Map PackageName ModuleRenaming } | ExeComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)], + componentPackageDeps :: [(UnitId, PackageId)], componentPackageRenaming :: Map PackageName ModuleRenaming } | TestComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)], + componentPackageDeps :: [(UnitId, PackageId)], componentPackageRenaming :: Map PackageName ModuleRenaming } | BenchComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)], + componentPackageDeps :: [(UnitId, PackageId)], componentPackageRenaming :: Map PackageName ModuleRenaming } deriving (Generic, Read, Show) @@ -233,11 +243,6 @@ foldComponent _ _ f _ (CTest tst) = f tst foldComponent _ _ _ f (CBench bch) = f bch -data LibraryName = LibraryName String - deriving (Generic, Read, Show) - -instance Binary LibraryName - componentBuildInfo :: Component -> BuildInfo componentBuildInfo = foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo @@ -306,7 +311,8 @@ ++ "component corresponding to " ++ show cname -getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo +getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName + -> ComponentLocalBuildInfo getComponentLocalBuildInfo lbi cname = case [ clbi | (cname', clbi, _) <- componentsConfigs lbi @@ -361,9 +367,9 @@ | (cname, clbi) <- allComponentsInBuildOrder lbi ] withComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo - -> [ComponentName] - -> (Component -> ComponentLocalBuildInfo -> IO ()) - -> IO () + -> [ComponentName] + -> (Component -> ComponentLocalBuildInfo -> IO ()) + -> IO () withComponentsInBuildOrder pkg lbi cnames f = sequence_ [ f (getComponent pkg cname') clbi @@ -476,7 +482,7 @@ absoluteInstallDirs pkg lbi copydest = InstallDirs.absoluteInstallDirs (packageId pkg) - (pkgKey lbi) + (localUnitId lbi) (compilerInfo (compiler lbi)) copydest (hostPlatform lbi) @@ -488,7 +494,7 @@ prefixRelativeInstallDirs pkg_descr lbi = InstallDirs.prefixRelativeInstallDirs (packageId pkg_descr) - (pkgKey lbi) + (localUnitId lbi) (compilerInfo (compiler lbi)) (hostPlatform lbi) (installDirTemplates lbi) @@ -499,6 +505,6 @@ . ( InstallDirs.substPathTemplate env ) where env = initialPathTemplateEnv pkgid - (pkgKey lbi) + (localUnitId lbi) (compilerInfo (compiler lbi)) (hostPlatform lbi) diff --git a/Distribution/Simple/PackageIndex.hs b/Distribution/Simple/PackageIndex.hs --- a/Distribution/Simple/PackageIndex.hs +++ b/Distribution/Simple/PackageIndex.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- @@ -17,7 +16,6 @@ -- * Package index data type InstalledPackageIndex, PackageIndex, - FakeMap, -- * Creating an index fromList, @@ -27,7 +25,7 @@ insert, - deleteInstalledPackageId, + deleteUnitId, deleteSourcePackageId, deletePackageName, -- deleteDependency, @@ -35,7 +33,7 @@ -- * Queries -- ** Precise lookups - lookupInstalledPackageId, + lookupUnitId, lookupSourcePackageId, lookupPackageId, lookupPackageName, @@ -62,27 +60,26 @@ dependencyGraph, moduleNameIndex, - -- ** Variants of special queries supporting fake map - fakeLookupInstalledPackageId, - brokenPackages', - dependencyClosure', - reverseDependencyClosure', - dependencyInconsistencies', - dependencyCycles', - dependencyGraph', + -- * Backwards compatibility + deleteInstalledPackageId, + lookupInstalledPackageId, ) where +import Distribution.Compat.Binary +import Distribution.Compat.Semigroup as Semi +import Distribution.Package +import Distribution.ModuleName +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Version +import Distribution.Simple.Utils + import Control.Exception (assert) import Data.Array ((!)) import qualified Data.Array as Array -import Distribution.Compat.Binary (Binary) import qualified Data.Graph as Graph import Data.List as List ( null, foldl', sort - , groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy ) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (Monoid(..)) -#endif + , groupBy, sortBy, find, nubBy, deleteBy, deleteFirstsBy ) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (isNothing, fromMaybe) @@ -90,65 +87,17 @@ import GHC.Generics (Generic) import Prelude hiding (lookup) -import Distribution.Package - ( PackageName(..), PackageId - , Package(..), packageName, packageVersion - , Dependency(Dependency)--, --PackageFixedDeps(..) - , InstalledPackageId(..), PackageInstalled(..) ) -import Distribution.ModuleName - ( ModuleName ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Version - ( Version, withinRange ) -import Distribution.Simple.Utils (lowercase, comparing, equating) - --- Note [FakeMap] ------------------ --- We'd like to use the PackageIndex defined in this module for --- cabal-install's InstallPlan. However, at the moment, this --- data structure is indexed by InstalledPackageId, which we don't --- know until after we've compiled a package (whereas InstallPlan --- needs to store not-compiled packages in the index.) Eventually, --- an InstalledPackageId will be calculatable prior to actually --- building the package (making it something of a misnomer), but --- at the moment, the "fake installed package ID map" is a workaround --- to solve this problem while reusing PackageIndex. The basic idea --- is that, since we don't know what an InstalledPackageId is --- beforehand, we just fake up one based on the package ID (it only --- needs to be unique for the particular install plan), and fill --- it out with the actual generated InstalledPackageId after the --- package is successfully compiled. --- --- However, there is a problem: in the index there may be --- references using the old package ID, which are now dangling if --- we update the InstalledPackageId. We could map over the entire --- index to update these pointers as well (a costly operation), but --- instead, we've chosen to parametrize a variety of important functions --- by a FakeMap, which records what a fake installed package ID was --- actually resolved to post-compilation. If we do a lookup, we first --- check and see if it's a fake ID in the FakeMap. --- --- It's a bit grungy, but we expect this to only be temporary anyway. --- (Another possible workaround would have been to *not* update --- the installed package ID, but I decided this would be hard to --- understand.) - --- | Map from fake installed package IDs to real ones. See Note [FakeMap] -type FakeMap = Map InstalledPackageId InstalledPackageId - -- | The collection of information about packages from one or more 'PackageDB's. -- These packages generally should have an instance of 'PackageInstalled' -- --- Packages are uniquely identified in by their 'InstalledPackageId', they can +-- Packages are uniquely identified in by their 'UnitId', they can -- also be efficiently looked up by package name or by name and version. -- data PackageIndex a = PackageIndex -- The primary index. Each InstalledPackageInfo record is uniquely identified - -- by its InstalledPackageId. + -- by its UnitId. -- - !(Map InstalledPackageId a) + !(Map UnitId a) -- This auxiliary index maps package names (case-sensitively) to all the -- versions and instances of that package. This allows us to find all @@ -156,39 +105,42 @@ -- -- It is a three-level index. The first level is the package name, -- the second is the package version and the final level is instances - -- of the same package version. These are unique by InstalledPackageId + -- of the same package version. These are unique by UnitId -- and are kept in preference order. -- -- FIXME: Clarify what "preference order" means. Check that this invariant is -- preserved. See #1463 for discussion. !(Map PackageName (Map Version [a])) - deriving (Generic, Show, Read) + deriving (Eq, Generic, Show, Read) instance Binary a => Binary (PackageIndex a) -- | The default package index which contains 'InstalledPackageInfo'. Normally -- use this. -type InstalledPackageIndex = PackageIndex InstalledPackageInfo +type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo -instance PackageInstalled a => Monoid (PackageIndex a) where +instance HasUnitId a => Monoid (PackageIndex a) where mempty = PackageIndex Map.empty Map.empty - mappend = merge + mappend = (Semi.<>) --save one mappend with empty in the common case: mconcat [] = mempty mconcat xs = foldr1 mappend xs -invariant :: PackageInstalled a => PackageIndex a -> Bool +instance HasUnitId a => Semigroup (PackageIndex a) where + (<>) = merge + +invariant :: HasUnitId a => PackageIndex a -> Bool invariant (PackageIndex pids pnames) = - map installedPackageId (Map.elems pids) + map installedUnitId (Map.elems pids) == sort - [ assert pinstOk (installedPackageId pinst) + [ assert pinstOk (installedUnitId pinst) | (pname, pvers) <- Map.toList pnames , let pversOk = not (Map.null pvers) , (pver, pinsts) <- assert pversOk $ Map.toList pvers - , let pinsts' = sortBy (comparing installedPackageId) pinsts + , let pinsts' = sortBy (comparing installedUnitId) pinsts pinstsOk = all (\g -> length g == 1) - (groupBy (equating installedPackageId) pinsts') + (groupBy (equating installedUnitId) pinsts') , pinst <- assert pinstsOk $ pinsts' , let pinstOk = packageName pinst == pname && packageVersion pinst == pver @@ -199,8 +151,8 @@ -- * Internal helpers -- -mkPackageIndex :: PackageInstalled a - => Map InstalledPackageId a +mkPackageIndex :: HasUnitId a + => Map UnitId a -> Map PackageName (Map Version [a]) -> PackageIndex a mkPackageIndex pids pnames = assert (invariant index) index @@ -213,13 +165,13 @@ -- | Build an index out of a bunch of packages. -- --- If there are duplicates by 'InstalledPackageId' then later ones mask earlier +-- If there are duplicates by 'UnitId' then later ones mask earlier -- ones. -- -fromList :: PackageInstalled a => [a] -> PackageIndex a +fromList :: HasUnitId a => [a] -> PackageIndex a fromList pkgs = mkPackageIndex pids pnames where - pids = Map.fromList [ (installedPackageId pkg, pkg) | pkg <- pkgs ] + pids = Map.fromList [ (installedUnitId pkg, pkg) | pkg <- pkgs ] pnames = Map.fromList [ (packageName (head pkgsN), pvers) @@ -229,7 +181,7 @@ , let pvers = Map.fromList [ (packageVersion (head pkgsNV), - nubBy (equating installedPackageId) (reverse pkgsNV)) + nubBy (equating installedUnitId) (reverse pkgsNV)) | pkgsNV <- groupBy (equating packageVersion) pkgsN ] ] @@ -241,14 +193,15 @@ -- | Merge two indexes. -- -- Packages from the second mask packages from the first if they have the exact --- same 'InstalledPackageId'. +-- same 'UnitId'. -- -- For packages with the same source 'PackageId', packages from the second are -- \"preferred\" over those from the first. Being preferred means they are top -- result when we do a lookup by source 'PackageId'. This is the mechanism we -- use to prefer user packages over global packages. -- -merge :: PackageInstalled a => PackageIndex a -> PackageIndex a -> PackageIndex a +merge :: HasUnitId a => PackageIndex a -> PackageIndex a + -> PackageIndex a merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = mkPackageIndex (Map.unionWith (\_ y -> y) pids1 pids2) (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) @@ -256,7 +209,7 @@ -- Packages in the second list mask those in the first, however preferred -- packages go first in the list. mergeBuckets xs ys = ys ++ (xs \\ ys) - (\\) = deleteFirstsBy (equating installedPackageId) + (\\) = deleteFirstsBy (equating installedUnitId) -- | Inserts a single package into the index. @@ -264,12 +217,12 @@ -- This is equivalent to (but slightly quicker than) using 'mappend' or -- 'merge' with a singleton index. -- -insert :: PackageInstalled a => a -> PackageIndex a -> PackageIndex a +insert :: HasUnitId a => a -> PackageIndex a -> PackageIndex a insert pkg (PackageIndex pids pnames) = mkPackageIndex pids' pnames' where - pids' = Map.insert (installedPackageId pkg) pkg pids + pids' = Map.insert (installedUnitId pkg) pkg pids pnames' = insertPackageName pnames insertPackageName = Map.insertWith' (\_ -> insertPackageVersion) @@ -281,13 +234,15 @@ (packageVersion pkg) [pkg] insertPackageInstance pkgs = - pkg : deleteBy (equating installedPackageId) pkg pkgs + pkg : deleteBy (equating installedUnitId) pkg pkgs -- | Removes a single installed package from the index. -- -deleteInstalledPackageId :: PackageInstalled a => InstalledPackageId -> PackageIndex a -> PackageIndex a -deleteInstalledPackageId ipkgid original@(PackageIndex pids pnames) = +deleteUnitId :: HasUnitId a + => UnitId -> PackageIndex a + -> PackageIndex a +deleteUnitId ipkgid original@(PackageIndex pids pnames) = case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of (Nothing, _) -> original (Just spkgid, pids') -> mkPackageIndex pids' @@ -303,19 +258,26 @@ deletePkgInstance = (\xs -> if List.null xs then Nothing else Just xs) - . List.deleteBy (\_ pkg -> installedPackageId pkg == ipkgid) undefined + . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined +-- | Backwards compatibility wrapper for Cabal pre-1.24. +{-# DEPRECATED deleteInstalledPackageId "Use deleteUnitId instead" #-} +deleteInstalledPackageId :: HasUnitId a + => UnitId -> PackageIndex a + -> PackageIndex a +deleteInstalledPackageId = deleteUnitId -- | Removes all packages with this source 'PackageId' from the index. -- -deleteSourcePackageId :: PackageInstalled a => PackageId -> PackageIndex a -> PackageIndex a +deleteSourcePackageId :: HasUnitId a => PackageId -> PackageIndex a + -> PackageIndex a deleteSourcePackageId pkgid original@(PackageIndex pids pnames) = case Map.lookup (packageName pkgid) pnames of Nothing -> original Just pvers -> case Map.lookup (packageVersion pkgid) pvers of Nothing -> original Just pkgs -> mkPackageIndex - (foldl' (flip (Map.delete . installedPackageId)) pids pkgs) + (foldl' (flip (Map.delete . installedUnitId)) pids pkgs) (deletePkgName pnames) where deletePkgName = @@ -328,12 +290,13 @@ -- | Removes all packages with this (case-sensitive) name from the index. -- -deletePackageName :: PackageInstalled a => PackageName -> PackageIndex a -> PackageIndex a +deletePackageName :: HasUnitId a => PackageName -> PackageIndex a + -> PackageIndex a deletePackageName name original@(PackageIndex pids pnames) = case Map.lookup name pnames of Nothing -> original Just pvers -> mkPackageIndex - (foldl' (flip (Map.delete . installedPackageId)) pids + (foldl' (flip (Map.delete . installedUnitId)) pids (concat (Map.elems pvers))) (Map.delete name pnames) @@ -367,7 +330,8 @@ -- -- They are grouped by source package id (package name and version). -- -allPackagesBySourcePackageId :: PackageInstalled a => PackageIndex a -> [(PackageId, [a])] +allPackagesBySourcePackageId :: HasUnitId a => PackageIndex a + -> [(PackageId, [a])] allPackagesBySourcePackageId (PackageIndex _ pnames) = [ (packageId ipkg, ipkgs) | pvers <- Map.elems pnames @@ -379,21 +343,27 @@ -- | Does a lookup by source package id (name & version). -- --- Since multiple package DBs mask each other by 'InstalledPackageId', +-- Since multiple package DBs mask each other by 'UnitId', -- then we get back at most one package. -- -lookupInstalledPackageId :: PackageInstalled a => PackageIndex a -> InstalledPackageId +lookupUnitId :: PackageIndex a -> UnitId + -> Maybe a +lookupUnitId (PackageIndex pids _) pid = Map.lookup pid pids + +-- | Backwards compatibility for Cabal pre-1.24. +{-# DEPRECATED lookupInstalledPackageId "Use lookupUnitId instead" #-} +lookupInstalledPackageId :: PackageIndex a -> UnitId -> Maybe a -lookupInstalledPackageId (PackageIndex pids _) pid = Map.lookup pid pids +lookupInstalledPackageId = lookupUnitId -- | Does a lookup by source package id (name & version). -- -- There can be multiple installed packages with the same source 'PackageId' --- but different 'InstalledPackageId'. They are returned in order of +-- but different 'UnitId'. They are returned in order of -- preference, with the most preferred first. -- -lookupSourcePackageId :: PackageInstalled a => PackageIndex a -> PackageId -> [a] +lookupSourcePackageId :: PackageIndex a -> PackageId -> [a] lookupSourcePackageId (PackageIndex _ pnames) pkgid = case Map.lookup (packageName pkgid) pnames of Nothing -> [] @@ -403,7 +373,7 @@ -- | Convenient alias of 'lookupSourcePackageId', but assuming only -- one package per package ID. -lookupPackageId :: PackageInstalled a => PackageIndex a -> PackageId -> Maybe a +lookupPackageId :: PackageIndex a -> PackageId -> Maybe a lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of [] -> Nothing [pkg] -> Just pkg @@ -411,7 +381,7 @@ -- | Does a lookup by source package name. -- -lookupPackageName :: PackageInstalled a => PackageIndex a -> PackageName +lookupPackageName :: PackageIndex a -> PackageName -> [(Version, [a])] lookupPackageName (PackageIndex _ pnames) name = case Map.lookup name pnames of @@ -424,7 +394,7 @@ -- We get back any number of versions of the specified package name, all -- satisfying the version range constraint. -- -lookupDependency :: PackageInstalled a => PackageIndex a -> Dependency +lookupDependency :: PackageIndex a -> Dependency -> [(Version, [a])] lookupDependency (PackageIndex _ pnames) (Dependency name versionRange) = case Map.lookup name pnames of @@ -449,7 +419,7 @@ -- packages. The list of ambiguous results is split by exact package name. So -- it is a non-empty list of non-empty lists. -- -searchByName :: PackageInstalled a => PackageIndex a -> String -> SearchResult [a] +searchByName :: PackageIndex a -> String -> SearchResult [a] searchByName (PackageIndex _ pnames) name = case [ pkgs | pkgs@(PackageName name',_) <- Map.toList pnames , lowercase name' == lname ] of @@ -466,7 +436,7 @@ -- -- That is, all packages that contain the given string in their name. -- -searchByNameSubstring :: PackageInstalled a => PackageIndex a -> String -> [a] +searchByNameSubstring :: PackageIndex a -> String -> [a] searchByNameSubstring (PackageIndex _ pnames) searchterm = [ pkg | (PackageName name, pvers) <- Map.toList pnames @@ -491,14 +461,10 @@ -- other, directly or indirectly. -- dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]] -dependencyCycles = dependencyCycles' Map.empty - --- | Variant of 'dependencyCycles' which accepts a 'FakeMap'. See Note [FakeMap]. -dependencyCycles' :: PackageInstalled a => FakeMap -> PackageIndex a -> [[a]] -dependencyCycles' fakeMap index = +dependencyCycles index = [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] where - adjacencyList = [ (pkg, installedPackageId pkg, fakeInstalledDepends fakeMap pkg) + adjacencyList = [ (pkg, installedUnitId pkg, installedDepends pkg) | pkg <- allPackages index ] @@ -506,22 +472,15 @@ -- -- Returns such packages along with the dependencies that they're missing. -- -brokenPackages :: PackageInstalled a => PackageIndex a -> [(a, [InstalledPackageId])] -brokenPackages = brokenPackages' Map.empty - --- | Variant of 'brokenPackages' which accepts a 'FakeMap'. See Note [FakeMap]. -brokenPackages' :: PackageInstalled a => FakeMap -> PackageIndex a -> [(a, [InstalledPackageId])] -brokenPackages' fakeMap index = +brokenPackages :: PackageInstalled a => PackageIndex a + -> [(a, [UnitId])] +brokenPackages index = [ (pkg, missing) | pkg <- allPackages index , let missing = [ pkg' | pkg' <- installedDepends pkg - , isNothing (fakeLookupInstalledPackageId fakeMap index pkg') ] + , isNothing (lookupUnitId index pkg') ] , not (null missing) ] --- | Variant of 'lookupInstalledPackageId' which accepts a 'FakeMap'. See Note [FakeMap]. -fakeLookupInstalledPackageId :: PackageInstalled a => FakeMap -> PackageIndex a -> InstalledPackageId -> Maybe a -fakeLookupInstalledPackageId fakeMap index pkg = lookupInstalledPackageId index (Map.findWithDefault pkg pkg fakeMap) - -- | Tries to take the transitive closure of the package dependencies. -- -- If the transitive closure is complete then it returns that subset of the @@ -531,25 +490,17 @@ -- the original given 'PackageId's do not occur in the index. -- dependencyClosure :: PackageInstalled a => PackageIndex a - -> [InstalledPackageId] - -> Either (PackageIndex a) - [(a, [InstalledPackageId])] -dependencyClosure = dependencyClosure' Map.empty - --- | Variant of 'dependencyClosure' which accepts a 'FakeMap'. See Note [FakeMap]. -dependencyClosure' :: PackageInstalled a => FakeMap - -> PackageIndex a - -> [InstalledPackageId] + -> [UnitId] -> Either (PackageIndex a) - [(a, [InstalledPackageId])] -dependencyClosure' fakeMap index pkgids0 = case closure mempty [] pkgids0 of + [(a, [UnitId])] +dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of (completed, []) -> Left completed (completed, _) -> Right (brokenPackages completed) where closure completed failed [] = (completed, failed) - closure completed failed (pkgid:pkgids) = case fakeLookupInstalledPackageId fakeMap index pkgid of + closure completed failed (pkgid:pkgids) = case lookupUnitId index pkgid of Nothing -> closure completed (pkgid:failed) pkgids - Just pkg -> case fakeLookupInstalledPackageId fakeMap completed (installedPackageId pkg) of + Just pkg -> case lookupUnitId completed (installedUnitId pkg) of Just _ -> closure completed failed pkgids Nothing -> closure completed' failed pkgids' where completed' = insert pkg completed @@ -560,23 +511,16 @@ -- * The given 'PackageId's must be in the index. -- reverseDependencyClosure :: PackageInstalled a => PackageIndex a - -> [InstalledPackageId] - -> [a] -reverseDependencyClosure = reverseDependencyClosure' Map.empty - --- | Variant of 'reverseDependencyClosure' which accepts a 'FakeMap'. See Note [FakeMap]. -reverseDependencyClosure' :: PackageInstalled a => FakeMap - -> PackageIndex a - -> [InstalledPackageId] + -> [UnitId] -> [a] -reverseDependencyClosure' fakeMap index = +reverseDependencyClosure index = map vertexToPkg . concatMap Tree.flatten . Graph.dfs reverseDepGraph . map (fromMaybe noSuchPkgId . pkgIdToVertex) where - (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph' fakeMap index + (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index reverseDepGraph = Graph.transposeG depGraph noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" @@ -601,25 +545,17 @@ dependencyGraph :: PackageInstalled a => PackageIndex a -> (Graph.Graph, Graph.Vertex -> a, - InstalledPackageId -> Maybe Graph.Vertex) -dependencyGraph = dependencyGraph' Map.empty - --- | Variant of 'dependencyGraph' which accepts a 'FakeMap'. See Note [FakeMap]. -dependencyGraph' :: PackageInstalled a => FakeMap - -> PackageIndex a - -> (Graph.Graph, - Graph.Vertex -> a, - InstalledPackageId -> Maybe Graph.Vertex) -dependencyGraph' fakeMap index = (graph, vertex_to_pkg, id_to_vertex) + UnitId -> Maybe Graph.Vertex) +dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex) where graph = Array.listArray bounds [ [ v | Just v <- map id_to_vertex (installedDepends pkg) ] | pkg <- pkgs ] pkgs = sortBy (comparing packageId) (allPackages index) - vertices = zip (map installedPackageId pkgs) [0..] + vertices = zip (map installedUnitId pkgs) [0..] vertex_map = Map.fromList vertices - id_to_vertex pid = Map.lookup (Map.findWithDefault pid pid fakeMap) vertex_map + id_to_vertex pid = Map.lookup pid vertex_map vertex_to_pkg vertex = pkgTable ! vertex @@ -639,12 +575,7 @@ -- dependencyInconsistencies :: PackageInstalled a => PackageIndex a -> [(PackageName, [(PackageId, Version)])] -dependencyInconsistencies = dependencyInconsistencies' Map.empty - --- | Variant of 'dependencyInconsistencies' which accepts a 'FakeMap'. See Note [FakeMap]. -dependencyInconsistencies' :: PackageInstalled a => FakeMap -> PackageIndex a - -> [(PackageName, [(PackageId, Version)])] -dependencyInconsistencies' fakeMap index = +dependencyInconsistencies index = [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids]) | (name, ipid_map) <- Map.toList inverseIndex , let uses = Map.elems ipid_map @@ -658,32 +589,29 @@ [ (packageName dep, Map.fromList [(ipid,(dep,[packageId pkg]))]) | pkg <- allPackages index - , ipid <- fakeInstalledDepends fakeMap pkg - , Just dep <- [fakeLookupInstalledPackageId fakeMap index ipid] + , ipid <- installedDepends pkg + , Just dep <- [lookupUnitId index ipid] ] reallyIsInconsistent :: PackageInstalled a => [a] -> Bool reallyIsInconsistent [] = False reallyIsInconsistent [_p] = False reallyIsInconsistent [p1, p2] = - let pid1 = installedPackageId p1 - pid2 = installedPackageId p2 - in Map.findWithDefault pid1 pid1 fakeMap `notElem` fakeInstalledDepends fakeMap p2 - && Map.findWithDefault pid2 pid2 fakeMap `notElem` fakeInstalledDepends fakeMap p1 + let pid1 = installedUnitId p1 + pid2 = installedUnitId p2 + in pid1 `notElem` installedDepends p2 + && pid2 `notElem` installedDepends p1 reallyIsInconsistent _ = True --- | Variant of 'installedDepends' which accepts a 'FakeMap'. See Note [FakeMap]. -fakeInstalledDepends :: PackageInstalled a => FakeMap -> a -> [InstalledPackageId] -fakeInstalledDepends fakeMap = map (\pid -> Map.findWithDefault pid pid fakeMap) . installedDepends - --- | A rough approximation of GHC's module finder, takes a 'InstalledPackageIndex' and --- turns it into a map from module names to their source packages. It's used to --- initialize the @build-deps@ field in @cabal init@. -moduleNameIndex :: InstalledPackageIndex -> Map ModuleName [InstalledPackageInfo] +-- | A rough approximation of GHC's module finder, takes a +-- 'InstalledPackageIndex' and turns it into a map from module names to their +-- source packages. It's used to initialize the @build-deps@ field in @cabal +-- init@. +moduleNameIndex :: InstalledPackageIndex -> Map ModuleName [IPI.InstalledPackageInfo] moduleNameIndex index = Map.fromListWith (++) $ do pkg <- allPackages index - IPI.ExposedModule m reexport _ <- IPI.exposedModules pkg + IPI.ExposedModule m reexport <- IPI.exposedModules pkg case reexport of Nothing -> return (m, [pkg]) Just (IPI.OriginalModule _ m') | m == m' -> [] diff --git a/Distribution/Simple/PreProcess.hs b/Distribution/Simple/PreProcess.hs --- a/Distribution/Simple/PreProcess.hs +++ b/Distribution/Simple/PreProcess.hs @@ -17,8 +17,9 @@ -- handlers. This module is not as good as it could be, it could really do with -- a rewrite to address some of the problems we have with pre-processors. -module Distribution.Simple.PreProcess (preprocessComponent, knownSuffixHandlers, - ppSuffixes, PPSuffixHandler, PreProcessor(..), +module Distribution.Simple.PreProcess (preprocessComponent, preprocessExtras, + knownSuffixHandlers, ppSuffixes, + PPSuffixHandler, PreProcessor(..), mkSimplePreProcessor, runSimplePreProcessor, ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, ppHappy, ppAlex, ppUnlit, platformDefines @@ -26,54 +27,32 @@ where -import Control.Monad -import Distribution.Simple.PreProcess.Unlit (unlit) +import Distribution.Simple.PreProcess.Unlit import Distribution.Package - ( Package(..), PackageName(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..) - , Executable(..) - , Library(..), libModules - , TestSuite(..), testModules - , TestSuiteInterface(..) - , Benchmark(..), benchmarkModules, BenchmarkInterface(..) ) import qualified Distribution.InstalledPackageInfo as Installed - ( InstalledPackageInfo_(..) ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.CCompiler - ( cSourceExtensions ) import Distribution.Simple.Compiler - ( CompilerFlavor(..) - , compilerFlavor, compilerCompatVersion, compilerVersion ) import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), Component(..) ) -import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName) +import Distribution.Simple.BuildPaths import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File - , die, setupMessage, intercalate, copyFileVerbose, moreRecentFile - , findFileWithExtension, findFileWithExtension' ) import Distribution.Simple.Program - ( Program(..), ConfiguredProgram(..), programPath - , requireProgram, requireProgramVersion - , rawSystemProgramConf, rawSystemProgram - , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram - , happyProgram, alexProgram, ghcProgram, ghcjsProgram, gccProgram ) import Distribution.Simple.Test.LibV09 - ( writeSimpleTestStub, stubFilePath, stubName ) import Distribution.System - ( OS(..), buildOS, Arch(..), Platform(..) ) import Distribution.Text import Distribution.Version - ( Version(..), anyVersion, orLaterVersion ) import Distribution.Verbosity +import Control.Monad import Data.Maybe (fromMaybe) -import Data.List (nub) +import Data.List (nub, isSuffixOf) import System.Directory (doesFileExist) import System.Info (os, arch) import System.FilePath (splitExtension, dropExtensions, (), (<.>), - takeDirectory, normalise, replaceExtension) + takeDirectory, normalise, replaceExtension, + takeExtensions) -- |The interface to a preprocessor, which may be implemented using an -- external program, but need not be. The arguments are the name of @@ -129,6 +108,13 @@ -> IO () -- Should exit if the preprocessor fails } +-- | Function to determine paths to possible extra C sources for a +-- preprocessor: just takes the path to the build directory and uses +-- this to search for C sources with names that match the +-- preprocessor's output name format. +type PreProcessorExtras = FilePath -> IO [FilePath] + + mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ()) -> (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO () @@ -251,7 +237,7 @@ Just (psrcLoc, psrcRelFile) -> do let (srcStem, ext) = splitExtension psrcRelFile psrcFile = psrcLoc psrcRelFile - pp = fromMaybe (error "Internal error in preProcess module: Just expected") + pp = fromMaybe (error "Distribution.Simple.PreProcess: Just expected") (lookup (tailNotNull ext) handlers) -- Preprocessing files for 'sdist' is different from preprocessing -- for 'build'. When preprocessing for sdist we preprocess to @@ -438,9 +424,15 @@ ++ ["-o", outFile, inFile] } where + -- TODO: installedPkgs contains ALL dependencies associated with + -- the package, but we really only want to look at packages for the + -- *current* dependency. We should use PackageIndex.dependencyClosure + -- on the direct depends of the component. Can't easily do that, + -- because the signature of this function is wrong. Tracked with + -- #2971 (which has a test case.) pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi)) isOSX = case buildOS of OSX -> True; _ -> False - isELF = case buildOS of OSX -> False; Windows -> False; _ -> True; + isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True; packageHacks = case compilerFlavor (compiler lbi) of GHC -> hackRtsPackage GHCJS -> hackRtsPackage @@ -455,6 +447,9 @@ -> PackageIndex.insert rts { Installed.ldOptions = [] } index _ -> error "No (or multiple) ghc rts package is registered!!" +ppHsc2hsExtras :: PreProcessorExtras +ppHsc2hsExtras buildBaseDir = filter ("_hsc.c" `isSuffixOf`) `fmap` + getDirectoryContentsRecursive buildBaseDir ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor ppC2hs bi lbi = @@ -471,6 +466,7 @@ -- Options from the current package: [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ] + ++ [ "--cppopts=-include" ++ (autogenModulesDir lbi cppHeaderName) ] ++ [ "--include=" ++ outBaseDir ] -- Options from dependent packages @@ -490,6 +486,10 @@ where pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) +ppC2hsExtras :: PreProcessorExtras +ppC2hsExtras d = filter (\p -> takeExtensions p == ".chs.c") `fmap` + getDirectoryContentsRecursive d + --TODO: perhaps use this with hsc2hs too --TODO: remove cc-options from cpphs for cabal-version: >= 1.10 getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] @@ -557,7 +557,9 @@ IRIX -> ["irix"] HaLVM -> [] IOS -> ["ios"] + Android -> ["android"] Ghcjs -> ["ghcjs"] + Hurd -> ["hurd"] OtherOS _ -> [] archStr = case hostArch of I386 -> ["i386"] @@ -618,3 +620,33 @@ , ("ly", ppHappy) , ("cpphs", ppCpp) ] + +-- |Standard preprocessors with possible extra C sources: c2hs, hsc2hs. +knownExtrasHandlers :: [ PreProcessorExtras ] +knownExtrasHandlers = [ ppC2hsExtras, ppHsc2hsExtras ] + +-- | Find any extra C sources generated by preprocessing that need to +-- be added to the component (addresses issue #238). +preprocessExtras :: Component + -> LocalBuildInfo + -> IO [FilePath] +preprocessExtras comp lbi = case comp of + CLib _ -> pp $ buildDir lbi + (CExe Executable { exeName = nm }) -> + pp $ buildDir lbi nm nm ++ "-tmp" + CTest test -> do + case testInterface test of + TestSuiteExeV10 _ _ -> + pp $ buildDir lbi testName test testName test ++ "-tmp" + TestSuiteLibV09 _ _ -> + pp $ buildDir lbi stubName test stubName test ++ "-tmp" + TestSuiteUnsupported tt -> die $ "No support for preprocessing test " + ++ "suite type " ++ display tt + CBench bm -> do + case benchmarkInterface bm of + BenchmarkExeV10 _ _ -> + pp $ buildDir lbi benchmarkName bm benchmarkName bm ++ "-tmp" + BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark " + ++ "type " ++ display tt + where + pp dir = (map (dir ) . concat) `fmap` forM knownExtrasHandlers ($ dir) diff --git a/Distribution/Simple/Program.hs b/Distribution/Simple/Program.hs --- a/Distribution/Simple/Program.hs +++ b/Distribution/Simple/Program.hs @@ -38,7 +38,8 @@ , ProgramSearchPath , ProgramSearchPathEntry(..) , simpleProgram - , findProgramLocation + , findProgramOnSearchPath + , defaultProgramSearchPath , findProgramVersion -- * Configured program and related functions @@ -122,6 +123,7 @@ , rawSystemProgramConf , rawSystemProgramStdoutConf , findProgramOnPath + , findProgramLocation ) where @@ -129,11 +131,9 @@ import Distribution.Simple.Program.Run import Distribution.Simple.Program.Db import Distribution.Simple.Program.Builtin - +import Distribution.Simple.Program.Find import Distribution.Simple.Utils - ( die, findProgramLocation, findProgramVersion ) import Distribution.Verbosity - ( Verbosity ) -- | Runs the given configured program. @@ -217,6 +217,8 @@ -> ProgramConfiguration restoreProgramConfiguration = restoreProgramDb -{-# DEPRECATED findProgramOnPath "use findProgramLocation instead" #-} +{-# DEPRECATED findProgramOnPath "use findProgramOnSearchPath instead" #-} findProgramOnPath :: String -> Verbosity -> IO (Maybe FilePath) -findProgramOnPath = flip findProgramLocation +findProgramOnPath name verbosity = + fmap (fmap fst) $ + findProgramOnSearchPath verbosity defaultProgramSearchPath name diff --git a/Distribution/Simple/Program/Ar.hs b/Distribution/Simple/Program/Ar.hs --- a/Distribution/Simple/Program/Ar.hs +++ b/Distribution/Simple/Program/Ar.hs @@ -15,7 +15,7 @@ multiStageProgramInvocation ) where -import Control.Monad (when, unless) +import Control.Monad (unless) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.Char (isSpace) @@ -26,8 +26,6 @@ import Distribution.Simple.Program.Run ( programInvocation, multiStageProgramInvocation , runProgramInvocation ) -import qualified Distribution.Simple.Program.Strip as Strip - ( stripLib ) import Distribution.Simple.Utils ( dieWithLocation, withTempDirectory ) import Distribution.System @@ -86,16 +84,15 @@ | inv <- multiStageProgramInvocation simple (initial, middle, final) files ] - when stripLib $ Strip.stripLib verbosity platform progConf tmpPath - unless (hostArch == Arm) $ -- See #1537 + unless (hostArch == Arm -- See #1537 + || hostOS == AIX) $ -- AIX uses its own "ar" format variant wipeMetadata tmpPath equal <- filesEqual tmpPath targetPath unless equal $ renameFile tmpPath targetPath where progConf = withPrograms lbi - stripLib = stripLibs lbi - platform@(Platform hostArch hostOS) = hostPlatform lbi + Platform hostArch hostOS = hostPlatform lbi verbosityOpts v | v >= deafening = ["-v"] | v >= verbose = [] | otherwise = ["-c"] 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 @@ -46,25 +46,16 @@ ) where import Distribution.Simple.Program.Find - ( findProgramOnSearchPath ) +import Distribution.Simple.Program.Internal import Distribution.Simple.Program.Run - ( getProgramInvocationOutput, programInvocation ) import Distribution.Simple.Program.Types - ( Program(..), ConfiguredProgram(..), simpleProgram ) import Distribution.Simple.Utils - ( findProgramVersion ) import Distribution.Compat.Exception - ( catchIO ) import Distribution.Verbosity - ( lessVerbose ) import Distribution.Version - ( Version(..), withinRange, earlierVersion, laterVersion - , intersectVersionRanges ) + import Data.Char ( isDigit ) - -import Data.List - ( isInfixOf ) import qualified Data.Map as Map -- ------------------------------------------------------------ @@ -225,16 +216,16 @@ haskellSuiteProgram = (simpleProgram "haskell-suite") { -- pretend that the program exists, otherwise it won't be in the -- "configured" state - programFindLocation = - \_verbosity _searchPath -> return $ Just "haskell-suite-dummy-location" + programFindLocation = \_verbosity _searchPath -> + return $ Just ("haskell-suite-dummy-location", []) } -- This represent a haskell-suite package manager. See the comments for -- haskellSuiteProgram. haskellSuitePkgProgram :: Program haskellSuitePkgProgram = (simpleProgram "haskell-suite-pkg") { - programFindLocation = - \_verbosity _searchPath -> return $ Just "haskell-suite-pkg-dummy-location" + programFindLocation = \_verbosity _searchPath -> + return $ Just ("haskell-suite-pkg-dummy-location", []) } @@ -269,24 +260,8 @@ stripProgram :: Program stripProgram = (simpleProgram "strip") { programFindVersion = \verbosity -> - findProgramVersion "--version" selectVersion (lessVerbose verbosity) + findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity) } - where - selectVersion str = - -- Invoking "strip --version" gives very inconsistent - -- results. We look for the first word that starts with a - -- number, and try parsing out the first two components of - -- it. Non-GNU 'strip' doesn't appear to have a version flag. - let numeric "" = False - numeric (x:_) = isDigit x - in case dropWhile (not . numeric) (words str) of - (ver:_) -> - -- take the first two version components - let isDot = (== '.') - (major, rest) = break isDot ver - minor = takeWhile (not . isDot) (dropWhile isDot rest) - in major ++ "." ++ minor - _ -> "" hsc2hsProgram :: Program hsc2hsProgram = (simpleProgram "hsc2hs") { 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 @@ -1,6 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} - ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Program.Db @@ -59,29 +56,19 @@ ) where 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, doesExecutableExist ) import Distribution.Version - ( Version, VersionRange, isAnyVersion, withinRange ) import Distribution.Text - ( display ) import Distribution.Verbosity - ( Verbosity ) +import Distribution.Compat.Binary -import Distribution.Compat.Binary (Binary(..)) -#if __GLASGOW_HASKELL__ < 710 -import Data.Functor ((<$>)) -#endif import Data.List ( foldl' ) import Data.Maybe ( catMaybes ) +import Data.Tuple (swap) import qualified Data.Map as Map import Control.Monad ( join, foldM ) @@ -129,28 +116,42 @@ -- Read & Show instances are based on listToFM --- Note that we only serialise the configured part of the database, this is --- because we don't need the unconfigured part after the configure stage, and --- additionally because we cannot read/show 'Program' as it contains functions. + +-- | Note that this instance does not preserve the known 'Program's. +-- See 'restoreProgramDb' for details. +-- instance Show ProgramDb where show = show . Map.toAscList . configuredProgs +-- | Note that this instance does not preserve the known 'Program's. +-- See 'restoreProgramDb' for details. +-- instance Read ProgramDb where readsPrec p s = [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r) | (s', r) <- readsPrec p s ] +-- | Note that this instance does not preserve the known 'Program's. +-- See 'restoreProgramDb' for details. +-- instance Binary ProgramDb where - put = put . configuredProgs + put db = do + put (progSearchPath db) + put (configuredProgs db) + get = do - progs <- get - return $! emptyProgramDb { configuredProgs = progs } + searchpath <- get + progs <- get + return $! emptyProgramDb { + progSearchPath = searchpath, + configuredProgs = progs + } --- | The Read\/Show instance does not preserve all the unconfigured 'Programs' --- because 'Program' is not in Read\/Show because it contains functions. So to --- fully restore a deserialised 'ProgramDb' use this function to add --- back all the known 'Program's. +-- | The 'Read'\/'Show' and 'Binary' instances do not preserve all the +-- unconfigured 'Programs' because 'Program' is not in 'Read'\/'Show' because +-- it contains functions. So to fully restore a deserialised 'ProgramDb' use +-- this function to add back all the known 'Program's. -- -- * It does not add the default programs, but you probably want them, use -- 'builtinPrograms' in addition to any extra you might need. @@ -319,21 +320,23 @@ configureProgram verbosity prog conf = do let name = programName prog maybeLocation <- case userSpecifiedPath prog conf of - Nothing -> programFindLocation prog verbosity (progSearchPath conf) - >>= return . fmap FoundOnSystem + Nothing -> + programFindLocation prog verbosity (progSearchPath conf) + >>= return . fmap (swap . fmap FoundOnSystem . swap) Just path -> do absolute <- doesExecutableExist path if absolute - then return (Just (UserSpecified path)) + then return (Just (UserSpecified path, [])) else findProgramOnSearchPath verbosity (progSearchPath conf) path - >>= maybe (die notFound) (return . Just . UserSpecified) + >>= maybe (die notFound) + (return . Just . swap . fmap UserSpecified . swap) where notFound = "Cannot find the program '" ++ name ++ "'. User-specified path '" ++ path ++ "' does not refer to an executable and " ++ "the program is not on the system path." case maybeLocation of Nothing -> return conf - Just location -> do + Just (location, triedLocations) -> do version <- programFindVersion prog verbosity (locationPath location) newPath <- programSearchPathAsPATHVar (progSearchPath conf) let configuredProg = ConfiguredProgram { @@ -343,7 +346,8 @@ programOverrideArgs = userSpecifiedArgs prog conf, programOverrideEnv = [("PATH", Just newPath)], programProperties = Map.empty, - programLocation = location + programLocation = location, + programMonitorFiles = triedLocations } configuredProg' <- programPostConf prog verbosity configuredProg return (updateConfiguredProgs (Map.insert name configuredProg') conf) @@ -443,7 +447,7 @@ | otherwise -> return $! Left (badVersion version location) Nothing -> - return $! Left (noVersion location) + return $! Left (unknownVersion location) where notFound = "The program '" ++ programName prog ++ "'" ++ versionRequirement @@ -452,7 +456,7 @@ ++ programName prog ++ "'" ++ versionRequirement ++ " is required but the version found at " ++ locationPath l ++ " is version " ++ display v - noVersion l = "The program '" + unknownVersion l = "The program '" ++ programName prog ++ "'" ++ versionRequirement ++ " is required but the version of " ++ locationPath l ++ " could not be determined." @@ -467,5 +471,5 @@ -> ProgramDb -> IO (ConfiguredProgram, Version, ProgramDb) requireProgramVersion verbosity prog range programDb = - join $ either die return <$> + join $ either die return `fmap` lookupProgramVersion verbosity prog range programDb diff --git a/Distribution/Simple/Program/Find.hs b/Distribution/Simple/Program/Find.hs --- a/Distribution/Simple/Program/Find.hs +++ b/Distribution/Simple/Program/Find.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE CPP, DeriveGeneric #-} + ----------------------------------------------------------------------------- -- | --- Module : Distribution.Simple.Program.Types +-- Module : Distribution.Simple.Program.Find -- Copyright : Duncan Coutts 2013 -- -- Maintainer : cabal-devel@haskell.org @@ -26,23 +28,26 @@ defaultProgramSearchPath, findProgramOnSearchPath, programSearchPathAsPATHVar, + getSystemSearchPath, ) where import Distribution.Verbosity - ( Verbosity ) import Distribution.Simple.Utils - ( debug, doesExecutableExist ) import Distribution.System - ( OS(..), buildOS ) -import System.Directory - ( findExecutable ) import Distribution.Compat.Environment - ( getEnvironment ) -import System.FilePath - ( (), (<.>), splitSearchPath, searchPathSeparator ) -import Data.List - ( intercalate ) +import Distribution.Compat.Binary +import qualified System.Directory as Directory + ( findExecutable ) +import System.FilePath as FilePath + ( (), (<.>), splitSearchPath, searchPathSeparator, getSearchPath + , takeDirectory ) +import Data.List + ( nub ) +import GHC.Generics +#if defined(mingw32_HOST_OS) +import qualified System.Win32 as Win32 +#endif -- | A search path to use when locating executables. This is analogous -- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use @@ -60,58 +65,69 @@ data ProgramSearchPathEntry = ProgramSearchPathDir FilePath -- ^ A specific dir | ProgramSearchPathDefault -- ^ The system default + deriving (Eq, Generic) +instance Binary ProgramSearchPathEntry + defaultProgramSearchPath :: ProgramSearchPath defaultProgramSearchPath = [ProgramSearchPathDefault] findProgramOnSearchPath :: Verbosity -> ProgramSearchPath - -> FilePath -> IO (Maybe FilePath) + -> FilePath -> IO (Maybe (FilePath, [FilePath])) findProgramOnSearchPath verbosity searchpath prog = do debug verbosity $ "Searching for " ++ prog ++ " in path." - res <- tryPathElems searchpath + res <- tryPathElems [] searchpath case res of Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") - Just path -> debug verbosity ("Found " ++ prog ++ " at "++ path) + Just (path, _) -> debug verbosity ("Found " ++ prog ++ " at "++ path) return res where - tryPathElems [] = return Nothing - tryPathElems (pe:pes) = do + tryPathElems :: [[FilePath]] -> [ProgramSearchPathEntry] + -> IO (Maybe (FilePath, [FilePath])) + tryPathElems _ [] = return Nothing + tryPathElems tried (pe:pes) = do res <- tryPathElem pe case res of - Nothing -> tryPathElems pes - Just _ -> return res + (Nothing, notfoundat) -> tryPathElems (notfoundat : tried) pes + (Just foundat, notfoundat) -> return (Just (foundat, alltried)) + where + alltried = concat (reverse (notfoundat : tried)) + tryPathElem :: ProgramSearchPathEntry -> IO (Maybe FilePath, [FilePath]) 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"] - Ghcjs -> ["", "exe"] - _ -> [""] + findFirstExe [ dir prog <.> ext | ext <- exeExtensions ] - tryPathElem ProgramSearchPathDefault = do - -- 'findExecutable' doesn't check that the path really refers to an - -- executable on Windows (at least with GHC < 7.8). See - -- https://ghc.haskell.org/trac/ghc/ticket/2184 - mExe <- findExecutable prog + -- On windows, getSystemSearchPath is not guaranteed 100% correct so we + -- use findExecutable and then approximate the not-found-at locations. + tryPathElem ProgramSearchPathDefault | buildOS == Windows = do + mExe <- findExecutable prog + syspath <- getSystemSearchPath case mExe of - Just exe -> do - exeExists <- doesExecutableExist exe - if exeExists - then return mExe - else return Nothing - _ -> return mExe + Nothing -> + let notfoundat = [ dir prog | dir <- syspath ] in + return (Nothing, notfoundat) - findFirstExe [] = return Nothing - findFirstExe (f:fs) = do - isExe <- doesExecutableExist f - if isExe - then return (Just f) - else findFirstExe fs + Just foundat -> do + let founddir = takeDirectory foundat + notfoundat = [ dir prog + | dir <- takeWhile (/= founddir) syspath ] + return (Just foundat, notfoundat) + -- On other OSs we can just do the simple thing + tryPathElem ProgramSearchPathDefault = do + dirs <- getSystemSearchPath + findFirstExe [ dir prog <.> ext | dir <- dirs, ext <- exeExtensions ] + + findFirstExe :: [FilePath] -> IO (Maybe FilePath, [FilePath]) + findFirstExe = go [] + where + go fs' [] = return (Nothing, reverse fs') + go fs' (f:fs) = do + isExe <- doesExecutableExist f + if isExe + then return (Just f, reverse fs') + else go (f:fs') 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%@. @@ -124,3 +140,46 @@ getEntries ProgramSearchPathDefault = do env <- getEnvironment return (maybe [] splitSearchPath (lookup "PATH" env)) + +-- | Get the system search path. On Unix systems this is just the @$PATH@ env +-- var, but on windows it's a bit more complicated. +-- +getSystemSearchPath :: IO [FilePath] +getSystemSearchPath = fmap nub $ do +#if defined(mingw32_HOST_OS) + processdir <- takeDirectory `fmap` Win32.getModuleFileName Win32.nullHANDLE + currentdir <- Win32.getCurrentDirectory + systemdir <- Win32.getSystemDirectory + windowsdir <- Win32.getWindowsDirectory + pathdirs <- FilePath.getSearchPath + let path = processdir : currentdir + : systemdir : windowsdir + : pathdirs + return path +#else + FilePath.getSearchPath +#endif + +#ifdef MIN_VERSION_directory +#if MIN_VERSION_directory(1,2,1) +#define HAVE_directory_121 +#endif +#endif + +findExecutable :: FilePath -> IO (Maybe FilePath) +#ifdef HAVE_directory_121 +findExecutable = Directory.findExecutable +#else +findExecutable prog = do + -- With directory < 1.2.1 'findExecutable' doesn't check that the path + -- really refers to an executable. + mExe <- Directory.findExecutable prog + case mExe of + Just exe -> do + exeExists <- doesExecutableExist exe + if exeExists + then return mExe + else return Nothing + _ -> return mExe +#endif + 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 @@ -1,9 +1,11 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} + module Distribution.Simple.Program.GHC ( GhcOptions(..), GhcMode(..), GhcOptimisation(..), GhcDynLinkMode(..), + GhcProfAuto(..), ghcInvocation, renderGhcOptions, @@ -12,25 +14,23 @@ ) where -import Distribution.Simple.GHC.ImplInfo ( getImplInfo, GhcImplInfo(..) ) +import Distribution.Compat.Semigroup as Semi +import Distribution.Simple.GHC.ImplInfo import Distribution.Package import Distribution.PackageDescription hiding (Flag) import Distribution.ModuleName import Distribution.Simple.Compiler hiding (Flag) -import Distribution.Simple.Setup ( Flag(..), flagToMaybe, fromFlagOrDefault, - flagToList ) +import Distribution.Simple.Setup import Distribution.Simple.Program.Types import Distribution.Simple.Program.Run +import Distribution.System import Distribution.Text import Distribution.Verbosity -import Distribution.Utils.NubList ( NubListR, fromNubListR ) -import Language.Haskell.Extension ( Language(..), Extension(..) ) +import Distribution.Utils.NubList +import Language.Haskell.Extension +import GHC.Generics (Generic) import qualified Data.Map as M -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif -import Data.List ( intercalate ) -- | A structured set of GHC options/flags -- @@ -73,9 +73,12 @@ ------------- -- Packages - -- | The package key the modules will belong to; the @ghc -this-package-key@ - -- flag. - ghcOptPackageKey :: Flag PackageKey, + -- | The unit ID the modules will belong to; the @ghc -this-unit-id@ + -- flag (or @-this-package-key@ or @-package-name@ on older + -- versions of GHC). This is a 'String' because we assume you've + -- already figured out what the correct format for this string is + -- (we need to handle backwards compatibility.) + ghcOptThisUnitId :: Flag String, -- | GHC package databases to use, the @ghc -package-conf@ flag. ghcOptPackageDBs :: PackageDBStack, @@ -84,7 +87,7 @@ -- requires both the short and long form of the package id; -- the @ghc -package@ or @ghc -package-id@ flags. ghcOptPackages :: - NubListR (InstalledPackageId, PackageId, ModuleRenaming), + NubListR (UnitId, PackageId, ModuleRenaming), -- | Start with a clean package set; the @ghc -hide-all-packages@ flag ghcOptHideAllPackages :: Flag Bool, @@ -93,9 +96,6 @@ -- -no-auto-link-packages@ flag. ghcOptNoAutoLinkPackages :: Flag Bool, - -- | What packages are implementing the signatures - ghcOptSigOf :: [(ModuleName, (PackageKey, ModuleName))], - ----------------- -- Linker stuff @@ -111,6 +111,10 @@ -- | OSX only: frameworks to link in; the @ghc -framework@ flag. ghcOptLinkFrameworks :: NubListR String, + -- | OSX only: Search path for frameworks to link in; the + -- @ghc -framework-path@ flag. + ghcOptLinkFrameworkDirs :: NubListR String, + -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag. ghcOptNoLink :: Flag Bool, @@ -161,6 +165,9 @@ -- | Compile in profiling mode; the @ghc -prof@ flag. ghcOptProfilingMode :: Flag Bool, + -- | Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags. + ghcOptProfilingAuto :: Flag GhcProfAuto, + -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag. ghcOptSplitObjs :: Flag Bool, @@ -207,7 +214,7 @@ -- Modifies some of the GHC error messages. ghcOptCabal :: Flag Bool -} deriving Show +} deriving (Show, Generic) data GhcMode = GhcModeCompile -- ^ @ghc -c@ @@ -230,18 +237,24 @@ | GhcStaticAndDynamic -- ^ @-static -dynamic-too@ deriving (Show, Eq) +data GhcProfAuto = GhcProfAutoAll -- ^ @-fprof-auto@ + | GhcProfAutoToplevel -- ^ @-fprof-auto-top@ + | GhcProfAutoExported -- ^ @-fprof-auto-exported@ + deriving (Show, Eq) -runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> GhcOptions -> IO () -runGHC verbosity ghcProg comp opts = do - runProgramInvocation verbosity (ghcInvocation ghcProg comp opts) +runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> Platform -> GhcOptions + -> IO () +runGHC verbosity ghcProg comp platform opts = do + runProgramInvocation verbosity (ghcInvocation ghcProg comp platform opts) -ghcInvocation :: ConfiguredProgram -> Compiler -> GhcOptions -> ProgramInvocation -ghcInvocation prog comp opts = - programInvocation prog (renderGhcOptions comp opts) +ghcInvocation :: ConfiguredProgram -> Compiler -> Platform -> GhcOptions + -> ProgramInvocation +ghcInvocation prog comp platform opts = + programInvocation prog (renderGhcOptions comp platform opts) -renderGhcOptions :: Compiler -> GhcOptions -> [String] -renderGhcOptions comp opts +renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] +renderGhcOptions comp _platform@(Platform _arch os) opts | compilerFlavor comp `notElem` [GHC, GHCJS] = error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " ++ "compiler flavor must be 'GHC' or 'GHCJS'!" @@ -283,6 +296,20 @@ , [ "-prof" | flagBool ghcOptProfilingMode ] + , case flagToMaybe (ghcOptProfilingAuto opts) of + _ | not (flagBool ghcOptProfilingMode) + -> [] + Nothing -> [] + Just GhcProfAutoAll + | flagProfAuto implInfo -> ["-fprof-auto"] + | otherwise -> ["-auto-all"] -- not the same, but close + Just GhcProfAutoToplevel + | flagProfAuto implInfo -> ["-fprof-auto-top"] + | otherwise -> ["-auto-all"] + Just GhcProfAutoExported + | flagProfAuto implInfo -> ["-fprof-auto-exported"] + | otherwise -> ["-auto"] + , [ "-split-objs" | flagBool ghcOptSplitObjs ] , case flagToMaybe (ghcOptHPCDir opts) of @@ -345,7 +372,14 @@ , [ "-optl" ++ opt | opt <- flags ghcOptLinkOptions ] , ["-l" ++ lib | lib <- flags ghcOptLinkLibs ] , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath ] - , concat [ ["-framework", fmwk] | fmwk <- flags ghcOptLinkFrameworks ] + , if isOSX + then concat [ ["-framework", fmwk] + | fmwk <- flags ghcOptLinkFrameworks ] + else [] + , if isOSX + then concat [ ["-framework-path", path] + | path <- flags ghcOptLinkFrameworkDirs ] + else [] , [ "-no-hs-main" | flagBool ghcOptLinkNoHsMain ] , [ "-dynload deploy" | not (null (flags ghcOptRPaths)) ] , concat [ [ "-optl-Wl,-rpath," ++ dir] @@ -354,25 +388,18 @@ ------------- -- Packages - , concat [ [if packageKeySupported comp - then "-this-package-key" - else "-package-name", display pkgid] - | pkgid <- flag ghcOptPackageKey ] + , concat [ [ case () of + _ | unitIdSupported comp -> "-this-unit-id" + | packageKeySupported comp -> "-this-package-key" + | otherwise -> "-package-name" + , this_arg ] + | this_arg <- flag ghcOptThisUnitId ] , [ "-hide-all-packages" | flagBool ghcOptHideAllPackages ] , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ] , packageDbArgs implInfo (ghcOptPackageDBs opts) - , if null (ghcOptSigOf opts) - then [] - else "-sig-of" - : intercalate "," (map (\(n,(p,m)) -> display n ++ " is " - ++ display p ++ ":" - ++ display m) - (ghcOptSigOf opts)) - : [] - , concat $ if flagPackageId implInfo then let space "" = "" space xs = ' ' : xs @@ -419,6 +446,7 @@ where implInfo = getImplInfo comp + isOSX = os == OSX flag flg = flagToList (flg opts) flags flg = fromNubListR . flg $ opts flagBool flg = fromFlagOrDefault False (flg opts) @@ -430,133 +458,49 @@ | otherwise = ["-w", "-v0"] -packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String] -packageDbArgs implInfo dbstack = case dbstack of +-- | GHC <7.6 uses '-package-conf' instead of '-package-db'. +packageDbArgsConf :: PackageDBStack -> [String] +packageDbArgsConf dbstack = case dbstack of (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs - (GlobalPackageDB:dbs) -> ("-no-user-" ++ packageDbFlag) + (GlobalPackageDB:dbs) -> ("-no-user-package-conf") : concatMap specific dbs _ -> ierror where - specific (SpecificPackageDB db) = [ '-':packageDbFlag , db ] - specific _ = ierror - ierror = error $ "internal error: unexpected package db stack: " - ++ show dbstack - packageDbFlag - | flagPackageConf implInfo - = "package-conf" - | otherwise - = "package-db" + specific (SpecificPackageDB db) = [ "-package-conf", db ] + specific _ = ierror + ierror = error $ "internal error: unexpected package db stack: " + ++ show dbstack +-- | GHC >= 7.6 uses the '-package-db' flag. See +-- https://ghc.haskell.org/trac/ghc/ticket/5977. +packageDbArgsDb :: PackageDBStack -> [String] +-- special cases to make arguments prettier in common scenarios +packageDbArgsDb dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) + | all isSpecific dbs -> concatMap single dbs + (GlobalPackageDB:dbs) + | all isSpecific dbs -> "-no-user-package-db" + : concatMap single dbs + dbs -> "-clear-package-db" + : concatMap single dbs + where + single (SpecificPackageDB db) = [ "-package-db", db ] + single GlobalPackageDB = [ "-global-package-db" ] + single UserPackageDB = [ "-user-package-db" ] + isSpecific (SpecificPackageDB _) = True + isSpecific _ = False +packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String] +packageDbArgs implInfo + | flagPackageConf implInfo = packageDbArgsConf + | otherwise = packageDbArgsDb + -- ----------------------------------------------------------------------------- -- Boilerplate Monoid instance for GhcOptions instance Monoid GhcOptions where - mempty = GhcOptions { - ghcOptMode = mempty, - ghcOptExtra = mempty, - ghcOptExtraDefault = mempty, - ghcOptInputFiles = mempty, - ghcOptInputModules = mempty, - ghcOptOutputFile = mempty, - ghcOptOutputDynFile = mempty, - ghcOptSourcePathClear = mempty, - ghcOptSourcePath = mempty, - ghcOptPackageKey = mempty, - ghcOptPackageDBs = mempty, - ghcOptPackages = mempty, - ghcOptHideAllPackages = mempty, - ghcOptNoAutoLinkPackages = mempty, - ghcOptSigOf = mempty, - ghcOptLinkLibs = mempty, - ghcOptLinkLibPath = mempty, - ghcOptLinkOptions = mempty, - ghcOptLinkFrameworks = mempty, - ghcOptNoLink = mempty, - ghcOptLinkNoHsMain = mempty, - ghcOptCcOptions = mempty, - ghcOptCppOptions = mempty, - ghcOptCppIncludePath = mempty, - ghcOptCppIncludes = mempty, - ghcOptFfiIncludes = mempty, - ghcOptLanguage = mempty, - ghcOptExtensions = mempty, - ghcOptExtensionMap = mempty, - ghcOptOptimisation = mempty, - ghcOptDebugInfo = mempty, - ghcOptProfilingMode = mempty, - ghcOptSplitObjs = mempty, - ghcOptNumJobs = mempty, - ghcOptHPCDir = mempty, - ghcOptGHCiScripts = mempty, - ghcOptHiSuffix = mempty, - ghcOptObjSuffix = mempty, - ghcOptDynHiSuffix = mempty, - ghcOptDynObjSuffix = mempty, - ghcOptHiDir = mempty, - ghcOptObjDir = mempty, - ghcOptOutputDir = mempty, - ghcOptStubDir = mempty, - ghcOptDynLinkMode = mempty, - ghcOptShared = mempty, - ghcOptFPic = mempty, - ghcOptDylibName = mempty, - ghcOptRPaths = mempty, - ghcOptVerbosity = mempty, - ghcOptCabal = mempty - } - mappend a b = GhcOptions { - ghcOptMode = combine ghcOptMode, - ghcOptExtra = combine ghcOptExtra, - ghcOptExtraDefault = combine ghcOptExtraDefault, - ghcOptInputFiles = combine ghcOptInputFiles, - ghcOptInputModules = combine ghcOptInputModules, - ghcOptOutputFile = combine ghcOptOutputFile, - ghcOptOutputDynFile = combine ghcOptOutputDynFile, - ghcOptSourcePathClear = combine ghcOptSourcePathClear, - ghcOptSourcePath = combine ghcOptSourcePath, - ghcOptPackageKey = combine ghcOptPackageKey, - ghcOptPackageDBs = combine ghcOptPackageDBs, - ghcOptPackages = combine ghcOptPackages, - ghcOptHideAllPackages = combine ghcOptHideAllPackages, - ghcOptNoAutoLinkPackages = combine ghcOptNoAutoLinkPackages, - ghcOptSigOf = combine ghcOptSigOf, - ghcOptLinkLibs = combine ghcOptLinkLibs, - ghcOptLinkLibPath = combine ghcOptLinkLibPath, - ghcOptLinkOptions = combine ghcOptLinkOptions, - ghcOptLinkFrameworks = combine ghcOptLinkFrameworks, - ghcOptNoLink = combine ghcOptNoLink, - ghcOptLinkNoHsMain = combine ghcOptLinkNoHsMain, - ghcOptCcOptions = combine ghcOptCcOptions, - ghcOptCppOptions = combine ghcOptCppOptions, - ghcOptCppIncludePath = combine ghcOptCppIncludePath, - ghcOptCppIncludes = combine ghcOptCppIncludes, - ghcOptFfiIncludes = combine ghcOptFfiIncludes, - ghcOptLanguage = combine ghcOptLanguage, - ghcOptExtensions = combine ghcOptExtensions, - ghcOptExtensionMap = combine ghcOptExtensionMap, - ghcOptOptimisation = combine ghcOptOptimisation, - ghcOptDebugInfo = combine ghcOptDebugInfo, - ghcOptProfilingMode = combine ghcOptProfilingMode, - ghcOptSplitObjs = combine ghcOptSplitObjs, - ghcOptNumJobs = combine ghcOptNumJobs, - ghcOptHPCDir = combine ghcOptHPCDir, - 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, - ghcOptDynLinkMode = combine ghcOptDynLinkMode, - ghcOptShared = combine ghcOptShared, - ghcOptFPic = combine ghcOptFPic, - ghcOptDylibName = combine ghcOptDylibName, - ghcOptRPaths = combine ghcOptRPaths, - ghcOptVerbosity = combine ghcOptVerbosity, - ghcOptCabal = combine ghcOptCabal - } - where - combine field = field a `mappend` field b + mempty = gmempty + mappend = (Semi.<>) + +instance Semigroup GhcOptions where + (<>) = gmappend 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 @@ -16,53 +16,48 @@ invoke, register, reregister, + registerMultiInstance, unregister, + recache, expose, hide, dump, + describe, list, -- * Program invocations initInvocation, registerInvocation, reregisterInvocation, + registerMultiInstanceInvocation, unregisterInvocation, + recacheInvocation, exposeInvocation, hideInvocation, dumpInvocation, + describeInvocation, listInvocation, ) where -import Prelude hiding (init) -import Distribution.Package - ( PackageId, InstalledPackageId(..) ) +import Distribution.Package hiding (installedUnitId) import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, InstalledPackageInfo_(..) - , showInstalledPackageInfo - , emptyInstalledPackageInfo, fieldsInstalledPackageInfo ) import Distribution.ParseUtils import Distribution.Simple.Compiler - ( PackageDB(..), PackageDBStack ) import Distribution.Simple.Program.Types - ( ConfiguredProgram(programId) ) import Distribution.Simple.Program.Run - ( ProgramInvocation(..), IOEncoding(..), programInvocation - , runProgramInvocation, getProgramInvocationOutput ) import Distribution.Text - ( display, simpleParse ) import Distribution.Simple.Utils - ( die ) import Distribution.Verbosity - ( Verbosity, deafening, silent ) import Distribution.Compat.Exception - ( catchExit ) +import Prelude hiding (init) import Data.Char ( isSpace ) import Data.List ( stripPrefix ) import System.FilePath as FilePath - ( (), splitPath, splitDirectories, joinPath, isPathSeparator ) + ( (), (<.>) + , splitPath, splitDirectories, joinPath, isPathSeparator ) import qualified System.FilePath.Posix as FilePath.Posix -- | Information about the features and capabilities of an @hc-pkg@ @@ -73,17 +68,25 @@ , noPkgDbStack :: Bool -- ^ no package DB stack supported , noVerboseFlag :: Bool -- ^ hc-pkg does not support verbosity flags , flagPackageConf :: Bool -- ^ use package-conf option instead of package-db - , useSingleFileDb :: Bool -- ^ requires single file package database + , supportsDirDbs :: Bool -- ^ supports directory style package databases + , requiresDirDbs :: Bool -- ^ requires directory style package databases + , nativeMultiInstance :: Bool -- ^ supports --enable-multi-instance flag + , recacheMultiInstance :: Bool -- ^ supports multi-instance via recache } -- | Call @hc-pkg@ to initialise a package database at the location {path}. -- -- > hc-pkg init {path} -- -init :: HcPkgInfo -> Verbosity -> FilePath -> IO () -init hpi verbosity path = - runProgramInvocation verbosity (initInvocation hpi verbosity path) +init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO () +init hpi verbosity preferCompat path + | not (supportsDirDbs hpi) + || (not (requiresDirDbs hpi) && preferCompat) + = writeFile path "[]" + | otherwise + = runProgramInvocation verbosity (initInvocation hpi verbosity path) + -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO () @@ -118,7 +121,51 @@ runProgramInvocation verbosity (reregisterInvocation hpi verbosity packagedb pkgFile) +registerMultiInstance :: HcPkgInfo -> Verbosity + -> PackageDBStack + -> InstalledPackageInfo + -> IO () +registerMultiInstance hpi verbosity packagedbs pkgInfo + | nativeMultiInstance hpi + = runProgramInvocation verbosity + (registerMultiInstanceInvocation hpi verbosity packagedbs (Right pkgInfo)) + -- This is a trick. Older versions of GHC do not support the + -- --enable-multi-instance flag for ghc-pkg register but it turns out that + -- the same ability is available by using ghc-pkg recache. The recache + -- command is there to support distro package managers that like to work + -- by just installing files and running update commands, rather than + -- special add/remove commands. So the way to register by this method is + -- to write the package registration file directly into the package db and + -- then call hc-pkg recache. + -- + | recacheMultiInstance hpi + = do let pkgdb = last packagedbs + writeRegistrationFileDirectly hpi pkgdb pkgInfo + recache hpi verbosity pkgdb + + | otherwise + = die $ "HcPkg.registerMultiInstance: the compiler does not support " + ++ "registering multiple instances of packages." + +writeRegistrationFileDirectly :: HcPkgInfo + -> PackageDB + -> InstalledPackageInfo + -> IO () +writeRegistrationFileDirectly hpi (SpecificPackageDB dir) pkgInfo + | supportsDirDbs hpi + = do let pkgfile = dir display (installedUnitId pkgInfo) <.> "conf" + writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo) + + | otherwise + = die $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs" + +writeRegistrationFileDirectly _ _ _ = + -- We don't know here what the dir for the global or user dbs are, + -- if that's needed it'll require a bit more plumbing to support. + die $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now" + + -- | Call @hc-pkg@ to unregister a package -- -- > hc-pkg unregister [pkgid] [--user | --global | --package-db] @@ -129,6 +176,16 @@ (unregisterInvocation hpi verbosity packagedb pkgid) +-- | Call @hc-pkg@ to recache the registered packages. +-- +-- > hc-pkg recache [--user | --global | --package-db] +-- +recache :: HcPkgInfo -> Verbosity -> PackageDB -> IO () +recache hpi verbosity packagedb = + runProgramInvocation verbosity + (recacheInvocation hpi verbosity packagedb) + + -- | Call @hc-pkg@ to expose a package. -- -- > hc-pkg expose [pkgid] [--user | --global | --package-db] @@ -138,7 +195,22 @@ runProgramInvocation verbosity (exposeInvocation hpi verbosity packagedb pkgid) +-- | Call @hc-pkg@ to retrieve a specific package +-- +-- > hc-pkg describe [pkgid] [--user | --global | --package-db] +-- +describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo] +describe hpi verbosity packagedb pid = do + output <- getProgramInvocationOutput verbosity + (describeInvocation hpi verbosity packagedb pid) + `catchIO` \_ -> return "" + + case parsePackages output of + Left ok -> return ok + _ -> die $ "failed to parse output of '" + ++ programId (hcPkgProgram hpi) ++ " describe " ++ display pid ++ "'" + -- | Call @hc-pkg@ to hide a package. -- -- > hc-pkg hide [pkgid] [--user | --global | --package-db] @@ -157,40 +229,40 @@ output <- getProgramInvocationOutput verbosity (dumpInvocation hpi verbosity packagedb) - `catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed" + `catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed" case parsePackages output of Left ok -> return ok _ -> die $ "failed to parse output of '" ++ programId (hcPkgProgram hpi) ++ " dump'" +parsePackages :: String -> Either [InstalledPackageInfo] [PError] +parsePackages str = + let parsed = map parseInstalledPackageInfo' (splitPkgs str) + in case [ msg | ParseFailed msg <- parsed ] of + [] -> Left [ setUnitId + . maybe id mungePackagePaths (pkgRoot pkg) + $ pkg + | ParseOk _ pkg <- parsed ] + msgs -> Right msgs where - parsePackages str = - let parsed = map parseInstalledPackageInfo' (splitPkgs str) - in case [ msg | ParseFailed msg <- parsed ] of - [] -> Left [ setInstalledPackageId - . maybe id mungePackagePaths (pkgRoot pkg) - $ pkg - | ParseOk _ pkg <- parsed ] - msgs -> Right msgs - parseInstalledPackageInfo' = parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo - --TODO: this could be a lot faster. We're doing normaliseLineEndings twice - -- and converting back and forth with lines/unlines. - splitPkgs :: String -> [String] - splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines - where - -- Handle the case of there being no packages at all. - checkEmpty [s] | all isSpace s = [] - checkEmpty ss = ss +--TODO: this could be a lot faster. We're doing normaliseLineEndings twice +-- and converting back and forth with lines/unlines. +splitPkgs :: String -> [String] +splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines + where + -- Handle the case of there being no packages at all. + checkEmpty [s] | all isSpace s = [] + checkEmpty ss = ss - splitWith :: (a -> Bool) -> [a] -> [[a]] - splitWith p xs = ys : case zs of - [] -> [] - _:ws -> splitWith p ws - where (ys,zs) = break p xs + splitWith :: (a -> Bool) -> [a] -> [[a]] + splitWith p xs = ys : case zs of + [] -> [] + _:ws -> splitWith p ws + where (ys,zs) = break p xs mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec @@ -230,26 +302,24 @@ _ -> Nothing --- Older installed package info files did not have the installedPackageId +-- Older installed package info files did not have the installedUnitId -- field, so if it is missing then we fill it as the source package ID. -setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo -setInstalledPackageId pkginfo@InstalledPackageInfo { - installedPackageId = InstalledPackageId "", - sourcePackageId = pkgid +setUnitId :: InstalledPackageInfo -> InstalledPackageInfo +setUnitId pkginfo@InstalledPackageInfo { + installedUnitId = SimpleUnitId (ComponentId ""), + sourcePackageId = pkgid } = pkginfo { - --TODO use a proper named function for the conversion - -- from source package id to installed package id - installedPackageId = InstalledPackageId (display pkgid) + installedUnitId = mkLegacyUnitId pkgid } -setInstalledPackageId pkginfo = pkginfo +setUnitId 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 +-- Note in particular that it does not include the 'UnitId', just -- the source 'PackageId' which is not necessarily unique in any package db. -- list :: HcPkgInfo -> Verbosity -> PackageDB @@ -258,7 +328,7 @@ output <- getProgramInvocationOutput verbosity (listInvocation hpi verbosity packagedb) - `catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed" + `catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed" case parsePackageIds output of Just ok -> return ok @@ -279,38 +349,36 @@ args = ["init", path] ++ verbosityOpts hpi verbosity -registerInvocation, reregisterInvocation +registerInvocation, reregisterInvocation, registerMultiInstanceInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> Either FilePath InstalledPackageInfo -> ProgramInvocation -registerInvocation = registerInvocation' "register" -reregisterInvocation = registerInvocation' "update" - +registerInvocation = registerInvocation' "register" False +reregisterInvocation = registerInvocation' "update" False +registerMultiInstanceInvocation = registerInvocation' "update" True -registerInvocation' :: String -> HcPkgInfo -> Verbosity -> PackageDBStack +registerInvocation' :: String -> Bool + -> HcPkgInfo -> Verbosity -> PackageDBStack -> Either FilePath InstalledPackageInfo -> ProgramInvocation -registerInvocation' cmdname hpi verbosity packagedbs (Left pkgFile) = - programInvocation (hcPkgProgram hpi) args - where - args = [cmdname, pkgFile] - ++ (if noPkgDbStack hpi - then [packageDbOpts hpi (last packagedbs)] - else packageDbStackOpts hpi packagedbs) - ++ verbosityOpts hpi verbosity +registerInvocation' cmdname multiInstance hpi + verbosity packagedbs pkgFileOrInfo = + case pkgFileOrInfo of + Left pkgFile -> + programInvocation (hcPkgProgram hpi) (args pkgFile) -registerInvocation' cmdname hpi verbosity packagedbs (Right pkgInfo) = - (programInvocation (hcPkgProgram hpi) args) { - progInvokeInput = Just (showInstalledPackageInfo pkgInfo), - progInvokeInputEncoding = IOEncodingUTF8 - } + Right pkgInfo -> + (programInvocation (hcPkgProgram hpi) (args "-")) { + progInvokeInput = Just (showInstalledPackageInfo pkgInfo), + progInvokeInputEncoding = IOEncodingUTF8 + } where - args = [cmdname, "-"] - ++ (if noPkgDbStack hpi - then [packageDbOpts hpi (last packagedbs)] - else packageDbStackOpts hpi packagedbs) - ++ verbosityOpts hpi verbosity - + args file = [cmdname, file] + ++ (if noPkgDbStack hpi + then [packageDbOpts hpi (last packagedbs)] + else packageDbStackOpts hpi packagedbs) + ++ [ "--enable-multi-instance" | multiInstance ] + ++ verbosityOpts hpi verbosity unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation @@ -320,6 +388,14 @@ ++ verbosityOpts hpi verbosity +recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB + -> ProgramInvocation +recacheInvocation hpi verbosity packagedb = + programInvocation (hcPkgProgram hpi) $ + ["recache", packageDbOpts hpi packagedb] + ++ verbosityOpts hpi verbosity + + exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation exposeInvocation hpi verbosity packagedb pkgid = @@ -327,6 +403,15 @@ ["expose", packageDbOpts hpi packagedb, display pkgid] ++ verbosityOpts hpi verbosity +describeInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId + -> ProgramInvocation +describeInvocation hpi verbosity packagedbs pkgid = + programInvocation (hcPkgProgram hpi) $ + ["describe", display pkgid] + ++ (if noPkgDbStack hpi + then [packageDbOpts hpi (last packagedbs)] + else packageDbStackOpts hpi packagedbs) + ++ verbosityOpts hpi verbosity hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation 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 @@ -13,14 +13,13 @@ , union ) where -import Distribution.ModuleName ( ModuleName ) +import Distribution.ModuleName import Distribution.Simple.Program.Run - ( ProgramInvocation, programInvocation, runProgramInvocation ) -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 ) +import Distribution.Simple.Program.Types +import Distribution.Text +import Distribution.Simple.Utils +import Distribution.Verbosity +import Distribution.Version -- | Invoke hpc with the given parameters. -- diff --git a/Distribution/Simple/Program/Internal.hs b/Distribution/Simple/Program/Internal.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/Internal.hs @@ -0,0 +1,46 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Internal +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Internal utilities used by Distribution.Simple.Program.*. + +module Distribution.Simple.Program.Internal ( + stripExtractVersion, + ) where + +import Data.Char (isDigit) +import Data.List (isPrefixOf, isSuffixOf) + +-- | Extract the version number from the output of 'strip --version'. +-- +-- Invoking "strip --version" gives very inconsistent results. We ignore +-- everything in parentheses (see #2497), look for the first word that starts +-- with a number, and try parsing out the first two components of it. Non-GNU +-- 'strip' doesn't appear to have a version flag. +stripExtractVersion :: String -> String +stripExtractVersion str = + let numeric "" = False + numeric (x:_) = isDigit x + + -- Filter out everything in parentheses. + filterPar' :: Int -> [String] -> [String] + filterPar' _ [] = [] + filterPar' n (x:xs) + | n >= 0 && "(" `isPrefixOf` x = filterPar' (n+1) ((tail x):xs) + | n > 0 && ")" `isSuffixOf` x = filterPar' (n-1) xs + | n > 0 = filterPar' n xs + | otherwise = x:filterPar' n xs + + filterPar = filterPar' 0 + + in case dropWhile (not . numeric) (filterPar . words $ str) of + (ver:_) -> + -- take the first two version components + let isDot = (== '.') + (major, rest) = break isDot ver + minor = takeWhile isDigit (dropWhile isDot rest) + in major ++ "." ++ minor + _ -> "" 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 @@ -24,12 +24,9 @@ ) where import Distribution.Simple.Program.Types - ( ConfiguredProgram(..), programPath ) import Distribution.Simple.Utils - ( die, rawSystemExit, rawSystemIOWithEnv, rawSystemStdInOut - , toUTF8, fromUTF8, normaliseLineEndings ) import Distribution.Verbosity - ( Verbosity ) +import Distribution.Compat.Environment import Data.List ( foldl', unfoldr ) @@ -38,8 +35,6 @@ ( when ) import System.Exit ( ExitCode(..), exitWith ) -import Distribution.Compat.Environment - ( getEnvironment ) -- | Represents a specific invocation of a specific program. -- 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 @@ -17,9 +17,7 @@ ) where import Distribution.Simple.Program.Run - ( ProgramInvocation(..) ) import Distribution.System - ( OS(..) ) import Data.Maybe ( maybeToList ) diff --git a/Distribution/Simple/Program/Strip.hs b/Distribution/Simple/Program/Strip.hs --- a/Distribution/Simple/Program/Strip.hs +++ b/Distribution/Simple/Program/Strip.hs @@ -10,16 +10,13 @@ module Distribution.Simple.Program.Strip (stripLib, stripExe) where -import Distribution.Simple.Program (ProgramConfiguration, lookupProgram - , programVersion, rawSystemProgram - , stripProgram) -import Distribution.Simple.Utils (warn) -import Distribution.System (Arch(..), Platform(..), OS (..), buildOS) -import Distribution.Verbosity (Verbosity) -import Distribution.Version (orLaterVersion, withinRange) +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Verbosity +import Distribution.Version import Control.Monad (unless) -import Data.Version (Version(..)) import System.FilePath (takeBaseName) runStrip :: Verbosity -> ProgramConfiguration -> FilePath -> [String] -> IO () @@ -47,10 +44,11 @@ stripLib :: Verbosity -> Platform -> ProgramConfiguration -> FilePath -> IO () stripLib verbosity (Platform arch os) conf path = do case os of - OSX -> -- '--strip-unneeded' is not supported on OS X, iOS or + OSX -> -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or -- Solaris. See #1630. return () IOS -> return () + AIX -> return () Solaris -> return () Windows -> -- Stripping triggers a bug in 'strip.exe' for -- libraries with lots identically named modules. See 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 @@ -33,14 +33,10 @@ ) where import Distribution.Simple.Program.Find - ( ProgramSearchPath, ProgramSearchPathEntry(..) - , findProgramOnSearchPath ) import Distribution.Version - ( Version ) import Distribution.Verbosity - ( Verbosity ) +import Distribution.Compat.Binary -import Distribution.Compat.Binary (Binary) import qualified Data.Map as Map import GHC.Generics (Generic) @@ -59,8 +55,13 @@ -- -- It is supplied with the prevailing search path which will typically -- just be used as-is, but can be extended or ignored as needed. + -- + -- For the purpose of change monitoring, in addition to the location + -- where the program was found, it returns all the other places that + -- were tried. + -- programFindLocation :: Verbosity -> ProgramSearchPath - -> IO (Maybe FilePath), + -> IO (Maybe (FilePath, [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. @@ -108,9 +109,18 @@ programProperties :: Map.Map String String, -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ - programLocation :: ProgramLocation - } deriving (Eq, Generic, Read, Show) + programLocation :: ProgramLocation, + -- | In addition to the 'programLocation' where the program was found, + -- these are additional locations that were looked at. The combination + -- of ths found location and these not-found locations can be used to + -- monitor to detect when the re-configuring the program might give a + -- different result (e.g. found in a different location). + -- + programMonitorFiles :: [FilePath] + } + deriving (Eq, Generic, Read, Show) + instance Binary ConfiguredProgram -- | Where a program was found. Also tells us whether it's specified by user or @@ -160,5 +170,6 @@ programOverrideArgs = [], programOverrideEnv = [], programProperties = Map.empty, - programLocation = loc + programLocation = loc, + programMonitorFiles = [] -- did not look in any other locations } diff --git a/Distribution/Simple/Register.hs b/Distribution/Simple/Register.hs --- a/Distribution/Simple/Register.hs +++ b/Distribution/Simple/Register.hs @@ -28,6 +28,10 @@ unregister, initPackageDB, + doesPackageDBExist, + createPackageDB, + deletePackageDB, + invokeHcPkg, registerPackage, generateRegistrationInfo, @@ -37,11 +41,7 @@ ) where import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) - , ComponentName(..), getComponentLocalBuildInfo - , LibraryName(..) - , InstallDirs(..), absoluteInstallDirs ) -import Distribution.Simple.BuildPaths (haddockName) +import Distribution.Simple.BuildPaths import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS @@ -50,41 +50,25 @@ import qualified Distribution.Simple.HaskellSuite as HaskellSuite import Distribution.Simple.Compiler - ( compilerVersion, Compiler, CompilerFlavor(..), compilerFlavor - , PackageDB, PackageDBStack, absolutePackageDBPaths - , registrationPackageDB ) import Distribution.Simple.Program - ( ProgramConfiguration, runProgramInvocation ) import Distribution.Simple.Program.Script - ( invocationAsSystemScript ) -import Distribution.Simple.Program.HcPkg (HcPkgInfo) import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Setup - ( RegisterFlags(..), CopyDest(..) - , fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.PackageDescription - ( PackageDescription(..), Library(..), BuildInfo(..), libModules ) import Distribution.Package - ( Package(..), packageName, InstalledPackageId(..) ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, InstalledPackageInfo_(InstalledPackageInfo) - , showInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Simple.Utils - ( writeUTF8File, writeFileAtomic, setFileExecutable - , die, notice, setupMessage, shortRelativePath ) import Distribution.System - ( OS(..), buildOS ) import Distribution.Text - ( display ) -import Distribution.Version ( Version(..) ) import Distribution.Verbosity as Verbosity - ( Verbosity, normal ) import System.FilePath ((), (<.>), isAbsolute) import System.Directory - ( getCurrentDirectory ) + ( getCurrentDirectory, removeDirectoryRecursive, removeFile + , doesDirectoryExist, doesFileExist ) +import Data.Version import Control.Monad (when) import Data.Maybe ( isJust, fromMaybe, maybeToList ) @@ -108,14 +92,16 @@ (registrationPackageDB absPackageDBs) when (fromFlag (regPrintId regFlags)) $ do - putStrLn (display (IPI.installedPackageId installedPkgInfo)) + putStrLn (display (IPI.installedUnitId installedPkgInfo)) -- Three different modes: case () of _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo | modeGenerateRegScript -> writeRegisterScript installedPkgInfo - | otherwise -> registerPackage verbosity - installedPkgInfo pkg lbi inplace packageDbs + | otherwise -> do + setupMessage verbosity "Registering" (packageId pkg) + registerPackage verbosity (compiler lbi) (withPrograms lbi) False + packageDbs installedPkgInfo where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) @@ -136,7 +122,7 @@ writeRegistrationFile installedPkgInfo = do notice verbosity ("Creating package registration file: " ++ regFile) - writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo) + writeUTF8File regFile (IPI.showInstalledPackageInfo installedPkgInfo) writeRegisterScript installedPkgInfo = case compilerFlavor (compiler lbi) of @@ -166,59 +152,80 @@ --TODO: eliminate pwd! pwd <- getCurrentDirectory - --TODO: the method of setting the InstalledPackageId is compiler specific + --TODO: the method of setting the UnitId is compiler specific -- this aspect should be delegated to a per-compiler helper. let comp = compiler lbi - ipid <- + abi_hash <- case compilerFlavor comp of GHC | compilerVersion comp >= Version [6,11] [] -> do - s <- GHC.libAbiHash verbosity pkg lbi lib clbi - return (InstalledPackageId (display (packageId pkg) ++ '-':s)) + fmap AbiHash $ GHC.libAbiHash verbosity pkg lbi lib clbi GHCJS -> do - s <- GHCJS.libAbiHash verbosity pkg lbi lib clbi - return (InstalledPackageId (display (packageId pkg) ++ '-':s)) - _other -> do - return (InstalledPackageId (display (packageId pkg))) + fmap AbiHash $ GHCJS.libAbiHash verbosity pkg lbi lib clbi + _ -> return (AbiHash "") installedPkgInfo <- if inplace then return (inplaceInstalledPackageInfo pwd distPref - pkg ipid lib lbi clbi) + pkg abi_hash lib lbi clbi) else if reloc then relocRegistrationInfo verbosity - pkg lib lbi clbi ipid packageDb + pkg lib lbi clbi abi_hash packageDb else return (absoluteInstalledPackageInfo - pkg ipid lib lbi clbi) + pkg abi_hash lib lbi clbi) - return installedPkgInfo{ IPI.installedPackageId = ipid } + return installedPkgInfo{ IPI.abiHash = abi_hash } relocRegistrationInfo :: Verbosity -> PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo - -> InstalledPackageId + -> AbiHash -> PackageDB -> IO InstalledPackageInfo -relocRegistrationInfo verbosity pkg lib lbi clbi ipid packageDb = +relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb = case (compilerFlavor (compiler lbi)) of GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb return (relocatableInstalledPackageInfo - pkg ipid lib lbi clbi fs) + pkg abi_hash lib lbi clbi fs) _ -> die "Distribution.Simple.Register.relocRegistrationInfo: \ \not implemented for this compiler" +initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath -> IO () +initPackageDB verbosity comp progdb dbPath = + createPackageDB verbosity comp progdb False dbPath + -- | Create an empty package DB at the specified location. -initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath - -> IO () -initPackageDB verbosity comp conf dbPath = - case compilerFlavor comp of - HaskellSuite {} -> HaskellSuite.initPackageDB verbosity conf dbPath - _ -> withHcPkg "Distribution.Simple.Register.initPackageDB: \ - \not implemented for this compiler" comp conf - (\hpi -> HcPkg.init hpi verbosity dbPath) +createPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> Bool + -> FilePath -> IO () +createPackageDB verbosity comp progdb preferCompat dbPath = + case compilerFlavor comp of + GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath + GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath + LHC -> HcPkg.init (LHC.hcPkgInfo progdb) verbosity False dbPath + UHC -> return () + HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath + _ -> die $ "Distribution.Simple.Register.createPackageDB: " + ++ "not implemented for this compiler" +doesPackageDBExist :: FilePath -> IO Bool +doesPackageDBExist dbPath = do + -- currently one impl for all compiler flavours, but could change if needed + dir_exists <- doesDirectoryExist dbPath + if dir_exists + then return True + else doesFileExist dbPath + +deletePackageDB :: FilePath -> IO () +deletePackageDB dbPath = do + -- currently one impl for all compiler flavours, but could change if needed + dir_exists <- doesDirectoryExist dbPath + if dir_exists + then removeDirectoryRecursive dbPath + else do file_exists <- doesFileExist dbPath + when file_exists $ removeFile dbPath + -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. invokeHcPkg :: Verbosity -> Compiler -> ProgramConfiguration -> PackageDBStack @@ -228,7 +235,7 @@ (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs) withHcPkg :: String -> Compiler -> ProgramConfiguration - -> (HcPkgInfo -> IO a) -> IO a + -> (HcPkg.HcPkgInfo -> IO a) -> IO a withHcPkg name comp conf f = case compilerFlavor comp of GHC -> f (GHC.hcPkgInfo conf) @@ -238,31 +245,29 @@ \not implemented for this compiler") registerPackage :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo + -> Compiler + -> ProgramConfiguration -> Bool -> PackageDBStack + -> InstalledPackageInfo -> IO () -registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do - let msg = if inplace - then "In-place registering" - else "Registering" - setupMessage verbosity msg (packageId pkg) - case compilerFlavor (compiler lbi) of - GHC -> GHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs - GHCJS -> GHCJS.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs - LHC -> LHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs - UHC -> UHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs +registerPackage verbosity comp progdb multiInstance packageDbs installedPkgInfo = + case compilerFlavor comp of + GHC -> GHC.registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo + GHCJS -> GHCJS.registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo + _ | multiInstance + -> die "Registering multiple package instances is not yet supported for this compiler" + LHC -> LHC.registerPackage verbosity progdb packageDbs installedPkgInfo + UHC -> UHC.registerPackage verbosity comp progdb packageDbs installedPkgInfo JHC -> notice verbosity "Registering for jhc (nothing to do)" HaskellSuite {} -> - HaskellSuite.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo _ -> die "Registering is not implemented for this compiler" writeHcPkgRegisterScript :: Verbosity -> InstalledPackageInfo -> PackageDBStack - -> HcPkgInfo + -> HcPkg.HcPkgInfo -> IO () writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs hpi = do let invocation = HcPkg.reregisterInvocation hpi Verbosity.normal @@ -289,17 +294,17 @@ :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to -- absolute paths. -> PackageDescription - -> InstalledPackageId + -> AbiHash -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo -> InstallDirs FilePath -> InstalledPackageInfo -generalInstalledPackageInfo adjustRelIncDirs pkg ipid lib lbi clbi installDirs = - InstalledPackageInfo { - IPI.installedPackageId = ipid, +generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDirs = + IPI.InstalledPackageInfo { IPI.sourcePackageId = packageId pkg, - IPI.packageKey = pkgKey lbi, + IPI.installedUnitId = componentUnitId clbi, + IPI.compatPackageKey = componentCompatPackageKey clbi, IPI.license = license pkg, IPI.copyright = copyright pkg, IPI.maintainer = maintainer pkg, @@ -310,12 +315,10 @@ IPI.synopsis = synopsis pkg, IPI.description = description pkg, IPI.category = category pkg, + IPI.abiHash = abi_hash, IPI.exposed = libExposed lib, - IPI.exposedModules = map fixupSelf (componentExposedModules clbi), + IPI.exposedModules = componentExposedModules clbi, IPI.hiddenModules = otherModules bi, - IPI.instantiatedWith = map (\(k,(p,n)) -> - (k,IPI.OriginalModule (IPI.installedPackageId p) n)) - (instantiatedWith lbi), IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo, IPI.importDirs = [ libdir installDirs | hasModules ], -- Note. the libsubdir and datasubdir templates have already been expanded @@ -324,9 +327,9 @@ then libdir installDirs : extraLibDirs bi else extraLibDirs bi, IPI.dataDir = datadir installDirs, - IPI.hsLibraries = [ libname - | LibraryName libname <- componentLibraries clbi - , hasLibrary ], + IPI.hsLibraries = if hasLibrary + then [getHSLibraryName (componentUnitId clbi)] + else [], IPI.extraLibraries = extraLibs bi, IPI.extraGHCiLibraries = extraGHCiLibs bi, IPI.includeDirs = absinc ++ adjustRelIncDirs relinc, @@ -336,8 +339,8 @@ -- We don't want cc-options to be propagated -- to C compilations in other packages. IPI.ldOptions = ldOptions bi, - IPI.frameworkDirs = [], IPI.frameworks = frameworks bi, + IPI.frameworkDirs = extraFrameworkDirs bi, IPI.haddockInterfaces = [haddockdir installDirs haddockName pkg], IPI.haddockHTMLs = [htmldir installDirs], IPI.pkgRoot = Nothing @@ -350,18 +353,6 @@ || (not (null (jsSources bi)) && compilerFlavor (compiler lbi) == GHCJS) - -- Since we currently don't decide the InstalledPackageId of our package - -- until just before we register, we didn't have one for the re-exports - -- of modules defined within this package, so we used an empty one that - -- we fill in here now that we know what it is. It's a bit of a hack, - -- we ought really to decide the InstalledPackageId ahead of time. - fixupSelf (IPI.ExposedModule n o o') = - IPI.ExposedModule n (fmap fixupOriginalModule o) - (fmap fixupOriginalModule o') - fixupOriginalModule (IPI.OriginalModule i m) = IPI.OriginalModule (fixupIpid i) m - fixupIpid (InstalledPackageId []) = ipid - fixupIpid x = x - -- | Construct 'InstalledPackageInfo' for a library that is in place in the -- build tree. -- @@ -370,19 +361,22 @@ inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree -> FilePath -- ^ location of the dist tree -> PackageDescription - -> InstalledPackageId + -> AbiHash -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo -> InstalledPackageInfo -inplaceInstalledPackageInfo inplaceDir distPref pkg ipid lib lbi clbi = +inplaceInstalledPackageInfo inplaceDir distPref pkg abi_hash lib lbi clbi = generalInstalledPackageInfo adjustRelativeIncludeDirs - pkg ipid lib lbi clbi installDirs + pkg abi_hash lib lbi clbi installDirs where adjustRelativeIncludeDirs = map (inplaceDir ) + libTargetDir + | componentUnitId clbi == localUnitId lbi = buildDir lbi + | otherwise = buildDir lbi display (componentUnitId clbi) installDirs = (absoluteInstallDirs pkg lbi NoCopyDest) { - libdir = inplaceDir buildDir lbi, + libdir = inplaceDir libTargetDir, datadir = inplaceDir dataDir pkg, docdir = inplaceDocdir, htmldir = inplaceHtmldir, @@ -398,14 +392,14 @@ -- This function knows about the layout of installed packages. -- absoluteInstalledPackageInfo :: PackageDescription - -> InstalledPackageId + -> AbiHash -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo -> InstalledPackageInfo -absoluteInstalledPackageInfo pkg ipid lib lbi clbi = +absoluteInstalledPackageInfo pkg abi_hash lib lbi clbi = generalInstalledPackageInfo adjustReativeIncludeDirs - pkg ipid lib lbi clbi installDirs + pkg abi_hash lib lbi clbi installDirs where -- For installed packages we install all include files into one dir, -- whereas in the build tree they may live in multiple local dirs. @@ -417,15 +411,15 @@ relocatableInstalledPackageInfo :: PackageDescription - -> InstalledPackageId + -> AbiHash -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath -> InstalledPackageInfo -relocatableInstalledPackageInfo pkg ipid lib lbi clbi pkgroot = +relocatableInstalledPackageInfo pkg abi_hash lib lbi clbi pkgroot = generalInstalledPackageInfo adjustReativeIncludeDirs - pkg ipid lib lbi clbi installDirs + pkg abi_hash lib lbi clbi installDirs where -- For installed packages we install all include files into one dir, -- whereas in the build tree they may live in multiple local dirs. diff --git a/Distribution/Simple/Setup.hs b/Distribution/Simple/Setup.hs --- a/Distribution/Simple/Setup.hs +++ b/Distribution/Simple/Setup.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- @@ -30,12 +30,12 @@ -- read and written from files. This would allow us to save configure flags in -- config files. -{-# LANGUAGE CPP #-} - module Distribution.Simple.Setup ( GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, + configPrograms, + AllowNewer(..), AllowNewerDep(..), isAllowNewer, configAbsolutePaths, readPackageDbList, showPackageDbList, CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, @@ -56,8 +56,9 @@ configureArgs, configureOptions, configureCCompiler, configureLinker, buildOptions, haddockOptions, installDirsOptions, programConfigurationOptions, programConfigurationPaths', + splitArgs, - defaultDistPref, + defaultDistPref, optionDistPref, Flag(..), toFlag, @@ -65,50 +66,34 @@ fromFlagOrDefault, flagToMaybe, flagToList, - boolOpt, boolOpt', trueArg, falseArg, optionVerbosity, optionNumJobs ) where + boolOpt, boolOpt', trueArg, falseArg, + optionVerbosity, optionNumJobs, readPToMaybe ) where -import Distribution.Compiler () +import Distribution.Compiler import Distribution.ReadE import Distribution.Text - ( Text(..), display ) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp -import Distribution.ModuleName -import Distribution.Package ( Dependency(..) - , PackageName - , InstalledPackageId ) -import Distribution.PackageDescription - ( FlagName(..), FlagAssignment ) +import Distribution.Package +import Distribution.PackageDescription hiding (Flag) import Distribution.Simple.Command hiding (boolOpt, boolOpt') import qualified Distribution.Simple.Command as Command -import Distribution.Simple.Compiler - ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..) - , DebugInfoLevel(..), flagToDebugInfoLevel - , OptimisationLevel(..), flagToOptimisationLevel - , absolutePackageDBPath ) +import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.Utils - ( wrapText, wrapLine, lowercase, intercalate ) -import Distribution.Simple.Program (Program(..), ProgramConfiguration, - requireProgram, - programInvocation, progInvokePath, progInvokeArgs, - knownPrograms, - addKnownProgram, emptyProgramConfiguration, - haddockProgram, ghcProgram, gccProgram, ldProgram) +import Distribution.Simple.Program import Distribution.Simple.InstallDirs - ( InstallDirs(..), CopyDest(..), - PathTemplate, toPathTemplate, fromPathTemplate ) import Distribution.Verbosity import Distribution.Utils.NubList - -import Control.Monad (liftM) import Distribution.Compat.Binary (Binary) -import Data.List ( sort ) -import Data.Char ( isSpace, isAlpha ) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid ( Monoid(..) ) -#endif -import GHC.Generics (Generic) +import Distribution.Compat.Semigroup as Semi +import Control.Applicative as A ( Applicative(..), (<*) ) +import Control.Monad ( liftM ) +import Data.List ( sort ) +import Data.Maybe ( listToMaybe ) +import Data.Char ( isSpace, isAlpha ) +import GHC.Generics ( Generic ) + -- FIXME Not sure where this should live defaultDistPref :: FilePath defaultDistPref = "dist" @@ -144,9 +129,12 @@ instance Monoid (Flag a) where mempty = NoFlag - _ `mappend` f@(Flag _) = f - f `mappend` NoFlag = f + mappend = (Semi.<>) +instance Semigroup (Flag a) where + _ <> f@(Flag _) = f + f <> NoFlag = f + instance Bounded a => Bounded (Flag a) where minBound = toFlag minBound maxBound = toFlag maxBound @@ -201,7 +189,7 @@ data GlobalFlags = GlobalFlags { globalVersion :: Flag Bool, globalNumericVersion :: Flag Bool - } + } deriving (Generic) defaultGlobalFlags :: GlobalFlags defaultGlobalFlags = GlobalFlags { @@ -226,8 +214,8 @@ align str = str ++ replicate (maxlen - length str) ' ' in "Commands:\n" - ++ unlines [ " " ++ align name ++ " " ++ description - | (name, description) <- cmdDescs ] + ++ unlines [ " " ++ align name ++ " " ++ descr + | (name, descr) <- cmdDescs ] ++ "\n" ++ "For more information about a command use\n" ++ " " ++ pname ++ " COMMAND --help\n\n" @@ -252,20 +240,78 @@ emptyGlobalFlags = mempty instance Monoid GlobalFlags where - mempty = GlobalFlags { - globalVersion = mempty, - globalNumericVersion = mempty - } - mappend a b = GlobalFlags { - globalVersion = combine globalVersion, - globalNumericVersion = combine globalNumericVersion - } - where combine field = field a `mappend` field b + mempty = gmempty + mappend = (Semi.<>) +instance Semigroup GlobalFlags where + (<>) = gmappend + -- ------------------------------------------------------------ -- * Config flags -- ------------------------------------------------------------ +-- | Policy for relaxing upper bounds in dependencies. For example, given +-- 'build-depends: array >= 0.3 && < 0.5', are we allowed to relax the upper +-- bound and choose a version of 'array' that is greater or equal to 0.5? By +-- default the upper bounds are always strictly honored. +data AllowNewer = + + -- | Default: honor the upper bounds in all dependencies, never choose + -- versions newer than allowed. + AllowNewerNone + + -- | Ignore upper bounds in dependencies on the given packages. + | AllowNewerSome [AllowNewerDep] + + -- | Ignore upper bounds in dependencies on all packages. + | AllowNewerAll + deriving (Eq, Read, Show, Generic) + +-- | Dependencies can be relaxed either for all packages in the install plan, or +-- only for some packages. +data AllowNewerDep = AllowNewerDep PackageName + | AllowNewerDepScoped PackageName PackageName + deriving (Eq, Read, Show, Generic) + +instance Text AllowNewerDep where + disp (AllowNewerDep p0) = disp p0 + disp (AllowNewerDepScoped p0 p1) = disp p0 Disp.<> Disp.colon Disp.<> disp p1 + + parse = scopedP Parse.<++ normalP + where + scopedP = AllowNewerDepScoped `fmap` parse A.<* Parse.char ':' A.<*> parse + normalP = AllowNewerDep `fmap` parse + +instance Binary AllowNewer +instance Binary AllowNewerDep + +instance Semigroup AllowNewer where + AllowNewerNone <> r = r + l@AllowNewerAll <> _ = l + l@(AllowNewerSome _) <> AllowNewerNone = l + (AllowNewerSome _) <> r@AllowNewerAll = r + (AllowNewerSome a) <> (AllowNewerSome b) = AllowNewerSome (a ++ b) + +instance Monoid AllowNewer where + mempty = AllowNewerNone + mappend = (Semi.<>) + +-- | Convert 'AllowNewer' to a boolean. +isAllowNewer :: AllowNewer -> Bool +isAllowNewer AllowNewerNone = False +isAllowNewer (AllowNewerSome _) = True +isAllowNewer AllowNewerAll = True + +allowNewerParser :: Parse.ReadP r (Maybe AllowNewer) +allowNewerParser = + (Just . AllowNewerSome) `fmap` Parse.sepBy1 parse (Parse.char ',') + +allowNewerPrinter :: (Maybe AllowNewer) -> [Maybe String] +allowNewerPrinter Nothing = [] +allowNewerPrinter (Just AllowNewerNone) = [] +allowNewerPrinter (Just AllowNewerAll) = [Nothing] +allowNewerPrinter (Just (AllowNewerSome pkgs)) = map (Just . display) $ pkgs + -- | Flags to @configure@ command. -- -- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags' @@ -275,8 +321,8 @@ -- 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_ :: Last' ProgramConfiguration, -- ^All programs that + -- @cabal@ may run configProgramPaths :: [(String, FilePath)], -- ^user specified programs paths configProgramArgs :: [(String, [String])], -- ^user specified programs args @@ -293,6 +339,12 @@ -- executables. configProfExe :: Flag Bool, -- ^Enable profiling in the -- executables. + configProf :: Flag Bool, -- ^Enable profiling in the library + -- and executables. + configProfDetail :: Flag ProfDetailLevel, -- ^Profiling detail level + -- in the library and executables. + configProfLibDetail :: Flag ProfDetailLevel, -- ^Profiling detail level + -- in the library configConfigureArgs :: [String], -- ^Extra arguments to @configure@ configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix. @@ -301,7 +353,10 @@ -- paths configScratchDir :: Flag FilePath, configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries + configExtraFrameworkDirs :: [FilePath], -- ^ path to search for extra + -- frameworks (OS X only) configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files + configIPID :: Flag String, -- ^ explicit IPID to be used configDistPref :: Flag FilePath, -- ^"dist" prefix configVerbosity :: Flag Verbosity, -- ^verbosity level @@ -313,8 +368,7 @@ configStripLibs :: Flag Bool, -- ^Enable library stripping configConstraints :: [Dependency], -- ^Additional constraints for -- dependencies. - configDependencies :: [(PackageName, InstalledPackageId)], - configInstantiateWith :: [(ModuleName, (InstalledPackageId, ModuleName))], + configDependencies :: [(PackageName, UnitId)], -- ^The packages depended on. configConfigurationsFlags :: FlagAssignment, configTests :: Flag Bool, -- ^Enable test suite compilation @@ -327,12 +381,20 @@ configFlagError :: Flag String, -- ^Halt and show an error message indicating an error in flag assignment configRelocatable :: Flag Bool, -- ^ Enable relocatable package built - configDebugInfo :: Flag DebugInfoLevel -- ^ Emit debug info. + configDebugInfo :: Flag DebugInfoLevel, -- ^ Emit debug info. + configAllowNewer :: Maybe AllowNewer + -- ^ Ignore upper bounds on all or some dependencies. Wrapped in 'Maybe' to + -- distinguish between "default" and "explicitly disabled". } deriving (Generic, Read, Show) instance Binary ConfigFlags +-- | More convenient version of 'configPrograms'. Results in an +-- 'error' if internal invariant is violated. +configPrograms :: ConfigFlags -> ProgramConfiguration +configPrograms = maybe (error "FIXME: remove configPrograms") id . getLast' . configPrograms_ + configAbsolutePaths :: ConfigFlags -> IO ConfigFlags configAbsolutePaths f = (\v -> f { configPackageDBs = v }) @@ -341,17 +403,20 @@ defaultConfigFlags :: ProgramConfiguration -> ConfigFlags defaultConfigFlags progConf = emptyConfigFlags { - configPrograms = progConf, + configPrograms_ = pure progConf, configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, configVanillaLib = Flag True, configProfLib = NoFlag, configSharedLib = NoFlag, configDynExe = Flag False, configProfExe = NoFlag, + configProf = NoFlag, + configProfDetail = NoFlag, + configProfLibDetail= NoFlag, configOptimization = Flag NormalOptimisation, configProgPrefix = Flag (toPathTemplate ""), configProgSuffix = Flag (toPathTemplate ""), - configDistPref = Flag defaultDistPref, + configDistPref = NoFlag, configVerbosity = Flag normal, configUserInstall = Flag False, --TODO: reverse this #if defined(mingw32_HOST_OS) @@ -370,7 +435,8 @@ configExactConfiguration = Flag False, configFlagError = NoFlag, configRelocatable = Flag False, - configDebugInfo = Flag NoDebugInfo + configDebugInfo = Flag NoDebugInfo, + configAllowNewer = Nothing } configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags @@ -383,7 +449,7 @@ ++ "\n" ++ "The configuration affects several other commands, " ++ "including build, test, bench, run, repl.\n" - , commandNotes = Just (\_ -> programFlagsDescription progConf) + , commandNotes = Just $ \_pname -> programFlagsDescription progConf , commandUsage = \pname -> "Usage: " ++ pname ++ " configure [FLAGS]\n" , commandDefaultFlags = defaultConfigFlags progConf @@ -460,19 +526,8 @@ (boolOpt [] []) ,option "" ["profiling"] - "Executable profiling (requires library profiling)" - -- HACK: See #2409. Thankfully, this is 1.22-specific. - (\flags -> - case (configProfLib flags, configProfExe flags) of - (Flag a, Flag b) - | (a == b) - && ("cabalConfProf", "/TRUE") `elem` configProgramPaths flags - -> configProfExe flags - _ -> NoFlag) - (\v flags -> flags - { configProfLib = v, configProfExe = v - , configProgramPaths = ("cabalConfProf", "/TRUE") - : configProgramPaths flags }) + "Executable and library profiling" + configProf (\v flags -> flags { configProf = v }) (boolOpt [] []) ,option "" ["executable-profiling"] @@ -480,6 +535,19 @@ configProfExe (\v flags -> flags { configProfExe = v }) (boolOpt [] []) + ,option "" ["profiling-detail"] + ("Profiling detail level for executable and library (default, " ++ + "none, exported-functions, toplevel-functions, all-functions).") + configProfDetail (\v flags -> flags { configProfDetail = v }) + (reqArg' "level" (Flag . flagToProfDetailLevel) + showProfDetailLevelFlag) + + ,option "" ["library-profiling-detail"] + "Profiling detail level for libraries only." + configProfLibDetail (\v flags -> flags { configProfLibDetail = v }) + (reqArg' "level" (Flag . flagToProfDetailLevel) + showProfDetailLevelFlag) + ,multiOption "optimization" configOptimization (\v flags -> flags { configOptimization = v }) [optArg' "n" (Flag . flagToOptimisationLevel) @@ -542,7 +610,12 @@ (boolOpt' ([],["user"]) ([], ["global"])) ,option "" ["package-db"] - "Use a given package database (to satisfy dependencies and register in). May be a specific file, 'global', 'user' or 'clear'." + ( "Append the given package database to the list of package" + ++ " databases used (to satisfy dependencies and register into)." + ++ " May be a specific file, 'global' or 'user'. The initial list" + ++ " is ['global'], ['global', 'user'], or ['global', $sandbox]," + ++ " depending on context. Use 'clear' to reset the list to empty." + ++ " See the user guide for details.") configPackageDBs (\v flags -> flags { configPackageDBs = v }) (reqArg' "DB" readPackageDbList showPackageDbList) @@ -556,11 +629,22 @@ configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) (reqArg' "PATH" (\x -> [x]) id) + ,option "" ["ipid"] + "Installed package ID to compile this package as" + configIPID (\v flags -> flags {configIPID = v}) + (reqArgFlag "IPID") + ,option "" ["extra-lib-dirs"] "A list of directories to search for external libraries" configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) (reqArg' "PATH" (\x -> [x]) id) + ,option "" ["extra-framework-dirs"] + "A list of directories to search for external frameworks (OS X only)" + configExtraFrameworkDirs + (\v flags -> flags {configExtraFrameworkDirs = 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}) @@ -580,13 +664,6 @@ (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parseDependency)) (map (\x -> display (fst x) ++ "=" ++ display (snd x)))) - ,option "" ["instantiate-with"] - "A mapping of signature names to concrete module instantiations. E.g., --instantiate-with=\"Map=Data.Map.Strict@containers-0.5.5.1-inplace\"" - configInstantiateWith (\v flags -> flags { configInstantiateWith = v }) - (reqArg "NAME=PKG:MOD" - (readP_to_E (const "signature mapping expected") ((\x -> [x]) `fmap` parseHoleMapEntry)) - (map (\(n,(p,m)) -> display n ++ "=" ++ display m ++ "@" ++ display p))) - ,option "" ["tests"] "dependency checking and compilation for test suites listed in the package description file." configTests (\v flags -> flags { configTests = v }) @@ -602,6 +679,13 @@ configLibCoverage (\v flags -> flags { configLibCoverage = v }) (boolOpt [] []) + ,option [] ["allow-newer"] + ("Ignore upper bounds in all dependencies or DEPS") + configAllowNewer (\v flags -> flags { configAllowNewer = v}) + (optArg "DEPS" + (readP_to_E ("Cannot parse the list of packages: " ++) allowNewerParser) + (Just AllowNewerAll) allowNewerPrinter) + ,option "" ["exact-configuration"] "All direct dependencies and flags are provided on the command line." configExactConfiguration @@ -649,23 +733,17 @@ showPackageDb (Just UserPackageDB) = "user" showPackageDb (Just (SpecificPackageDB db)) = db +showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String] +showProfDetailLevelFlag NoFlag = [] +showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] -parseDependency :: Parse.ReadP r (PackageName, InstalledPackageId) +parseDependency :: Parse.ReadP r (PackageName, UnitId) parseDependency = do x <- parse _ <- Parse.char '=' y <- parse return (x, y) -parseHoleMapEntry :: Parse.ReadP r (ModuleName, (InstalledPackageId, ModuleName)) -parseHoleMapEntry = do - x <- parse - _ <- Parse.char '=' - y <- parse - _ <- Parse.char '@' - z <- parse - return (x, (z, y)) - installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] installDirsOptions = [ option "" ["prefix"] @@ -732,92 +810,12 @@ emptyConfigFlags = mempty instance Monoid ConfigFlags where - mempty = ConfigFlags { - configPrograms = error "FIXME: remove configPrograms", - configProgramPaths = mempty, - configProgramArgs = mempty, - configProgramPathExtra = mempty, - configHcFlavor = mempty, - configHcPath = mempty, - configHcPkg = mempty, - configVanillaLib = mempty, - configProfLib = mempty, - configSharedLib = mempty, - configDynExe = mempty, - configProfExe = mempty, - configConfigureArgs = mempty, - configOptimization = mempty, - configProgPrefix = mempty, - configProgSuffix = mempty, - configInstallDirs = mempty, - configScratchDir = mempty, - configDistPref = mempty, - configVerbosity = mempty, - configUserInstall = mempty, - configPackageDBs = mempty, - configGHCiLib = mempty, - configSplitObjs = mempty, - configStripExes = mempty, - configStripLibs = mempty, - configExtraLibDirs = mempty, - configConstraints = mempty, - configDependencies = mempty, - configInstantiateWith = mempty, - configExtraIncludeDirs = mempty, - configConfigurationsFlags = mempty, - configTests = mempty, - configCoverage = mempty, - configLibCoverage = mempty, - configExactConfiguration = mempty, - configBenchmarks = mempty, - configFlagError = mempty, - configRelocatable = mempty, - configDebugInfo = mempty - } - mappend a b = ConfigFlags { - configPrograms = configPrograms b, - configProgramPaths = combine configProgramPaths, - configProgramArgs = combine configProgramArgs, - configProgramPathExtra = combine configProgramPathExtra, - configHcFlavor = combine configHcFlavor, - configHcPath = combine configHcPath, - configHcPkg = combine configHcPkg, - configVanillaLib = combine configVanillaLib, - configProfLib = combine configProfLib, - configSharedLib = combine configSharedLib, - configDynExe = combine configDynExe, - configProfExe = combine configProfExe, - configConfigureArgs = combine configConfigureArgs, - configOptimization = combine configOptimization, - configProgPrefix = combine configProgPrefix, - configProgSuffix = combine configProgSuffix, - configInstallDirs = combine configInstallDirs, - configScratchDir = combine configScratchDir, - configDistPref = combine configDistPref, - configVerbosity = combine configVerbosity, - configUserInstall = combine configUserInstall, - configPackageDBs = combine configPackageDBs, - configGHCiLib = combine configGHCiLib, - configSplitObjs = combine configSplitObjs, - configStripExes = combine configStripExes, - configStripLibs = combine configStripLibs, - configExtraLibDirs = combine configExtraLibDirs, - configConstraints = combine configConstraints, - configDependencies = combine configDependencies, - configInstantiateWith = combine configInstantiateWith, - configExtraIncludeDirs = combine configExtraIncludeDirs, - configConfigurationsFlags = combine configConfigurationsFlags, - configTests = combine configTests, - configCoverage = combine configCoverage, - configLibCoverage = combine configLibCoverage, - configExactConfiguration = combine configExactConfiguration, - configBenchmarks = combine configBenchmarks, - configFlagError = combine configFlagError, - configRelocatable = combine configRelocatable, - configDebugInfo = combine configDebugInfo - } - where combine field = field a `mappend` field b + mempty = gmempty + mappend = (Semi.<>) +instance Semigroup ConfigFlags where + (<>) = gmappend + -- ------------------------------------------------------------ -- * Copy flags -- ------------------------------------------------------------ @@ -828,12 +826,12 @@ copyDistPref :: Flag FilePath, copyVerbosity :: Flag Verbosity } - deriving Show + deriving (Show, Generic) defaultCopyFlags :: CopyFlags defaultCopyFlags = CopyFlags { copyDest = Flag NoCopyDest, - copyDistPref = Flag defaultDistPref, + copyDistPref = NoFlag, copyVerbosity = Flag normal } @@ -867,18 +865,12 @@ emptyCopyFlags = mempty instance Monoid CopyFlags where - mempty = CopyFlags { - copyDest = mempty, - copyDistPref = mempty, - copyVerbosity = mempty - } - mappend a b = CopyFlags { - copyDest = combine copyDest, - copyDistPref = combine copyDistPref, - copyVerbosity = combine copyVerbosity - } - where combine field = field a `mappend` field b + mempty = gmempty + mappend = (Semi.<>) +instance Semigroup CopyFlags where + (<>) = gmappend + -- ------------------------------------------------------------ -- * Install flags -- ------------------------------------------------------------ @@ -891,12 +883,12 @@ installInPlace :: Flag Bool, installVerbosity :: Flag Verbosity } - deriving Show + deriving (Show, Generic) defaultInstallFlags :: InstallFlags defaultInstallFlags = InstallFlags { installPackageDB = NoFlag, - installDistPref = Flag defaultDistPref, + installDistPref = NoFlag, installUseWrapper = Flag False, installInPlace = Flag False, installVerbosity = Flag normal @@ -944,22 +936,12 @@ emptyInstallFlags = mempty instance Monoid InstallFlags where - mempty = InstallFlags{ - installPackageDB = mempty, - installDistPref = mempty, - installUseWrapper = mempty, - installInPlace = mempty, - installVerbosity = mempty - } - mappend a b = InstallFlags{ - installPackageDB = combine installPackageDB, - installDistPref = combine installDistPref, - installUseWrapper = combine installUseWrapper, - installInPlace = combine installInPlace, - installVerbosity = combine installVerbosity - } - where combine field = field a `mappend` field b + mempty = gmempty + mappend = (Semi.<>) +instance Semigroup InstallFlags where + (<>) = gmappend + -- ------------------------------------------------------------ -- * SDist flags -- ------------------------------------------------------------ @@ -972,13 +954,13 @@ sDistListSources :: Flag FilePath, sDistVerbosity :: Flag Verbosity } - deriving Show + deriving (Show, Generic) defaultSDistFlags :: SDistFlags defaultSDistFlags = SDistFlags { sDistSnapshot = Flag False, sDistDirectory = mempty, - sDistDistPref = Flag defaultDistPref, + sDistDistPref = NoFlag, sDistListSources = mempty, sDistVerbosity = Flag normal } @@ -1021,22 +1003,12 @@ emptySDistFlags = mempty instance Monoid SDistFlags where - mempty = SDistFlags { - sDistSnapshot = mempty, - sDistDirectory = mempty, - sDistDistPref = mempty, - sDistListSources = mempty, - sDistVerbosity = mempty - } - mappend a b = SDistFlags { - sDistSnapshot = combine sDistSnapshot, - sDistDirectory = combine sDistDirectory, - sDistDistPref = combine sDistDistPref, - sDistListSources = combine sDistListSources, - sDistVerbosity = combine sDistVerbosity - } - where combine field = field a `mappend` field b + mempty = gmempty + mappend = (Semi.<>) +instance Semigroup SDistFlags where + (<>) = gmappend + -- ------------------------------------------------------------ -- * Register flags -- ------------------------------------------------------------ @@ -1052,7 +1024,7 @@ regPrintId :: Flag Bool, regVerbosity :: Flag Verbosity } - deriving Show + deriving (Show, Generic) defaultRegisterFlags :: RegisterFlags defaultRegisterFlags = RegisterFlags { @@ -1060,7 +1032,7 @@ regGenScript = Flag False, regGenPkgConf = NoFlag, regInPlace = Flag False, - regDistPref = Flag defaultDistPref, + regDistPref = NoFlag, regPrintId = Flag False, regVerbosity = Flag normal } @@ -1144,26 +1116,12 @@ emptyRegisterFlags = mempty instance Monoid RegisterFlags where - mempty = RegisterFlags { - regPackageDB = mempty, - regGenScript = mempty, - regGenPkgConf = mempty, - regInPlace = mempty, - regPrintId = mempty, - regDistPref = mempty, - regVerbosity = mempty - } - mappend a b = RegisterFlags { - regPackageDB = combine regPackageDB, - regGenScript = combine regGenScript, - regGenPkgConf = combine regGenPkgConf, - regInPlace = combine regInPlace, - regPrintId = combine regPrintId, - regDistPref = combine regDistPref, - regVerbosity = combine regVerbosity - } - where combine field = field a `mappend` field b + mempty = gmempty + mappend = (Semi.<>) +instance Semigroup RegisterFlags where + (<>) = gmappend + -- ------------------------------------------------------------ -- * HsColour flags -- ------------------------------------------------------------ @@ -1176,7 +1134,7 @@ hscolourDistPref :: Flag FilePath, hscolourVerbosity :: Flag Verbosity } - deriving Show + deriving (Show, Generic) emptyHscolourFlags :: HscolourFlags emptyHscolourFlags = mempty @@ -1187,29 +1145,17 @@ hscolourExecutables = Flag False, hscolourTestSuites = Flag False, hscolourBenchmarks = Flag False, - hscolourDistPref = Flag defaultDistPref, + hscolourDistPref = NoFlag, hscolourVerbosity = Flag normal } instance Monoid HscolourFlags where - 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 + mempty = gmempty + mappend = (Semi.<>) +instance Semigroup HscolourFlags where + (<>) = gmappend + hscolourCommand :: CommandUI HscolourFlags hscolourCommand = CommandUI { commandName = "hscolour" @@ -1269,6 +1215,7 @@ haddockHoogle :: Flag Bool, haddockHtml :: Flag Bool, haddockHtmlLocation :: Flag String, + haddockForHackage :: Flag Bool, haddockExecutables :: Flag Bool, haddockTestSuites :: Flag Bool, haddockBenchmarks :: Flag Bool, @@ -1281,7 +1228,7 @@ haddockKeepTempFiles:: Flag Bool, haddockVerbosity :: Flag Verbosity } - deriving Show + deriving (Show, Generic) defaultHaddockFlags :: HaddockFlags defaultHaddockFlags = HaddockFlags { @@ -1290,6 +1237,7 @@ haddockHoogle = Flag False, haddockHtml = Flag False, haddockHtmlLocation = NoFlag, + haddockForHackage = Flag False, haddockExecutables = Flag False, haddockTestSuites = Flag False, haddockBenchmarks = Flag False, @@ -1298,7 +1246,7 @@ haddockHscolour = Flag False, haddockHscolourCss = NoFlag, haddockContents = NoFlag, - haddockDistPref = Flag defaultDistPref, + haddockDistPref = NoFlag, haddockKeepTempFiles= Flag False, haddockVerbosity = Flag normal } @@ -1355,6 +1303,11 @@ haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v }) (reqArgFlag "URL") + ,option "" ["for-hackage"] + "Collection of flags to generate documentation suitable for upload to hackage" + haddockForHackage (\v flags -> flags { haddockForHackage = v }) + trueArg + ,option "" ["executables"] "Run haddock for Executables targets" haddockExecutables (\v flags -> flags { haddockExecutables = v }) @@ -1412,44 +1365,12 @@ emptyHaddockFlags = mempty instance Monoid HaddockFlags where - mempty = HaddockFlags { - haddockProgramPaths = mempty, - haddockProgramArgs = mempty, - haddockHoogle = mempty, - 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 { - haddockProgramPaths = combine haddockProgramPaths, - haddockProgramArgs = combine haddockProgramArgs, - haddockHoogle = combine haddockHoogle, - 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 + mempty = gmempty + mappend = (Semi.<>) +instance Semigroup HaddockFlags where + (<>) = gmappend + -- ------------------------------------------------------------ -- * Clean flags -- ------------------------------------------------------------ @@ -1459,12 +1380,12 @@ cleanDistPref :: Flag FilePath, cleanVerbosity :: Flag Verbosity } - deriving Show + deriving (Show, Generic) defaultCleanFlags :: CleanFlags defaultCleanFlags = CleanFlags { cleanSaveConf = Flag False, - cleanDistPref = Flag defaultDistPref, + cleanDistPref = NoFlag, cleanVerbosity = Flag normal } @@ -1495,18 +1416,12 @@ emptyCleanFlags = mempty instance Monoid CleanFlags where - mempty = CleanFlags { - cleanSaveConf = mempty, - cleanDistPref = mempty, - cleanVerbosity = mempty - } - mappend a b = CleanFlags { - cleanSaveConf = combine cleanSaveConf, - cleanDistPref = combine cleanDistPref, - cleanVerbosity = combine cleanVerbosity - } - where combine field = field a `mappend` field b + mempty = gmempty + mappend = (Semi.<>) +instance Semigroup CleanFlags where + (<>) = gmappend + -- ------------------------------------------------------------ -- * Build flags -- ------------------------------------------------------------ @@ -1521,7 +1436,7 @@ -- UserHooks stop us from passing extra info in other ways buildArgs :: [String] } - deriving Show + deriving (Show, Generic) {-# DEPRECATED buildVerbose "Use buildVerbosity instead" #-} buildVerbose :: BuildFlags -> Verbosity @@ -1531,7 +1446,7 @@ defaultBuildFlags = BuildFlags { buildProgramPaths = mempty, buildProgramArgs = [], - buildDistPref = Flag defaultDistPref, + buildDistPref = mempty, buildVerbosity = Flag normal, buildNumJobs = mempty, buildArgs = [] @@ -1596,24 +1511,12 @@ emptyBuildFlags = mempty instance Monoid BuildFlags where - mempty = BuildFlags { - buildProgramPaths = mempty, - buildProgramArgs = mempty, - buildVerbosity = mempty, - buildDistPref = mempty, - buildNumJobs = mempty, - buildArgs = mempty - } - mappend a b = BuildFlags { - buildProgramPaths = combine buildProgramPaths, - buildProgramArgs = combine buildProgramArgs, - buildVerbosity = combine buildVerbosity, - buildDistPref = combine buildDistPref, - buildNumJobs = combine buildNumJobs, - buildArgs = combine buildArgs - } - where combine field = field a `mappend` field b + mempty = gmempty + mappend = (Semi.<>) +instance Semigroup BuildFlags where + (<>) = gmappend + -- ------------------------------------------------------------ -- * REPL Flags -- ------------------------------------------------------------ @@ -1625,34 +1528,24 @@ replVerbosity :: Flag Verbosity, replReload :: Flag Bool } - deriving Show + deriving (Show, Generic) defaultReplFlags :: ReplFlags defaultReplFlags = ReplFlags { replProgramPaths = mempty, replProgramArgs = [], - replDistPref = Flag defaultDistPref, + replDistPref = NoFlag, 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 + mempty = gmempty + mappend = (Semi.<>) +instance Semigroup ReplFlags where + (<>) = gmappend + replCommand :: ProgramConfiguration -> CommandUI ReplFlags replCommand progConf = CommandUI { commandName = "repl" @@ -1725,7 +1618,7 @@ -- * Test flags -- ------------------------------------------------------------ -data TestShowDetails = Never | Failures | Always | Streaming +data TestShowDetails = Never | Failures | Always | Streaming | Direct deriving (Eq, Ord, Enum, Bounded, Show) knownTestShowDetails :: [TestShowDetails] @@ -1745,8 +1638,11 @@ --TODO: do we need this instance? instance Monoid TestShowDetails where mempty = Never - mappend a b = if a < b then b else a + mappend = (Semi.<>) +instance Semigroup TestShowDetails where + a <> b = if a < b then b else a + data TestFlags = TestFlags { testDistPref :: Flag FilePath, testVerbosity :: Flag Verbosity, @@ -1756,11 +1652,11 @@ testKeepTix :: Flag Bool, -- TODO: think about if/how options are passed to test exes testOptions :: [PathTemplate] - } + } deriving (Generic) defaultTestFlags :: TestFlags defaultTestFlags = TestFlags { - testDistPref = Flag defaultDistPref, + testDistPref = NoFlag, testVerbosity = Flag normal, testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log", testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log", @@ -1813,7 +1709,8 @@ ("'always': always show results of individual test cases. " ++ "'never': never show results of individual test cases. " ++ "'failures': show results of failing test cases. " - ++ "'streaming': show results of test cases in real time.") + ++ "'streaming': show results of test cases in real time." + ++ "'direct': send results of test cases in real time; no log file.") testShowDetails (\v flags -> flags { testShowDetails = v }) (reqArg "FILTER" (readP_to_E (\_ -> "--show-details flag expects one of " @@ -1847,26 +1744,12 @@ emptyTestFlags = mempty instance Monoid TestFlags where - mempty = TestFlags { - testDistPref = mempty, - testVerbosity = mempty, - testHumanLog = mempty, - testMachineLog = mempty, - testShowDetails = mempty, - testKeepTix = mempty, - testOptions = mempty - } - mappend a b = TestFlags { - testDistPref = combine testDistPref, - testVerbosity = combine testVerbosity, - testHumanLog = combine testHumanLog, - testMachineLog = combine testMachineLog, - testShowDetails = combine testShowDetails, - testKeepTix = combine testKeepTix, - testOptions = combine testOptions - } - where combine field = field a `mappend` field b + mempty = gmempty + mappend = (Semi.<>) +instance Semigroup TestFlags where + (<>) = gmappend + -- ------------------------------------------------------------ -- * Benchmark flags -- ------------------------------------------------------------ @@ -1875,11 +1758,11 @@ benchmarkDistPref :: Flag FilePath, benchmarkVerbosity :: Flag Verbosity, benchmarkOptions :: [PathTemplate] - } + } deriving (Generic) defaultBenchmarkFlags :: BenchmarkFlags defaultBenchmarkFlags = BenchmarkFlags { - benchmarkDistPref = Flag defaultDistPref, + benchmarkDistPref = NoFlag, benchmarkVerbosity = Flag normal, benchmarkOptions = [] } @@ -1934,18 +1817,12 @@ emptyBenchmarkFlags = mempty instance Monoid BenchmarkFlags where - mempty = BenchmarkFlags { - benchmarkDistPref = mempty, - benchmarkVerbosity = mempty, - benchmarkOptions = mempty - } - mappend a b = BenchmarkFlags { - benchmarkDistPref = combine benchmarkDistPref, - benchmarkVerbosity = combine benchmarkVerbosity, - benchmarkOptions = combine benchmarkOptions - } - where combine field = field a `mappend` field b + mempty = gmempty + mappend = (Semi.<>) +instance Semigroup BenchmarkFlags where + (<>) = gmappend + -- ------------------------------------------------------------ -- * Shared options utils -- ------------------------------------------------------------ @@ -2105,6 +1982,10 @@ -- ------------------------------------------------------------ -- * Other Utils -- ------------------------------------------------------------ + +readPToMaybe :: Parse.ReadP a a -> String -> Maybe a +readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str + , all isSpace s ] -- | Arguments to pass to a @configure@ script, e.g. generated by -- @autoconf@. diff --git a/Distribution/Simple/SrcDist.hs b/Distribution/Simple/SrcDist.hs --- a/Distribution/Simple/SrcDist.hs +++ b/Distribution/Simple/SrcDist.hs @@ -40,35 +40,20 @@ ) where -import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) - , TestSuite(..), TestSuiteInterface(..), Benchmark(..) - , BenchmarkInterface(..) ) -import Distribution.PackageDescription.Check - ( PackageCheck(..), checkConfiguredPackage, checkPackageFiles ) +import Distribution.PackageDescription hiding (Flag) +import Distribution.PackageDescription.Check hiding (doesFileExist) import Distribution.Package - ( PackageIdentifier(pkgVersion), Package(..), packageVersion ) -import Distribution.ModuleName (ModuleName) +import Distribution.ModuleName import qualified Distribution.ModuleName as ModuleName import Distribution.Version - ( Version(versionBranch) ) import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File - , installOrdinaryFiles, installMaybeExecutableFiles - , findFile, findFileWithExtension, matchFileGlob - , withTempDirectory, defaultPackageDesc - , die, warn, notice, info, setupMessage ) -import Distribution.Simple.Setup ( Flag(..), SDistFlags(..) - , fromFlag, flagToMaybe) -import Distribution.Simple.PreProcess ( PPSuffixHandler, ppSuffixes - , preprocessComponent ) +import Distribution.Simple.Setup +import Distribution.Simple.PreProcess import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), withAllComponentsInBuildOrder ) -import Distribution.Simple.BuildPaths ( autogenModuleName ) -import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram, - runProgram, programProperties, tarProgram ) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Program import Distribution.Text - ( display ) +import Distribution.Verbosity import Control.Monad(when, unless, forM) import Data.Char (toLower) @@ -78,7 +63,6 @@ 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 ( (), (<.>), dropExtension, isAbsolute ) @@ -169,19 +153,19 @@ fmap concat . sequence $ [ -- Library sources. - withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } -> + withAllLib $ \Library { exposedModules = modules, libBuildInfo = libBi } -> allSourcesBuildInfo libBi pps modules -- Executables sources. , fmap concat - . withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do + . withAllExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do biSrcs <- allSourcesBuildInfo exeBi pps [] mainSrc <- findMainExeFile exeBi pps mainPath return (mainSrc:biSrcs) -- Test suites sources. , fmap concat - . withTest $ \t -> do + . withAllTest $ \t -> do let bi = testBuildInfo t case testInterface t of TestSuiteExeV10 _ mainPath -> do @@ -200,7 +184,7 @@ -- Benchmarks sources. , fmap concat - . withBenchmark $ \bm -> do + . withAllBenchmark $ \bm -> do let bi = benchmarkBuildInfo bm case benchmarkInterface bm of BenchmarkExeV10 _ mainPath -> do @@ -229,7 +213,7 @@ , return (licenseFiles pkg_descr) -- Install-include files. - , withLib $ \ l -> do + , withAllLib $ \ l -> do let lbi = libBuildInfo l relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) mapM (fmap snd . findIncludeFile relincdirs) (installIncludes lbi) @@ -244,10 +228,10 @@ 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) + withAllLib action = maybe (return []) action (library pkg_descr) + withAllExe action = mapM action (executables pkg_descr) + withAllTest action = mapM action (testSuites pkg_descr) + withAllBenchmark action = mapM action (benchmarks pkg_descr) -- |Prepare a directory tree of source files. @@ -432,10 +416,10 @@ -> IO [FilePath] allSourcesBuildInfo bi pps modules = do let searchDirs = hsSourceDirs bi - sources <- sequence + sources <- fmap concat $ sequence $ [ let file = ModuleName.toFilePath module_ - in findFileWithExtension suffixes searchDirs file - >>= maybe (notFound module_) return + in findAllFilesWithExtension suffixes searchDirs file + >>= nonEmpty (notFound module_) return | module_ <- modules ++ otherModules bi ] bootFiles <- sequence [ let file = ModuleName.toFilePath module_ @@ -446,6 +430,8 @@ return $ sources ++ catMaybes bootFiles ++ cSources bi ++ jsSources bi where + nonEmpty x _ [] = x + nonEmpty _ f xs = f xs suffixes = ppSuffixes pps ++ ["hs", "lhs"] notFound m = die $ "Error: Could not find module: " ++ display m ++ " with any suffix: " ++ show suffixes @@ -455,8 +441,9 @@ printPackageProblems verbosity pkg_descr = do ioChecks <- checkPackageFiles pkg_descr "." let pureChecks = checkConfiguredPackage pkg_descr - isDistError (PackageDistSuspicious _) = False - isDistError _ = True + isDistError (PackageDistSuspicious _) = False + isDistError (PackageDistSuspiciousWarn _) = False + isDistError _ = True (errors, warnings) = partition isDistError (pureChecks ++ ioChecks) unless (null errors) $ notice verbosity $ "Distribution quality errors:\n" diff --git a/Distribution/Simple/Test.hs b/Distribution/Simple/Test.hs --- a/Distribution/Simple/Test.hs +++ b/Distribution/Simple/Test.hs @@ -16,23 +16,17 @@ ) where import qualified Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(buildable) - , TestSuite(..) - , TestSuiteInterface(..), testType, hasTests ) -import Distribution.Simple.Compiler ( compilerInfo ) -import Distribution.Simple.Hpc ( markupPackage ) +import Distribution.Simple.Compiler +import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs - ( fromPathTemplate, initialPathTemplateEnv, substPathTemplate - , PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI - ( LocalBuildInfo(..) ) -import Distribution.Simple.Setup ( TestFlags(..), fromFlag, configCoverage ) -import Distribution.Simple.UserHooks ( Args ) +import Distribution.Simple.Setup +import Distribution.Simple.UserHooks import qualified Distribution.Simple.Test.ExeV10 as ExeV10 import qualified Distribution.Simple.Test.LibV09 as LibV09 import Distribution.Simple.Test.Log -import Distribution.Simple.Utils ( die, notice ) -import Distribution.TestSuite ( Result(..) ) +import Distribution.Simple.Utils +import Distribution.TestSuite import Distribution.Text import Control.Monad ( when, unless, filterM ) @@ -132,5 +126,5 @@ fromPathTemplate $ substPathTemplate env template where env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.pkgKey lbi) + (PD.package pkg_descr) (LBI.localUnitId lbi) (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) diff --git a/Distribution/Simple/Test/ExeV10.hs b/Distribution/Simple/Test/ExeV10.hs --- a/Distribution/Simple/Test/ExeV10.hs +++ b/Distribution/Simple/Test/ExeV10.hs @@ -2,26 +2,22 @@ ( runTest ) where -import Distribution.Compat.CreatePipe ( createPipe ) -import Distribution.Compat.Environment ( getEnvironment ) +import Distribution.Compat.CreatePipe +import Distribution.Compat.Environment import qualified Distribution.PackageDescription as PD -import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar ) -import Distribution.Simple.BuildPaths ( exeExtension ) -import Distribution.Simple.Compiler ( compilerInfo ) -import Distribution.Simple.Hpc ( guessWay, markupTest, tixDir, tixFilePath ) +import Distribution.Simple.Build.PathsModule +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs - ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) - , substPathTemplate , toPathTemplate, PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI import Distribution.Simple.Setup - ( TestFlags(..), TestShowDetails(..), fromFlag, configCoverage ) import Distribution.Simple.Test.Log import Distribution.Simple.Utils - ( die, notice, rawSystemIOWithEnv, addLibraryPath ) -import Distribution.System ( Platform (..) ) +import Distribution.System import Distribution.TestSuite import Distribution.Text -import Distribution.Verbosity ( normal ) +import Distribution.Verbosity import Control.Concurrent (forkIO) import Control.Monad ( unless, void, when ) @@ -30,7 +26,7 @@ , getCurrentDirectory, removeDirectoryRecursive ) import System.Exit ( ExitCode(..) ) import System.FilePath ( (), (<.>) ) -import System.IO ( hGetContents, hPutStr, stdout ) +import System.IO ( hGetContents, hPutStr, stdout, stderr ) runTest :: PD.PackageDescription -> LBI.LocalBuildInfo @@ -63,16 +59,21 @@ -- Write summary notices indicating start of test suite notice verbosity $ summarizeSuiteStart $ PD.testName suite - (rOut, wOut) <- createPipe + (wOut, wErr, logText) <- case details of + Direct -> return (stdout, stderr, "") + _ -> do + (rOut, wOut) <- createPipe - -- Read test executable's output lazily (returns immediately) - logText <- hGetContents rOut - -- Force the IO manager to drain the test output pipe - void $ forkIO $ length logText `seq` return () + -- Read test executable's output lazily (returns immediately) + logText <- hGetContents rOut + -- Force the IO manager to drain the test output pipe + void $ forkIO $ length logText `seq` return () - -- '--show-details=streaming': print the log output in another thread - when (details == Streaming) $ void $ forkIO $ hPutStr stdout logText + -- '--show-details=streaming': print the log output in another thread + when (details == Streaming) $ void $ forkIO $ hPutStr stdout logText + return (wOut, wOut, logText) + -- Run the test executable let opts = map (testOption pkg_descr lbi suite) (testOptions flags) @@ -93,7 +94,7 @@ exit <- rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv') -- these handles are automatically closed - Nothing (Just wOut) (Just wOut) + Nothing (Just wOut) (Just wErr) -- Generate TestSuiteLog from executable exit code and a machine- -- readable test log. @@ -112,12 +113,10 @@ -- Show the contents of the human-readable log file on the terminal -- if there is a failure and/or detailed output is requested let whenPrinting = when $ - (details > Never) - && (not (suitePassed $ testLogs suiteLog) || details == Always) + ( details == Always || + details == Failures && not (suitePassed $ testLogs suiteLog)) -- verbosity overrides show-details && verbosity >= normal - -- if streaming, we already printed the log - && details /= Streaming whenPrinting $ putStr $ unlines $ lines logText -- Write summary notice to terminal indicating end of test suite @@ -163,6 +162,6 @@ fromPathTemplate $ substPathTemplate env template where env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.pkgKey lbi) + (PD.package pkg_descr) (LBI.localUnitId lbi) (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)] diff --git a/Distribution/Simple/Test/LibV09.hs b/Distribution/Simple/Test/LibV09.hs --- a/Distribution/Simple/Test/LibV09.hs +++ b/Distribution/Simple/Test/LibV09.hs @@ -6,28 +6,24 @@ , writeSimpleTestStub ) where -import Distribution.Compat.CreatePipe ( createPipe ) -import Distribution.Compat.Environment ( getEnvironment ) -import Distribution.Compat.TempFile ( openTempFile ) -import Distribution.ModuleName ( ModuleName ) +import Distribution.Compat.CreatePipe +import Distribution.Compat.Environment +import Distribution.Compat.Internal.TempFile +import Distribution.ModuleName import qualified Distribution.PackageDescription as PD -import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar ) -import Distribution.Simple.BuildPaths ( exeExtension ) -import Distribution.Simple.Compiler ( compilerInfo ) -import Distribution.Simple.Hpc ( guessWay, markupTest, tixDir, tixFilePath ) +import Distribution.Simple.Build.PathsModule +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs - ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) - , substPathTemplate , toPathTemplate, PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI import Distribution.Simple.Setup - ( TestFlags(..), TestShowDetails(..), fromFlag, configCoverage ) import Distribution.Simple.Test.Log import Distribution.Simple.Utils - ( die, notice, rawSystemIOWithEnv, addLibraryPath ) -import Distribution.System ( Platform (..) ) +import Distribution.System import Distribution.TestSuite import Distribution.Text -import Distribution.Verbosity ( normal ) +import Distribution.Verbosity import Control.Exception ( bracket ) import Control.Monad ( when, unless ) @@ -39,6 +35,7 @@ import System.Exit ( ExitCode(..), exitWith ) import System.FilePath ( (), (<.>) ) import System.IO ( hClose, hGetContents, hPutStr ) +import System.Process (StdStream(..), waitForProcess) runTest :: PD.PackageDescription -> LBI.LocalBuildInfo @@ -73,16 +70,11 @@ suiteLog <- bracket openCabalTemp deleteIfExists $ \tempLog -> do - (rIn, wIn) <- createPipe (rOut, wOut) <- createPipe - -- Prepare standard input for test executable - --appendFile tempInput $ show (tempInput, PD.testName suite) - hPutStr wIn $ show (tempLog, PD.testName suite) - hClose wIn - -- Run test executable - _ <- do let opts = map (testOption pkg_descr lbi suite) $ testOptions flags + (Just wIn, _, _, process) <- do + let opts = map (testOption pkg_descr lbi suite) $ testOptions flags dataDirPath = pwd PD.dataDir pkg_descr tixFile = pwd tixFilePath distPref way (PD.testName suite) pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) @@ -101,10 +93,23 @@ True False lbi clbi return (addLibraryPath os paths shellEnv) else return shellEnv - rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv') - -- these handles are closed automatically - (Just rIn) (Just wOut) (Just wOut) + createProcessWithEnv verbosity cmd opts Nothing (Just shellEnv') + -- these handles are closed automatically + CreatePipe (UseHandle wOut) (UseHandle wOut) + hPutStr wIn $ show (tempLog, PD.testName suite) + hClose wIn + + -- Append contents of temporary log file to the final human- + -- readable log file + logText <- hGetContents rOut + -- Force the IO manager to drain the test output pipe + length logText `seq` return () + + exitcode <- waitForProcess process + unless (exitcode == ExitSuccess) $ do + debug verbosity $ cmd ++ " returned " ++ show exitcode + -- Generate final log file name let finalLogName l = testLogDir testSuiteLogPath @@ -118,9 +123,6 @@ -- Write summary notice to log file indicating start of test suite appendFile (logFile suiteLog) $ summarizeSuiteStart $ PD.testName suite - -- Append contents of temporary log file to the final human- - -- readable log file - logText <- hGetContents rOut appendFile (logFile suiteLog) logText -- Write end-of-suite summary notice to log file @@ -167,7 +169,7 @@ fromPathTemplate $ substPathTemplate env template where env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.pkgKey lbi) + (PD.package pkg_descr) (LBI.localUnitId lbi) (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)] diff --git a/Distribution/Simple/Test/Log.hs b/Distribution/Simple/Test/Log.hs --- a/Distribution/Simple/Test/Log.hs +++ b/Distribution/Simple/Test/Log.hs @@ -11,18 +11,16 @@ , testSuiteLogPath ) where -import Distribution.Package ( PackageId ) +import Distribution.Package import qualified Distribution.PackageDescription as PD -import Distribution.Simple.Compiler ( Compiler(..), compilerInfo, CompilerId ) +import Distribution.Simple.Compiler import Distribution.Simple.InstallDirs - ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) - , substPathTemplate , toPathTemplate, PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.Setup ( TestShowDetails(..) ) -import Distribution.Simple.Utils ( notice ) -import Distribution.System ( Platform ) -import Distribution.TestSuite ( Options, Result(..) ) -import Distribution.Verbosity ( Verbosity ) +import Distribution.Simple.Setup +import Distribution.Simple.Utils +import Distribution.System +import Distribution.TestSuite +import Distribution.Verbosity import Control.Monad ( when ) import Data.Char ( toUpper ) @@ -109,13 +107,13 @@ -> String -- ^ test suite name -> TestLogs -- ^ test suite results -> FilePath -testSuiteLogPath template pkg_descr lbi name result = +testSuiteLogPath template pkg_descr lbi test_name result = fromPathTemplate $ substPathTemplate env template where env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.pkgKey lbi) + (PD.package pkg_descr) (LBI.localUnitId lbi) (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) - ++ [ (TestSuiteNameVar, toPathTemplate name) + ++ [ (TestSuiteNameVar, toPathTemplate test_name) , (TestSuiteResultVar, toPathTemplate $ resultString result) ] diff --git a/Distribution/Simple/UHC.hs b/Distribution/Simple/UHC.hs --- a/Distribution/Simple/UHC.hs +++ b/Distribution/Simple/UHC.hs @@ -16,15 +16,12 @@ module Distribution.Simple.UHC ( configure, getInstalledPackages, - buildLib, buildExe, installLib, registerPackage + buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath ) where -import Control.Monad -import Data.List -import qualified Data.Map as M ( empty ) import Distribution.Compat.ReadP import Distribution.InstalledPackageInfo -import Distribution.Package hiding (installedPackageId) +import Distribution.Package hiding (installedUnitId) import Distribution.PackageDescription import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler as C @@ -35,10 +32,14 @@ import Distribution.Text import Distribution.Verbosity import Distribution.Version +import Distribution.System import Language.Haskell.Extension + +import Control.Monad +import Data.List +import qualified Data.Map as M ( empty ) import System.Directory import System.FilePath -import Distribution.System ( Platform ) -- ----------------------------------------------------------------------------- -- Configuring @@ -91,14 +92,13 @@ -> IO InstalledPackageIndex getInstalledPackages verbosity comp packagedbs conf = do let compilerid = compilerId comp - systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram conf ["--meta-pkgdir-system"] + systemPkgDir <- getGlobalPackageDir verbosity conf userPkgDir <- getUserPackageDir let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) -- putStrLn $ "pkgdirs: " ++ show pkgDirs - -- call to "lines" necessary, because pkgdir contains an extra newline at the end - pkgs <- liftM (map addBuiltinVersions . concat) . - mapM (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d)) . - concatMap lines $ pkgDirs + pkgs <- liftM (map addBuiltinVersions . concat) $ + mapM (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d)) + pkgDirs -- putStrLn $ "pkgs: " ++ show pkgs let iPkgs = map mkInstalledPackageInfo $ @@ -107,9 +107,16 @@ -- putStrLn $ "installed pkgs: " ++ show iPkgs return (fromList iPkgs) +getGlobalPackageDir :: Verbosity -> ProgramConfiguration -> IO FilePath +getGlobalPackageDir verbosity conf = do + output <- rawSystemProgramStdoutConf verbosity + uhcProgram conf ["--meta-pkgdir-system"] + -- call to "lines" necessary, because pkgdir contains an extra newline at the end + let [pkgdir] = lines output + return pkgdir + getUserPackageDir :: IO FilePath -getUserPackageDir = - do +getUserPackageDir = do homeDir <- getHomeDirectory return $ homeDir ".cabal" "lib" -- TODO: determine in some other way @@ -150,8 +157,8 @@ -- | Create a trivial package info from a directory name. mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo mkInstalledPackageInfo p = emptyInstalledPackageInfo - { installedPackageId = InstalledPackageId (display p), - sourcePackageId = p } + { installedUnitId = mkLegacyUnitId p, + sourcePackageId = p } -- ----------------------------------------------------------------------------- @@ -161,7 +168,7 @@ -> Library -> ComponentLocalBuildInfo -> IO () buildLib verbosity pkg_descr lbi lib clbi = do - systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] + systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) userPkgDir <- getUserPackageDir let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) let uhcArgs = -- set package name @@ -183,7 +190,7 @@ buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () buildExe verbosity _pkg_descr lbi exe clbi = do - systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] + systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) userPkgDir <- getUserPackageDir let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) let uhcArgs = -- common flags lib/exe @@ -236,8 +243,8 @@ installLib :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> FilePath - -> PackageDescription -> Library -> IO () -installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library = do + -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO () +installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do -- putStrLn $ "dest: " ++ targetDir -- putStrLn $ "built: " ++ builtDir installDirectoryContents verbosity (builtDir display (packageId pkg)) targetDir @@ -258,19 +265,23 @@ registerPackage :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo - -> Bool + -> Compiler + -> ProgramConfiguration -> PackageDBStack + -> InstalledPackageInfo -> IO () -registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do - let installDirs = absoluteInstallDirs pkg lbi NoCopyDest - pkgdir | inplace = buildDir lbi uhcPackageDir (display pkgid) (display compilerid) - | otherwise = libdir installDirs uhcPackageSubDir (display compilerid) +registerPackage verbosity comp progdb packageDbs installedPkgInfo = do + dbdir <- case last packageDbs of + GlobalPackageDB -> getGlobalPackageDir verbosity progdb + UserPackageDB -> getUserPackageDir + SpecificPackageDB dir -> return dir + let pkgdir = dbdir uhcPackageDir (display pkgid) (display compilerid) createDirectoryIfMissingVerbose verbosity True pkgdir writeUTF8File (pkgdir installedPkgConfig) (showInstalledPackageInfo installedPkgInfo) where - pkgid = packageId pkg - compilerid = compilerId (compiler lbi) + pkgid = sourcePackageId installedPkgInfo + compilerid = compilerId comp + +inplacePackageDbPath :: LocalBuildInfo -> FilePath +inplacePackageDbPath lbi = buildDir lbi diff --git a/Distribution/Simple/UserHooks.hs b/Distribution/Simple/UserHooks.hs --- a/Distribution/Simple/UserHooks.hs +++ b/Distribution/Simple/UserHooks.hs @@ -29,16 +29,11 @@ ) where import Distribution.PackageDescription - (PackageDescription, GenericPackageDescription, - HookedBuildInfo, emptyHookedBuildInfo) -import Distribution.Simple.Program (Program) -import Distribution.Simple.Command (noExtraFlags) -import Distribution.Simple.PreProcess (PPSuffixHandler) +import Distribution.Simple.Program +import Distribution.Simple.Command +import Distribution.Simple.PreProcess import Distribution.Simple.Setup - (ConfigFlags, BuildFlags, ReplFlags, CleanFlags, CopyFlags, - InstallFlags, SDistFlags, RegisterFlags, HscolourFlags, - HaddockFlags, TestFlags, BenchmarkFlags) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) +import Distribution.Simple.LocalBuildInfo type Args = [String] diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs --- a/Distribution/Simple/Utils.hs +++ b/Distribution/Simple/Utils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Utils @@ -26,6 +26,9 @@ debugNoWrap, chattyTry, printRawCommandAndArgs, printRawCommandAndArgsAndEnv, + -- * exceptions + handleDoesNotExist, + -- * running programs rawSystemExit, rawSystemExitCode, @@ -33,6 +36,7 @@ rawSystemStdout, rawSystemStdInOut, rawSystemIOWithEnv, + createProcessWithEnv, maybeExit, xargs, findProgramLocation, @@ -64,12 +68,15 @@ -- * file names currentDir, shortRelativePath, + dropExeExtension, + exeExtensions, -- * finding files findFile, findFirstFile, findFileWithExtension, findFileWithExtension', + findAllFilesWithExtension, findModuleFile, findModuleFiles, getDirectoryContentsRecursive, @@ -113,6 +120,11 @@ writeUTF8File, normaliseLineEndings, + -- * BOM + startsWithBOM, + fileHasBOM, + ignoreBOM, + -- * generic utils dropWhileEndLE, takeWhileEndLE, @@ -125,20 +137,51 @@ listUnionRight, ordNub, ordNubRight, + safeTail, wrapText, wrapLine, ) where +import Distribution.Text +import Distribution.Package +import Distribution.ModuleName as ModuleName +import Distribution.System +import Distribution.Version +import Distribution.Compat.CopyFile +import Distribution.Compat.Internal.TempFile +import Distribution.Compat.Exception +import Distribution.Verbosity + +#if __GLASGOW_HASKELL__ < 711 +#ifdef VERSION_base +#define BOOTSTRAPPED_CABAL 1 +#endif +#else +#ifdef CURRENT_PACKAGE_KEY +#define BOOTSTRAPPED_CABAL 1 +#endif +#endif + +#ifdef BOOTSTRAPPED_CABAL +import qualified Paths_Cabal (version) +#endif + import Control.Monad - ( join, when, unless, filterM ) + ( when, unless, filterM ) import Control.Concurrent.MVar ( newEmptyMVar, putMVar, takeMVar ) -import Data.List - ( nub, unfoldr, isPrefixOf, tails, intercalate ) -import Data.Char as Char - ( isDigit, toLower, chr, ord ) import Data.Bits ( Bits((.|.), (.&.), shiftL, shiftR) ) +import Data.Char as Char + ( isDigit, toLower, chr, ord ) +import Data.Foldable + ( traverse_ ) +import Data.List + ( nub, unfoldr, intercalate, isInfixOf ) +import Data.Typeable + ( cast ) +import Data.Ord + ( comparing ) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.Set as Set @@ -163,7 +206,7 @@ , IOMode(ReadMode), hSetBinaryMode , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) import System.IO.Error as IO.Error - ( isDoesNotExistError, isAlreadyExistsError + ( isDoesNotExistError, isAlreadyExistsError, isUserError , ioeSetFileName, ioeGetFileName, ioeGetErrorString ) import System.IO.Error ( ioeSetLocation, ioeGetLocation ) @@ -171,40 +214,17 @@ ( unsafeInterleaveIO ) import qualified Control.Exception as Exception -import Distribution.Text - ( display, simpleParse ) -import Distribution.Package - ( PackageIdentifier ) -import Distribution.ModuleName (ModuleName) -import qualified Distribution.ModuleName as ModuleName -import Distribution.System - ( OS (..) ) -import Distribution.Version - (Version(..)) - import Control.Exception (IOException, evaluate, throwIO) import Control.Concurrent (forkIO) import qualified System.Process as Process ( CreateProcess(..), StdStream(..), proc) import System.Process - ( createProcess, rawSystem, runInteractiveProcess + ( ProcessHandle, createProcess, rawSystem, runInteractiveProcess , showCommandForUser, waitForProcess) -import Distribution.Compat.CopyFile - ( copyFile, copyOrdinaryFile, copyExecutableFile - , setFileOrdinary, setFileExecutable, setDirOrdinary ) -import Distribution.Compat.TempFile - ( openTempFile, createTempDirectory ) -import Distribution.Compat.Exception - ( tryIO, catchIO, catchExit ) -import Distribution.Verbosity -#ifdef VERSION_base -import qualified Paths_Cabal (version) -#endif - -- We only get our own version number when we're building with ourselves cabalVersion :: Version -#if defined(VERSION_base) +#if defined(BOOTSTRAPPED_CABAL) cabalVersion = Paths_Cabal.version #elif defined(CABAL_VERSION) cabalVersion = Version [CABAL_VERSION] [] @@ -227,24 +247,49 @@ die :: String -> IO a die msg = ioError (userError msg) -topHandlerWith :: (Exception.IOException -> IO a) -> IO a -> IO a -topHandlerWith cont prog = catchIO prog handle +topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a +topHandlerWith cont prog = + Exception.catches prog [ + Exception.Handler rethrowAsyncExceptions + , Exception.Handler rethrowExitStatus + , Exception.Handler handle + ] where - handle ioe = do + -- Let async exceptions rise to the top for the default top-handler + rethrowAsyncExceptions :: Exception.AsyncException -> IO a + rethrowAsyncExceptions = throwIO + + -- ExitCode gets thrown asynchronously too, and we don't want to print it + rethrowExitStatus :: ExitCode -> IO a + rethrowExitStatus = throwIO + + -- Print all other exceptions + handle :: Exception.SomeException -> IO a + handle se = do hFlush stdout pname <- getProgName - hPutStr stderr (mesage pname) - cont ioe - where - mesage pname = wrapText (pname ++ ": " ++ file ++ detail) - file = case ioeGetFileName ioe of - Nothing -> "" - Just path -> path ++ location ++ ": " - location = case ioeGetLocation ioe of - l@(n:_) | Char.isDigit n -> ':' : l - _ -> "" - detail = ioeGetErrorString ioe + hPutStr stderr (wrapText (message pname se)) + cont se + message :: String -> Exception.SomeException -> String + message pname (Exception.SomeException se) = + case cast se :: Maybe Exception.IOException of + Just ioe | isUserError ioe -> + let file = case ioeGetFileName ioe of + Nothing -> "" + Just path -> path ++ location ++ ": " + location = case ioeGetLocation ioe of + l@(n:_) | Char.isDigit n -> ':' : l + _ -> "" + detail = ioeGetErrorString ioe + in pname ++ ": " ++ file ++ detail + _ -> +#if __GLASGOW_HASKELL__ < 710 + show se +#else + Exception.displayException se +#endif + topHandler :: IO a -> IO a topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog @@ -310,6 +355,14 @@ catchIO action $ \exception -> putStrLn $ "Error while " ++ desc ++ ": " ++ show exception +-- | Run an IO computation, returning @e@ if it raises a "file +-- does not exist" error. +handleDoesNotExist :: a -> IO a -> IO a +handleDoesNotExist e = + Exception.handleJust + (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing) + (\_ -> return e) + -- ----------------------------------------------------------------------------- -- Helper functions @@ -356,7 +409,7 @@ -> IO () printRawCommandAndArgsAndEnv verbosity path args menv | verbosity >= deafening = do - maybe (return ()) (putStrLn . ("Environment: " ++) . show) menv + traverse_ (putStrLn . ("Environment: " ++) . show) menv print (path, args) | verbosity >= verbose = putStrLn $ showCommandForUser path args | otherwise = return () @@ -415,29 +468,47 @@ -> Maybe Handle -- ^ stderr -> IO ExitCode rawSystemIOWithEnv verbosity path args mcwd menv inp out err = do + (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv + (mbToStd inp) (mbToStd out) (mbToStd err) + exitcode <- waitForProcess ph + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + return exitcode + where + mbToStd :: Maybe Handle -> Process.StdStream + mbToStd = maybe Process.Inherit Process.UseHandle + +createProcessWithEnv :: + Verbosity + -> FilePath + -> [String] + -> Maybe FilePath -- ^ New working dir or inherit + -> Maybe [(String, String)] -- ^ New environment or inherit + -> Process.StdStream -- ^ stdin + -> Process.StdStream -- ^ stdout + -> Process.StdStream -- ^ stderr + -> IO (Maybe Handle, Maybe Handle, Maybe Handle,ProcessHandle) + -- ^ Any handles created for stdin, stdout, or stderr + -- with 'CreateProcess', and a handle to the process. +createProcessWithEnv verbosity path args mcwd menv inp out err = do printRawCommandAndArgsAndEnv verbosity path args menv hFlush stdout - (_,_,_,ph) <- createProcess $ - (Process.proc path args) { Process.cwd = mcwd - , Process.env = menv - , Process.std_in = mbToStd inp - , Process.std_out = mbToStd out - , Process.std_err = mbToStd err + (inp', out', err', ph) <- createProcess $ + (Process.proc path args) { + Process.cwd = mcwd + , Process.env = menv + , Process.std_in = inp + , Process.std_out = out + , Process.std_err = err #ifdef MIN_VERSION_process #if MIN_VERSION_process(1,2,0) -- delegate_ctlc has been added in process 1.2, and we still want to be able to -- bootstrap GHC on systems not having that version - , Process.delegate_ctlc = True + , Process.delegate_ctlc = True #endif #endif - } - exitcode <- waitForProcess ph - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - return exitcode - where - mbToStd :: Maybe Handle -> Process.StdStream - mbToStd = maybe Process.Inherit Process.UseHandle + } + return (inp', out', err', ph) -- | Run a command and return its output. -- @@ -519,6 +590,8 @@ return (out, err, exitcode) +{-# DEPRECATED findProgramLocation + "No longer used within Cabal, try findProgramOnSearchPath" #-} -- | Look for a program on the path. findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath) findProgramLocation verbosity prog = do @@ -610,6 +683,16 @@ | path <- nub searchPath , ext <- nub extensions ] +findAllFilesWithExtension :: [String] + -> [FilePath] + -> FilePath + -> IO [FilePath] +findAllFilesWithExtension extensions searchPath basename = + findAllFiles id + [ path basename <.> ext + | path <- nub searchPath + , ext <- nub extensions ] + -- | Like 'findFileWithExtension' but returns which element of the search path -- the file was found in, and the file path relative to that base directory. -- @@ -631,6 +714,9 @@ then return (Just x) else findFirst xs +findAllFiles :: (a -> FilePath) -> [a] -> IO [a] +findAllFiles file = filterM (doesFileExist . file) + -- | Finds the files corresponding to a list of Haskell module names. -- -- As 'findModuleFile' but for a list of module names. @@ -950,7 +1036,8 @@ copyDirectoryRecursive verbosity srcDir destDir = do info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") srcFiles <- getDirectoryContentsRecursive srcDir - copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f) | f <- srcFiles ] + copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f) + | f <- srcFiles ] ------------------- -- File permissions @@ -1012,7 +1099,8 @@ Exception.bracket (openTempFile tmpDir template) (\(name, handle) -> do hClose handle - unless (optKeepTempFiles opts) $ removeFile name) + unless (optKeepTempFiles opts) $ + handleDoesNotExist () . removeFile $ name) (uncurry action) -- | Create and use a temporary directory. @@ -1038,7 +1126,8 @@ withTempDirectoryEx _verbosity opts targetDir template = Exception.bracket (createTempDirectory targetDir template) - (unless (optKeepTempFiles opts) . removeDirectoryRecursive) + (unless (optKeepTempFiles opts) + . handleDoesNotExist () . removeDirectoryRecursive) ----------------------------------- -- Safely reading and writing files @@ -1105,6 +1194,24 @@ | x == y = dropCommonPrefix xs ys dropCommonPrefix xs ys = (xs,ys) +-- | Drop the extension if it's one of 'exeExtensions', or return the path +-- unchanged. +dropExeExtension :: FilePath -> FilePath +dropExeExtension filepath = + case splitExtension filepath of + (filepath', extension) | extension `elem` exeExtensions -> filepath' + | otherwise -> filepath + +-- | List of possible executable file extensions on the current platform. +exeExtensions :: [String] +exeExtensions = case buildOS of + -- Possible improvement: on Windows, read the list of extensions from the + -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat; + -- .cmd". + Windows -> ["", "exe"] + Ghcjs -> ["", "exe"] + _ -> [""] + -- ------------------------------------------------------------ -- * Finding the description file -- ------------------------------------------------------------ @@ -1143,7 +1250,7 @@ -- |Like 'findPackageDesc', but calls 'die' in case of error. tryFindPackageDesc :: FilePath -> IO FilePath -tryFindPackageDesc dir = join . fmap (either die return) $ findPackageDesc dir +tryFindPackageDesc dir = either die return =<< findPackageDesc dir -- |Optional auxiliary package information file (/pkgname/@.buildinfo@) defaultHookedPackageDesc :: IO (Maybe FilePath) @@ -1236,6 +1343,16 @@ : toUTF8 cs where w = ord c +-- | Whether BOM is at the beginning of the input +startsWithBOM :: String -> Bool +startsWithBOM ('\xFEFF':_) = True +startsWithBOM _ = False + +-- | Check whether a file has Unicode byte order mark (BOM). +fileHasBOM :: FilePath -> IO Bool +fileHasBOM f = fmap (startsWithBOM . fromUTF8) + . hGetContents =<< openBinaryFile f ReadMode + -- | Ignore a Unicode byte order mark (BOM) at the beginning of the input -- ignoreBOM :: String -> String @@ -1357,14 +1474,13 @@ where bSet = Set.fromList b +-- | A total variant of 'tail'. +safeTail :: [a] -> [a] +safeTail [] = [] +safeTail (_:xs) = xs + equating :: Eq a => (b -> a) -> b -> b -> Bool equating p x y = p x == p y - -comparing :: Ord a => (b -> a) -> b -> b -> Ordering -comparing p x y = p x `compare` p y - -isInfixOf :: String -> String -> Bool -isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) 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 @@ -13,7 +13,7 @@ -- probably know about the 'System.Info.os' however using that is very -- inconvenient because it is a string and different Haskell implementations -- do not agree on using the same strings for the same platforms! (In --- particular see the controversy over \"windows\" vs \"ming32\"). So to make it +-- particular see the controversy over \"windows\" vs \"mingw32\"). So to make it -- more consistent and easy to use we have an 'OS' enumeration. -- module Distribution.System ( @@ -28,18 +28,24 @@ -- * Platform is a pair of arch and OS Platform(..), buildPlatform, - platformFromTriple + platformFromTriple, + + -- * Internal + knownOSs, + knownArches ) where import qualified System.Info (os, arch) -import qualified Data.Char as Char (toLower, isAlphaNum) +import qualified Data.Char as Char (toLower, isAlphaNum, isAlpha) -import Distribution.Compat.Binary (Binary) +import Distribution.Compat.Binary +import Distribution.Text +import qualified Distribution.Compat.ReadP as Parse + +import Control.Monad (liftM2) import Data.Data (Data) import Data.Typeable (Typeable) import Data.Maybe (fromMaybe, listToMaybe) -import Distribution.Text (Text(..), display) -import qualified Distribution.Compat.ReadP as Parse import GHC.Generics (Generic) import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>)) @@ -72,30 +78,28 @@ | DragonFly | Solaris | AIX | HPUX | IRIX -- ageing Unix OSs | HaLVM -- bare metal / VMs / hypervisors - | IOS -- iOS + | Hurd -- GNU's microkernel + | IOS | Android -- mobile OSs | Ghcjs | OtherOS String deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) instance Binary OS ---TODO: decide how to handle Android and iOS. --- They are like Linux and OSX but with some differences. --- Should they be separate from Linux/OS X, or a subtype? --- e.g. should we have os(linux) && os(android) true simultaneously? - knownOSs :: [OS] knownOSs = [Linux, Windows, OSX ,FreeBSD, OpenBSD, NetBSD, DragonFly ,Solaris, AIX, HPUX, IRIX ,HaLVM - ,IOS + ,Hurd + ,IOS, Android ,Ghcjs] osAliases :: ClassificationStrictness -> OS -> [String] osAliases Permissive Windows = ["mingw32", "win32", "cygwin32"] osAliases Compat Windows = ["mingw32", "win32"] osAliases _ OSX = ["darwin"] +osAliases _ Hurd = ["gnu"] osAliases Permissive FreeBSD = ["kfreebsdgnu"] osAliases Compat FreeBSD = ["kfreebsdgnu"] osAliases Permissive Solaris = ["solaris2"] @@ -180,11 +184,21 @@ instance Text Platform where disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os + -- TODO: there are ambigious platforms like: `arch-word-os` + -- which could be parsed as + -- * Platform "arch-word" "os" + -- * Platform "arch" "word-os" + -- We could support that preferring variants 'OtherOS' or 'OtherArch' + -- + -- For now we split into arch and os parts on the first dash. parse = do - arch <- parse + arch <- parseDashlessArch _ <- Parse.char '-' os <- parse return (Platform arch os) + where + parseDashlessArch :: Parse.ReadP r Arch + parseDashlessArch = fmap (classifyArch Strict) dashlessIdent -- | The platform Cabal was compiled on. In most cases, -- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're @@ -195,9 +209,15 @@ -- Utils: ident :: Parse.ReadP r String -ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') - --TODO: probably should disallow starting with a number +ident = liftM2 (:) first rest + where first = Parse.satisfy Char.isAlpha + rest = Parse.munch (\c -> Char.isAlphaNum c || c == '_' || c == '-') +dashlessIdent :: Parse.ReadP r String +dashlessIdent = liftM2 (:) first rest + where first = Parse.satisfy Char.isAlpha + rest = Parse.munch (\c -> Char.isAlphaNum c || c == '_') + lowercase :: String -> String lowercase = map Char.toLower @@ -206,10 +226,10 @@ 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 + arch <- fmap (classifyArch Permissive) parseWord _ <- Parse.char '-' _ <- parseWord -- Skip vendor _ <- Parse.char '-' - os <- fmap (classifyOS Compat) ident -- OS may have hyphens, like + os <- fmap (classifyOS Permissive) ident -- OS may have hyphens, like -- 'nto-qnx' return $ Platform arch os diff --git a/Distribution/Text.hs b/Distribution/Text.hs --- a/Distribution/Text.hs +++ b/Distribution/Text.hs @@ -13,6 +13,7 @@ -- module Distribution.Text ( Text(..), + defaultStyle, display, simpleParse, ) where @@ -27,13 +28,15 @@ disp :: a -> Disp.Doc parse :: Parse.ReadP r a +-- | The default rendering style used in Cabal for console output. +defaultStyle :: Disp.Style +defaultStyle = Disp.Style { Disp.mode = Disp.PageMode + , Disp.lineLength = 79 + , Disp.ribbonsPerLine = 1.0 + } + display :: Text a => a -> String -display = Disp.renderStyle style . disp - where style = Disp.Style { - Disp.mode = Disp.PageMode, - Disp.lineLength = 79, - Disp.ribbonsPerLine = 1.0 - } +display = Disp.renderStyle defaultStyle . disp simpleParse :: Text a => String -> Maybe a simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str @@ -51,18 +54,20 @@ , (Parse.string "False" Parse.+++ Parse.string "false") >> return False ] +instance Text Int where + disp = Disp.text . show + parse = (fmap negate $ Parse.char '-' >> parseNat) Parse.+++ parseNat + +-- | Parser for non-negative integers. +parseNat :: Parse.ReadP r Int +parseNat = read `fmap` Parse.munch1 Char.isDigit + instance Text Version where disp (Version branch _tags) -- Death to version tags!! = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch)) parse = do - branch <- Parse.sepBy1 digits (Parse.char '.') - tags <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum) - return (Version branch tags) --TODO: should we ignore the tags? - where - digits = do - first <- Parse.satisfy Char.isDigit - if first == '0' - then return 0 - else do rest <- Parse.munch Char.isDigit - return (read (first : rest)) + branch <- Parse.sepBy1 parseNat (Parse.char '.') + -- allow but ignore tags: + _tags <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum) + return (Version branch []) diff --git a/Distribution/Utils/NubList.hs b/Distribution/Utils/NubList.hs --- a/Distribution/Utils/NubList.hs +++ b/Distribution/Utils/NubList.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} module Distribution.Utils.NubList ( NubList -- opaque , toNubList -- smart construtor @@ -11,12 +10,9 @@ , overNubListR ) where +import Distribution.Compat.Semigroup as Semi import Distribution.Compat.Binary -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif - -import Distribution.Simple.Utils (ordNub, listUnion, ordNubRight, listUnionRight) +import Distribution.Simple.Utils import qualified Text.Read as R @@ -54,8 +50,11 @@ instance Ord a => Monoid (NubList a) where mempty = NubList [] - mappend (NubList xs) (NubList ys) = NubList $ xs `listUnion` ys + mappend = (Semi.<>) +instance Ord a => Semigroup (NubList a) where + (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys + instance Show a => Show (NubList a) where show (NubList list) = show list @@ -63,7 +62,7 @@ readPrec = readNubList toNubList -- | Helper used by NubList/NubListR's Read instances. -readNubList :: (Ord a, Read a) => ([a] -> l a) -> R.ReadPrec (l a) +readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a) readNubList toList = R.parens . R.prec 10 $ fmap toList R.readPrec -- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we @@ -91,7 +90,10 @@ instance Ord a => Monoid (NubListR a) where mempty = NubListR [] - mappend (NubListR xs) (NubListR ys) = NubListR $ xs `listUnionRight` ys + mappend = (Semi.<>) + +instance Ord a => Semigroup (NubListR a) where + (NubListR xs) <> (NubListR ys) = NubListR $ xs `listUnionRight` ys instance Show a => Show (NubListR a) where show (NubListR list) = show list diff --git a/Distribution/Verbosity.hs b/Distribution/Verbosity.hs --- a/Distribution/Verbosity.hs +++ b/Distribution/Verbosity.hs @@ -24,9 +24,10 @@ showForCabal, showForGHC ) where -import Distribution.Compat.Binary (Binary) -import Data.List (elemIndex) +import Distribution.Compat.Binary import Distribution.ReadE + +import Data.List (elemIndex) import GHC.Generics data Verbosity = Silent | Normal | Verbose | Deafening diff --git a/Distribution/Version.hs b/Distribution/Version.hs --- a/Distribution/Version.hs +++ b/Distribution/Version.hs @@ -4,20 +4,23 @@ {-# LANGUAGE StandaloneDeriving #-} #endif --- Hack approach to support bootstrapping --- Assume binary <0.8 when MIN_VERSION_binary macro is not available. --- Starting with GHC>=8.0, compiler will hopefully provide this macros too. --- https://ghc.haskell.org/trac/ghc/ticket/10970 --- --- Otherwise, one can specify -DMIN_VERSION_binary_0_8_0=1, when bootstrapping --- with binary >=0.8.0.0 +-- Hack approach to support bootstrapping. +-- When MIN_VERSION_binary macro is available, use it. But it's not available +-- during bootstrapping (or anyone else building Setup.hs directly). If the +-- builder specifies -DMIN_VERSION_binary_0_8_0=1 or =0 then we respect that. +-- Otherwise we pick a default based on GHC version: assume binary <0.8 when +-- GHC < 8.0, and binary >=0.8 when GHC >= 8.0. #ifdef MIN_VERSION_binary #define MIN_VERSION_binary_0_8_0 MIN_VERSION_binary(0,8,0) #else #ifndef MIN_VERSION_binary_0_8_0 +#if __GLASGOW_HASKELL__ >= 800 +#define MIN_VERSION_binary_0_8_0 1 +#else #define MIN_VERSION_binary_0_8_0 0 #endif #endif +#endif #if !MIN_VERSION_binary_0_8_0 {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -50,6 +53,7 @@ laterVersion, earlierVersion, orLaterVersion, orEarlierVersion, unionVersionRanges, intersectVersionRanges, + invertVersionRange, withinVersion, betweenVersionsInclusive, @@ -61,6 +65,8 @@ simplifyVersionRange, foldVersionRange, foldVersionRange', + hasUpperBound, + hasLowerBound, -- ** Modification removeUpperBound, @@ -86,6 +92,7 @@ mkVersionIntervals, unionVersionIntervals, intersectVersionIntervals, + invertVersionIntervals ) where @@ -95,9 +102,10 @@ import Data.Version ( Version(..) ) import GHC.Generics ( Generic ) -import Distribution.Text ( Text(..) ) +import Distribution.Text import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP ((+++)) +import Distribution.Compat.ReadP hiding (get) + import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>), (<+>)) import qualified Data.Char as Char (isDigit) @@ -140,13 +148,20 @@ put (Version br tags) = put br >> put tags #endif -{-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED LaterVersion "use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED EarlierVersion "use 'earlierVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED WildcardVersion "use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED UnionVersionRanges "use 'unionVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED IntersectVersionRanges "use 'intersectVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DeprecateD AnyVersion + "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED ThisVersion + "Use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED LaterVersion + "Use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED EarlierVersion + "Use 'earlierVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED WildcardVersion + "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED UnionVersionRanges + "Use 'unionVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED IntersectVersionRanges + "Use 'intersectVersionRanges', 'foldVersionRange' or 'asVersionIntervals'"#-} -- | The version range @-any@. That is, a version range containing all -- versions. @@ -225,6 +240,16 @@ intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange intersectVersionRanges = IntersectVersionRanges +-- | The inverse of a version range +-- +-- > withinRange v' (invertVersionRange vr) +-- > = not (withinRange v' vr) +-- +invertVersionRange :: VersionRange -> VersionRange +invertVersionRange = + fromVersionIntervals . invertVersionIntervals + . VersionIntervals . asVersionIntervals + -- | The version range @== v.*@. -- -- For example, for version @1.2@, the version range @== 1.2.*@ is the same as @@ -293,9 +318,10 @@ (orLaterVersion v) (earlierVersion (wildcardUpperBound v)) --- | An extended variant of 'foldVersionRange' that also provides a view of --- in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented --- explicitly rather than in terms of the other basic syntax. +-- | An extended variant of 'foldVersionRange' that also provides a view of the +-- expression in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== +-- v.*\"@ is presented explicitly rather than in terms of the other basic +-- syntax. -- foldVersionRange' :: a -- ^ @\"-any\"@ version -> (Version -> a) -- ^ @\"== v\"@ @@ -697,6 +723,47 @@ where lowerBound = max lower lower' +invertVersionIntervals :: VersionIntervals + -> VersionIntervals +invertVersionIntervals (VersionIntervals xs) = + case xs of + -- Empty interval set + [] -> VersionIntervals [(noLowerBound, NoUpperBound)] + -- Interval with no lower bound + ((lb, ub) : more) | lb == noLowerBound -> + VersionIntervals $ invertVersionIntervals' ub more + -- Interval with a lower bound + ((lb, ub) : more) -> + VersionIntervals $ (noLowerBound, invertLowerBound lb) + : invertVersionIntervals' ub more + where + -- Invert subsequent version intervals given the upper bound of + -- the intervals already inverted. + invertVersionIntervals' :: UpperBound + -> [(LowerBound, UpperBound)] + -> [(LowerBound, UpperBound)] + invertVersionIntervals' NoUpperBound [] = [] + invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)] + invertVersionIntervals' ub0 [(lb, NoUpperBound)] = + [(invertUpperBound ub0, invertLowerBound lb)] + invertVersionIntervals' ub0 ((lb, ub1) : more) = + (invertUpperBound ub0, invertLowerBound lb) + : invertVersionIntervals' ub1 more + + invertLowerBound :: LowerBound -> UpperBound + invertLowerBound (LowerBound v b) = UpperBound v (invertBound b) + + invertUpperBound :: UpperBound -> LowerBound + invertUpperBound (UpperBound v b) = LowerBound v (invertBound b) + invertUpperBound NoUpperBound = error "NoUpperBound: unexpected" + + invertBound :: Bound -> Bound + invertBound ExclusiveBound = InclusiveBound + invertBound InclusiveBound = ExclusiveBound + + noLowerBound :: LowerBound + noLowerBound = LowerBound (Version [0] []) InclusiveBound + ------------------------------- -- Parsing and pretty printing -- @@ -711,9 +778,11 @@ (\v -> (Disp.text ">=" <> disp v , 0)) (\v -> (Disp.text "<=" <> disp v , 0)) (\v _ -> (Disp.text "==" <> dispWild v , 0)) - (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) - (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) - (\(r, p) -> (Disp.parens r, p)) + (\(r1, p1) (r2, p2) -> + (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) + (\(r1, p1) (r2, p2) -> + (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) + (\(r, _) -> (Disp.parens r, 0)) where dispWild (Version b _) = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) @@ -775,3 +844,28 @@ (">", LaterVersion), (">=", orLaterVersion), ("==", ThisVersion) ] + +-- | Does the version range have an upper bound? +-- +-- @since 1.24.0.0 +hasUpperBound :: VersionRange -> Bool +hasUpperBound = foldVersionRange + False + (const True) + (const False) + (const True) + (&&) (||) + +-- | Does the version range have an explicit lower bound? +-- +-- Note: this function only considers the user-specified lower bounds, but not +-- the implicit >=0 lower bound. +-- +-- @since 1.24.0.0 +hasLowerBound :: VersionRange -> Bool +hasLowerBound = foldVersionRange + False + (const True) + (const True) + (const False) + (&&) (||) diff --git a/Language/Haskell/Extension.hs b/Language/Haskell/Extension.hs --- a/Language/Haskell/Extension.hs +++ b/Language/Haskell/Extension.hs @@ -22,12 +22,13 @@ deprecatedExtensions ) where -import Distribution.Text (Text(..)) +import Distribution.Text import qualified Distribution.Compat.ReadP as Parse +import Distribution.Compat.Binary + import qualified Text.PrettyPrint as Disp import qualified Data.Char as Char (isAlphaNum) import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) -import Distribution.Compat.Binary (Binary) import Data.Data (Data) import Data.Typeable (Typeable) import GHC.Generics (Generic) @@ -713,6 +714,57 @@ -- -- * | DeriveAnyClass + + -- | Enable @deriving@ for the 'Language.Haskell.TH.Syntax.Lift' class. + -- + -- * + | DeriveLift + + -- | Enable support for 'static pointers' (and the @static@ + -- keyword) to refer to globally stable names, even across + -- different programs. + -- + -- * + | StaticPointers + + -- | Switches data type declarations to be strict by default (as if + -- they had a bang using @BangPatterns@), and allow opt-in field + -- laziness using @~@. + | StrictData + + -- | Switches all pattern bindings to be strict by default (as if + -- they had a bang using @BangPatterns@), ordinary patterns are + -- recovered using @~@. Implies @StrictData@. + | Strict + + -- | Allows @do@-notation for types that are @'Applicative'@ as well + -- as @'Monad'@. When enabled, desugaring @do@ notation tries to use + -- @(<*>)@ and @'fmap'@ and @'join'@ as far as possible. + | ApplicativeDo + + -- | Allow records to use duplicated field labels for accessors. + | DuplicateRecordFields + + -- | Enable explicit type applications with the syntax @id \@Int@. + | TypeApplications + + -- | Dissolve the distinction between types and kinds, allowing the compiler + -- to reason about kind equality and therefore enabling GADTs to be promoted + -- to the type-level. + | TypeInType + + -- | Allow recursive (and therefore undecideable) super-class relationships. + | UndecidableSuperClasses + + -- | A temporary extension to help library authors check if their + -- code will compile with the new planned desugaring of fail. + | MonadFailDesugaring + + -- | A subset of @TemplateHaskell@ including only quasi-quoting. + | TemplateHaskellQuotes + + -- | Allows use of the @#label@ syntax. + | OverloadedLabels deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -8,3 +8,6 @@ -- on any previous installation. This also means we can use any new features -- immediately because we never have to worry about building Cabal with an -- older version of itself. +-- +-- NOTE 25/01/2015: Bootstrapping is disabled for now, see +-- https://github.com/haskell/cabal/issues/3003. diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,42 +1,32 @@ -1.22.8.0 Ryan Thomas March 2016 - * Distribution.Simple.Setup: remove job cap. Fixes #3191. - * Check all object file suffixes for recompilation. Fixes #3128. - * Move source files under 'src/'. Fixes #3003. - -1.22.7.0 Ryan Thomas January 2016 - * Backport #3012 to the 1.22 branch - * Cabal.cabal: change build-type to Simple - * Add foldl' import - * The Cabal part for fully gcc-like response files - -1.22.6.0 - * Relax upper bound to allow upcoming binary-0.8 - -1.22.5.0 - * Don't recompile C sources unless needed (#2601). (Luke Iannini) - * Support Haddock response files. - * Add frameworks when linking a dynamic library. - -1.22.4.0 Ryan Thomas June 2015 - * Add libname install-dirs variable, use it by default. Fixes #2437. (Edward Z. Yang) - * Reduce temporary directory name length, fixes #2502. (Edward Z. Yang) - * Workaround for #2527. (Mikhail Glushenkov) - -1.22.3.0 Ryan Thomas April 2015 - * Fix for the ghcjs-pkg version number handling (Luite Stegeman) - * filterConfigureFlags: filter more flags (Mikhail Glushenkov) - * Cabal check will fail on -fprof-auto passed as a ghc-option - Fixes #2479 (John Chee) +-*-change-log-*- -1.22.2.0 Ryan Thomas March 2015 - * Don't pass '--{en,dis}able-profiling' to old setup. - * Add -Wall police - * Fix dependencies on 'old-time' - * Fix test interface detailed-0.9 with GHC 7.10 - * Fix HPC tests with GHC 7.10 - * Make sure to pass the package key to ghc - * Use --package-{name|version} when available for Haddock when available - * Put full package name and version in library names - * Fully specify package key format, so external tools can generate it. +1.24.0.0 Ryan Thomas May 2016 + * Support GHC 8. + * Deal with extra C sources from preprocessors (#238). + * Include cabal_macros.h when running c2hs (#2600). + * Don't recompile C sources unless needed (#2601). + * Read 'builddir' option from 'CABAL_BUILDDIR' environment variable + * Add '--profiling-detail=$level' flag with a default for libraries + and executables of 'exported-functions' and 'toplevel-functions' + respetively (GHC's '-fprof-auto-{exported,top}' flags) (#193). + * New 'custom-setup' stanza to specify setup deps. Setup is also built + with the cabal_macros.h style macros, for conditional compilation. + * Support Haddock response files (#2746). + * Fixed a bug in the Text instance for Platform (#2862). + * New 'setup haddock' option: '--for-hackage' (#2852). + * New --show-detail=direct; like streaming, but allows the test + program to detect that is connected to a terminal, and works + reliable with a non-threaded runtime (#2911, and serves as a + work-around for #2398) + * Library support for multi-instance package DBs (#2948). + * Improved the './Setup configure' solver (#3082, #3076). + * The '--allow-newer' option can be now used with './Setup + configure' (#3163). + * Added a way to specify extra locations to find OS X frameworks + in ('extra-framework-dirs'). Can be used both in .cabal files and + as an argument to './Setup configure' (#3158). + * Macros 'VERSION_$pkgname' and 'MIN_VERSION_$pkgname' are now + also generated for the current package. (#3235). 1.22.0.0 Johan Tibell January 2015 * Support GHC 7.10. diff --git a/doc/Cabal.css b/doc/Cabal.css new file mode 100644 --- /dev/null +++ b/doc/Cabal.css @@ -0,0 +1,49 @@ +body { + max-width: 18cm; +} + +div { + font-family: sans-serif; + color: black; + background: white +} + +h1, h2, h3, h4, h5, h6, p.title { color: #005A9C } + +h1 { font: 170% sans-serif } +h2 { font: 140% sans-serif } +h3 { font: 120% sans-serif } +h4 { font: bold 100% sans-serif } +h5 { font: italic 100% sans-serif } +h6 { font: small-caps 100% sans-serif } + +pre { + font-family: monospace; + border-width: 1px; + border-style: solid; + padding: 0.3em +} + +pre.screen { color: #006400 } +pre.programlisting { color: maroon } + +div.example { + margin: 1ex 0em; + border: solid #412e25 1px; + padding: 0ex 0.4em +} + +div.example, div.example-contents { + background-color: #fffcf5 +} + +a:link { color: #0000C8 } +a:hover { background: #FFFFA8 } +a:active { color: #D00000 } +a:visited { color: #680098 } + +h1 a:link, h2 a:link, h3 a:link, h4 a:link, h5 a:link, h6 a:link, +h1 a:visited, h2 a:visited, h3 a:visited, h4 a:visited, h5 a:visited, h6 a:visited { + color: #005A9C; + text-decoration: none +} diff --git a/doc/developing-packages.markdown b/doc/developing-packages.markdown --- a/doc/developing-packages.markdown +++ b/doc/developing-packages.markdown @@ -676,10 +676,11 @@ The syntax of the value depends on the field. Field types include: _token_, _filename_, _directory_ -: Either a sequence of one or more non-space non-comma characters, or - a quoted string in Haskell 98 lexical syntax. Unless otherwise - stated, relative filenames and directories are interpreted from the - package root directory. +: Either a sequence of one or more non-space non-comma characters, or a quoted + string in Haskell 98 lexical syntax. The latter can be used for escaping + whitespace, for example: `ghc-options: -Wall "-with-rtsopts=-T -I1"`. + Unless otherwise stated, relative filenames and directories are interpreted + from the package root directory. _freeform_, _URL_, _address_ : An arbitrary, uninterpreted string. @@ -705,8 +706,12 @@ * `.x` ([alex][]) * `.cpphs` ([cpphs][]) -When building, Cabal will automatically run the appropriate preprocessor -and compile the Haskell module it produces. +When building, Cabal will automatically run the appropriate +preprocessor and compile the Haskell module it produces. For the +`c2hs` and `hsc2hs` preprocessors, Cabal will also automatically add, +compile and link any C sources generated by the preprocessor (produced +by `hsc2hs`'s `#def` feature or `c2hs`'s auto-generated wrapper +functions). Some fields take lists of values, which are optionally separated by commas, except for the `build-depends` field, where the commas are mandatory. @@ -998,6 +1003,32 @@ `cabal.config` file. All environments which share this file will use the dependency versions specified in it. +#### Generating dependency version bounds #### + +Cabal also has the ability to suggest dependency version bounds that conform to +[Package Versioning Policy][PVP], which is a recommended versioning system for +publicly released Cabal packages. This is done by running the `gen-bounds` +command: + +~~~~~~~~~~~~~~~~ +cabal gen-bounds +~~~~~~~~~~~~~~~~ + +For example, given the following dependencies specified in `build-depends`: + +~~~~~~~~~~~~~~~~ +foo == 0.5.2 +bar == 1.1 +~~~~~~~~~~~~~~~~ + +`gen-bounds` will suggest changing them to the following: + +~~~~~~~~~~~~~~~~ +foo >= 0.5.2 && < 0.6 +bar >= 1.1 && < 1.2 +~~~~~~~~~~~~~~~~ + + ### Executables ### Executable sections (if present) describe executable programs contained @@ -1077,9 +1108,7 @@ #### Example: Package using `exitcode-stdio-1.0` interface #### The example package description and executable source file below demonstrate -the use of the `exitcode-stdio-1.0` interface. For brevity, the example package -does not include a library or any normal executables, but a real package would -be required to have at least one library or executable. +the use of the `exitcode-stdio-1.0` interface. foo.cabal: @@ -1111,12 +1140,10 @@ #### Example: Package using `detailed-0.9` interface #### The example package description and test module source file below demonstrate -the use of the `detailed-0.9` interface. For brevity, the example package does -note include a library or any normal executables, but a real package would be -required to have at least one library or executable. The test module below -also develops a simple implementation of the interface set by -`Distribution.TestSuite`, but in actual usage the implementation would be -provided by the library that provides the testing facility. +the use of the `detailed-0.9` interface. The test module also develops a simple +implementation of the interface set by `Distribution.TestSuite`, but in actual +usage the implementation would be provided by the library that provides the +testing facility. bar.cabal: @@ -1204,9 +1231,7 @@ #### Example: Package using `exitcode-stdio-1.0` interface #### The example package description and executable source file below demonstrate -the use of the `exitcode-stdio-1.0` interface. For brevity, the example package -does not include a library or any normal executables, but a real package would -be required to have at least one library or executable. +the use of the `exitcode-stdio-1.0` interface. foo.cabal: @@ -1257,12 +1282,12 @@ ### Build information ### -The following fields may be optionally present in a library or -executable section, and give information for the building of the +The following fields may be optionally present in a library, executable, test +suite or benchmark section, and give information for the building of the corresponding library or executable. See also the sections on [system-dependent parameters](#system-dependent-parameters) and -[configurations](#configurations) for a way to supply system-dependent -values for these fields. +[configurations](#configurations) for a way to supply system-dependent values +for these fields. `build-depends:` _package list_ : A list of packages needed to build this one. Each package can be @@ -1292,29 +1317,16 @@ It is only syntactic sugar. It is exactly equivalent to `foo >= 1.2 && < 1.3`. - With Cabal 1.20 and GHC 7.10, `build-depends` also supports module - thinning and renaming, which allows you to selectively decide what - modules become visible from a package dependency. For example: - - ~~~~~~~~~~~~~~~~ - build-depends: containers (Data.Set, Data.IntMap as Map) - ~~~~~~~~~~~~~~~~ - - This results in only the modules `Data.Set` and `Map` being visible to - the user from containers, hiding all other modules. To add additional - names for modules without hiding the others, you can use the `with` - keyword: - - ~~~~~~~~~~~~~~~~ - build-depends: containers with (Data.IntMap as Map) - ~~~~~~~~~~~~~~~~ - Note: Prior to Cabal 1.8, build-depends specified in each section were global to all sections. This was unintentional, but some packages were written to depend on it, so if you need your build-depends to be local to each section, you must specify at least `Cabal-Version: >= 1.8` in your `.cabal` file. + Note: Cabal 1.20 experimentally supported module thinning and + renaming in `build-depends`; however, this support has since been + removed and should not be used. + `other-modules:` _identifier list_ : A list of modules used by the component but not exposed to users. For a library component, these would be hidden modules of the @@ -1330,21 +1342,38 @@ For backwards compatibility, the old variant `hs-source-dir` is also recognized. -`extensions:` _identifier list_ -: A list of Haskell extensions used by every module. Extension names - are the constructors of the [Extension][extension] type. These - determine corresponding compiler options. In particular, `CPP` specifies that - Haskell source files are to be preprocessed with a C preprocessor. +`default-extensions:` _identifier list_ +: A list of Haskell extensions used by every module. These determine + corresponding compiler options enabled for all files. Extension names are + the constructors of the [Extension][extension] type. For example, `CPP` + specifies that Haskell source files are to be preprocessed with a C + preprocessor. - Extensions used only by one module may be specified by placing a - `LANGUAGE` pragma in the source file affected, e.g.: +`other-extensions:` _identifier list_ +: A list of Haskell extensions used by some (but not necessarily all) modules. + From GHC version 6.6 onward, these may be specified by placing a `LANGUAGE` + pragma in the source files affected e.g. ~~~~~~~~~~~~~~~~ {-# LANGUAGE CPP, MultiParamTypeClasses #-} ~~~~~~~~~~~~~~~~ - Note: GHC versions prior to 6.6 do not support the `LANGUAGE` pragma. + In Cabal-1.24 the dependency solver will use this and `default-extensions` information. + Cabal prior to 1.24 will abort compilation if the current compiler doesn't provide + the extensions. + If you use some extensions conditionally, using CPP or conditional module lists, + it is good to replicate the condition in `other-extensions` declarations: + + ~~~~~~~~~~~~~~~~ + other-extensions: CPP + if impl(ghc >= 7.5) + other-extensions: PolyKinds + ~~~~~~~~~~~~~~~~ + + You could also omit the conditionally used extensions, as they are for information only, + but it is recommended to replicate them in `other-extensions` declarations. + `build-tools:` _program list_ : A list of programs, possibly annotated with versions, needed to build this package, e.g. `c2hs >= 0.15, cpphs`.If no version @@ -1363,12 +1392,33 @@ Options required only by one module may be specified by placing an `OPTIONS_GHC` pragma in the source file affected. + As with many other fields, whitespace can be escaped by using Haskell string + syntax. Example: `ghc-options: -Wcompat "-with-rtsopts=-T -I1" -Wall`. + `ghc-prof-options:` _token list_ : Additional options for GHC when the package is built with profiling enabled. + Note that as of Cabal-1.24, the default profiling detail level defaults to + `exported-functions` for libraries and `toplevel-functions` for + executables. For GHC these correspond to the flags `-fprof-auto-exported` + and `-fprof-auto-top`. Prior to Cabal-1.24 the level defaulted to `none`. + These levels can be adjusted by the person building the package with the + `--profiling-detail` and `--library-profiling-detail` flags. + + It is typically better for the person building the package to pick the + profiling detail level rather than for the package author. So unless you + have special needs it is probably better not to specify any of the GHC + `-fprof-auto*` flags here. However if you wish to override the profiling + detail level, you can do so using the `ghc-prof-options` field: use + `-fno-prof-auto` or one of the other `-fprof-auto*` flags. + + `ghc-shared-options:` _token list_ : Additional options for GHC when the package is built as shared library. + The options specified via this field are combined with the ones specified + via `ghc-options`, and are passed to GHC during both the compile and + link phases. `includes:` _filename list_ : A list of header files to be included in any compilations via C. @@ -1430,7 +1480,7 @@ parameters](#system-dependent-parameters)>. `pkgconfig-depends:` _package list_ -: A list of [pkg-config][] packages, needed to build this package. +: A list of [pkg-config] packages, needed to build this package. They can be annotated with versions, e.g. `gtk+-2.0 >= 2.10, cairo >= 1.0`. If no version constraint is specified, any version is assumed to be acceptable. Cabal uses `pkg-config` to find if the @@ -1447,6 +1497,10 @@ developer documentation for more details on frameworks. This entry is ignored on all other platforms. +`extra-frameworks-dirs:` _directory list_ +: On Darwin/MacOS X, a list of directories to search for frameworks. + This entry is ignored on all other platforms. + ### Configurations ### Library and executable sections may include conditional @@ -1687,15 +1741,15 @@ items, for example ~~~~~~~~~~~~~~~~ - Extensions: CPP + other-extensions: CPP if impl(ghc) - Extensions: MultiParamTypeClasses + other-extensions: MultiParamTypeClasses ~~~~~~~~~~~~~~~~ when compiled using GHC will be combined to ~~~~~~~~~~~~~~~~ - Extensions: CPP, MultiParamTypeClasses + other-extensions: CPP, MultiParamTypeClasses ~~~~~~~~~~~~~~~~ Similarly, if two conditional sections appear at the same nesting @@ -1872,6 +1926,21 @@ The `Paths_`_pkgname_ module is not platform independent so it does not get included in the source tarballs generated by `sdist`. +The `Paths_`_pkgname_ module also includes some other useful functions +and values, which record the version of the package and some other +directories which the package has been configured to be installed +into (e.g. data files live in `getDataDir`): + +~~~~~~~~~~~~~~~ +version :: Version + +getBinDir :: IO FilePath +getLibDir :: IO FilePath +getDataDir :: IO FilePath +getLibexecDir :: IO FilePath +getSysconfDir :: IO FilePath +~~~~~~~~~~~~~~~ + ### Accessing the package version ### The aforementioned auto generated `Paths_`_pkgname_ module also @@ -2144,3 +2213,4 @@ [Hackage]: http://hackage.haskell.org/ [pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/ [REPL]: http://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop +[PVP]: https://wiki.haskell.org/Package_versioning_policy diff --git a/doc/index.markdown b/doc/index.markdown --- a/doc/index.markdown +++ b/doc/index.markdown @@ -1,4 +1,5 @@ % Cabal User Guide +**Version: 1.24.0.0** Cabal is the standard package system for [Haskell] software. It helps people to configure, build and install Haskell software and to diff --git a/doc/installing-packages.markdown b/doc/installing-packages.markdown --- a/doc/installing-packages.markdown +++ b/doc/installing-packages.markdown @@ -1,5 +1,140 @@ % Cabal User Guide +# Configuration # + +## Overview ## + +The global configuration file for `cabal-install` is `~/.cabal/config`. If you +do not have this file, `cabal` will create it for you on the first call to +`cabal update`. Alternatively, you can explicitly ask `cabal` to create it for +you using + +> `cabal user-config update` + +Most of the options in this configuration file are also available as command +line arguments, and the corresponding documentation can be used to lookup their +meaning. The created configuration file only specifies values for a handful of +options. Most options are left at their default value, which it documents; +for instance, + +~~~~~~~~~~~~~~~~ +-- executable-stripping: True +~~~~~~~~~~~~~~~~ + +means that the configuration file currently does not specify a value for the +`executable-stripping` option (the line is commented out), and that the default +is `True`; if you wanted to disable stripping of executables by default, you +would change this line to + +~~~~~~~~~~~~~~~~ +executable-stripping: False +~~~~~~~~~~~~~~~~ + +You can also use `cabal user-config update` to migrate configuration files +created by older versions of `cabal`. + +## Repository specification ## + +An important part of the configuration if the specification of the repository. +When `cabal` creates a default config file, it configures the repository to +be the central Hackage server: + +~~~~~~~~~~~~~~~~ +repository hackage.haskell.org + url: http://hackage.haskell.org/ +~~~~~~~~~~~~~~~~ + +The name of the repository is given on the first line, and can be anything; +packages downloaded from this repository will be cached under +`~/.cabal/packages/hackage.haskell.org` (or whatever name you specify; you can +change the prefix by changing the value of `remote-repo-cache`). If you want, +you can configure multiple repositories, and `cabal` will combine them and be +able to download packages from any of them. + +### Using secure repositories ### + +For repositories that support the TUF security infrastructure (this includes +Hackage), you can enable secure access to the repository by specifying: + +~~~~~~~~~~~~~~~~ +repository hackage.haskell.org + url: http://hackage.haskell.org/ + secure: True + root-keys: + key-threshold: +~~~~~~~~~~~~~~~~ + +The `` and `` values are used for bootstrapping. As +part of the TUF infrastructure the repository will contain a file `root.json` +(for instance, +[http://hackage.haskell.org/root.json](http://hackage.haskell.org/root.json)) +which the client needs to do verification. However, how can `cabal` verify the +`root.json` file _itself_? This is known as bootstrapping: if you specify a list +of root key IDs and a corresponding threshold, `cabal` will verify that the +downloaded `root.json` file has been signed with at least `` +keys from your set of ``. + +You can, but are not recommended to, omit these two fields. In that case `cabal` +will download the `root.json` field and use it without verification. Although +this bootstrapping step is then unsafe, all subsequent access is secure +(provided that the downloaded `root.json` was not tempered with). Of course, +adding `root-keys` and `key-threshold` to your repository specification only +shifts the problem, because now you somehow need to make sure that the key IDs +you received were the right ones. How that is done is however outside the scope +of `cabal` proper. + +More information about the security infrastructure can be found at +[https://github.com/well-typed/hackage-security](https://github.com/well-typed/hackage-security). + +### Legacy repositories ### + +Currently `cabal` supports two kinds of “legacy” repositories. The +first is specified using + +~~~~~~~~~~~~~~~~ +remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive +~~~~~~~~~~~~~~~~ + +This is just syntactic sugar for + +~~~~~~~~~~~~~~~~ +repository hackage.haskell.org + url: hackage.haskell.org:http://hackage.haskell.org/packages/archive +~~~~~~~~~~~~~~~~ + +although, in (and only in) the specific case of Hackage, the URL +`http://hackage.haskell.org/packages/archive` will be silently translated to +`http://hackage.haskell.org/`. + +The second kind of legacy repositories are so-called “local” +repositories: + +~~~~~~~~~~~~~~~~ +local-repo: my-local-repo:/path/to/local/repo +~~~~~~~~~~~~~~~~ + +This can be used to access repositories on the local file system. However, the +layout of these local repositories is different from the layout of remote +repositories, and usage of these local repositories is deprecated. + +### Secure local repositories ### + +If you want to use repositories on your local file system, it is recommended +instead to use a _secure_ local repository: + +~~~~~~~~~~~~~~~~ +repository my-local-repo + url: file:/path/to/local/repo + secure: True + root-keys: + key-threshold: +~~~~~~~~~~~~~~~~ + +The layout of these secure local repos matches the layout of remote repositories +exactly; the +[hackage-repo-tool](http://hackage.haskell.org/package/hackage-repo-tool) can be +used to create and manage such repositories. + # Building and installing packages # After you've unpacked a Cabal package, you can build it by moving into @@ -610,6 +745,14 @@ be a file or directory. Not all implementations support arbitrary package databases. +`--default-user-config=` _file_ +: Allows a "default" `cabal.config` freeze file to be passed in + manually. This file will only be used if one does not exist in the + project directory already. Typically, this can be set from the global + cabal `config` file so as to provide a default set of partial + constraints to be used by projects, providing a way for users to peg + themselves to stable package collections. + `--enable-optimization`[=_n_] or `-O`[_n_] : (default) Build with optimization flags (if available). This is appropriate for production use, taking more time to build faster @@ -626,25 +769,81 @@ : Build without optimization. This is suited for development: building will be quicker, but the resulting library or programs will be slower. +`--enable-profiling` +: Build libraries and executables with profiling enabled (for compilers + that support profiling as a separate mode). For this to work, all + libraries used by this package must also have been built with profiling + support. For libraries this involves building an additional instance of + the library in addition to the normal non-profiling instance. For + executables it changes the single executable to be built in profiling mode. + + This flag covers both libraries and executables, but can be overridden + by the `--enable-library-profiling` flag. + + See also the `--profiling-detail` flag below. + +`--disable-profiling` +: (default) Do not enable profiling in generated libraries and executables. + `--enable-library-profiling` or `-p` -: Request that an additional version of the library with profiling - features enabled be built and installed (only for implementations - that support profiling). +: As with `--enable-profiling` above, but it applies only for libraries. So + this generates an additional profiling instance of the library in addition + to the normal non-profiling instance. + The `--enable-profiling` flag controls the profiling mode for both + libraries and executables, but if different modes are desired for + libraries versus executables then use `--enable-library-profiling` as well. + `--disable-library-profiling` : (default) Do not generate an additional profiling version of the library. -`--enable-profiling` -: Any executables generated should have profiling enabled (only for - implementations that support profiling). For this to work, all - libraries used by these executables must also have been built with - profiling support. The library will be built with profiling enabled (if - supported) unless `--disable-library-profiling` is specified. +`--profiling-detail`[=_level_] +: Some compilers that support profiling, notably GHC, can allocate costs to + different parts of the program and there are different levels of + granularity or detail with which this can be done. In particular for GHC + this concept is called "cost centers", and GHC can automatically add cost + centers, and can do so in different ways. -`--disable-profiling` -: (default) Do not enable profiling in generated executables. + This flag covers both libraries and executables, but can be overridden + by the `--library-profiling-detail` flag. + Currently this setting is ignored for compilers other than GHC. The levels + that cabal currently supports are: + + `default` + : For GHC this uses `exported-functions` for libraries and + `toplevel-functions` for executables. + + `none` + : No costs will be assigned to any code within this component. + + `exported-functions` + : Costs will be assigned at the granularity of all top level functions + exported from each module. In GHC specifically, this is for non-inline + functions. + + `toplevel-functions` + : Costs will be assigned at the granularity of all top level functions + in each module, whether they are exported from the module or not. + In GHC specifically, this is for non-inline functions. + + `all-functions` + : Costs will be assigned at the granularity of all functions in each + module, whether top level or local. In GHC specifically, this is for + non-inline toplevel or where-bound functions or values. + + This flag is new in Cabal-1.24. Prior versions used the equivalent of + `none` above. + +`--library-profiling-detail`[=_level_] +: As with `--profiling-detail` above, but it applies only for libraries. + + The level for both libraries and executables is set by the + `--profiling-detail` flag, but if different levels are desired for + libraries versus executables then use `--library-profiling-detail` as well. + + `--enable-library-vanilla` : (default) Build ordinary libraries (as opposed to profiling libraries). This is independent of the `--enable-library-profiling` @@ -733,6 +932,10 @@ : An extra directory to search for system libraries files. You can use this flag multiple times to get a list of directories. +`--extra-framework-dirs`[=_dir_] +: An extra directory to search for frameworks (OS X only). You can use this + flag multiple times to get a list of directories. + You might need to use this flag if you have standard system libraries in a non-standard location that is not mentioned in the package's `.cabal` file. Using this option has the same affect as @@ -779,8 +982,26 @@ $ cabal install --allow-newer=bar --constraint="bar==2.1" foo ~~~~~~~~~~~~~~~~ - It's also possible to enable `--allow-newer` permanently by setting - `allow-newer: True` in the `~/.cabal/config` file. + It's also possible to limit the scope of `--allow-newer` to single + packages with the `--allow-newer=scope:dep` syntax. This means that the + dependency on `dep` will be relaxed only for the package `scope`. + + Example: + + ~~~~~~~~~~~~~~~~ + # Relax upper bound in foo's dependency on base; also relax upper bound in + # every package's dependency on lens. + $ cabal install --allow-newer=foo:base,lens + + # Relax upper bounds in foo's dependency on base and bar's dependency + # on time; also relax the upper bound in the dependency on lens specified by + # any package. + $ cabal install --allow-newer=foo:base,lens --allow-newer=bar:time + ~~~~~~~~~~~~~~~~ + + Finally, one can enable `--allow-newer` permanently by setting `allow-newer: + True` in the `~/.cabal/config` file. Enabling 'allow-newer' selectively is + also supported in the config file (`allow-newer: foo, bar, baz:base`). `--constraint=`_constraint_ : Restrict solutions involving a package to a given version range. diff --git a/tests/PackageTests.hs b/tests/PackageTests.hs --- a/tests/PackageTests.hs +++ b/tests/PackageTests.hs @@ -6,167 +6,278 @@ module Main where -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.DeterministicAr.Check -import PackageTests.EmptyLib.Check -import PackageTests.Haddock.Check -import PackageTests.TestOptions.Check -import PackageTests.TestStanza.Check -import PackageTests.TestSuiteExeV10.Check -import PackageTests.OrderFlags.Check -import PackageTests.ReexportedModules.Check +import PackageTests.Options +import PackageTests.PackageTester +import PackageTests.Tests import Distribution.Simple.Configure - ( ConfigStateFileError(..), getConfigStateFile ) + ( ConfigStateFileError(..), findDistPrefOrDefault, getConfigStateFile + , interpretPackageDbFlags ) +import Distribution.Simple.Compiler (PackageDB(..), PackageDBStack) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) -import Distribution.Simple.Program.Types (programPath) +import Distribution.Simple.Program.Types (Program(..), programPath, programVersion) import Distribution.Simple.Program.Builtin ( ghcProgram, ghcPkgProgram, haddockProgram ) import Distribution.Simple.Program.Db (requireProgram) +import Distribution.Simple.Setup (Flag(..), readPackageDbList, showPackageDbList) import Distribution.Simple.Utils (cabalVersion) -import Distribution.Text (display) -import Distribution.Verbosity (normal) -import Distribution.Version (Version(Version)) +import Distribution.Text (display, simpleParse) +import Distribution.Verbosity (normal, flagToVerbosity) +import Distribution.ReadE (readEOrFail) -import Control.Exception (try, throw) +import Control.Exception +import Data.Proxy ( Proxy(..) ) +import Distribution.Compat.Environment ( lookupEnv ) import System.Directory - ( getCurrentDirectory, setCurrentDirectory ) -import System.FilePath (()) -import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout) -import Test.Framework (Test, TestName, defaultMain, testGroup) -import Test.Framework.Providers.HUnit (hUnitTestToTests) -import qualified Test.HUnit as HUnit - - -hunit :: TestName -> HUnit.Test -> Test -hunit name test = testGroup name $ hUnitTestToTests test +import Test.Tasty +import Test.Tasty.Options +import Test.Tasty.Ingredients +import Data.Maybe -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. - , testGroup "TestSuiteExeV10" (PackageTests.TestSuiteExeV10.Check.checks 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 "PathsModule/Executable" - (PackageTests.PathsModule.Executable.Check.suite ghcPath) - , hunit "PathsModule/Library" (PackageTests.PathsModule.Library.Check.suite ghcPath) - , hunit "DeterministicAr" - (PackageTests.DeterministicAr.Check.suite ghcPath ghcPkgPath) - , hunit "EmptyLib/emptyLib" - (PackageTests.EmptyLib.Check.emptyLib ghcPath) - , hunit "Haddock" (PackageTests.Haddock.Check.suite ghcPath) - , hunit "BuildTestSuiteDetailedV09" - (PackageTests.BuildTestSuiteDetailedV09.Check.suite inplaceSpec ghcPath) - , hunit "OrderFlags" - (PackageTests.OrderFlags.Check.suite ghcPath) - , hunit "TemplateHaskell/dynamic" - (PackageTests.TemplateHaskell.Check.dynamic ghcPath) - , hunit "ReexportedModules" - (PackageTests.ReexportedModules.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 []) +#if MIN_VERSION_base(4,6,0) +import System.Environment ( getExecutablePath ) +#endif main :: IO () main = do - -- WORKAROUND: disable buffering on stdout to get streaming test logs - -- test providers _should_ do this themselves - hSetBuffering stdout NoBuffering + -- In abstract, the Cabal test suite makes calls to the "Setup" + -- executable and tests the output of Cabal. However, we have to + -- responsible for building this executable in the first place, + -- since (1) Cabal doesn't support a test-suite depending on an + -- executable, so we can't put a "Setup" executable in the Cabal + -- file and then depend on it, (2) we don't want to call the Cabal + -- functions *directly* because we need to capture and save the + -- stdout and stderr, and (3) even if we could do all that, we will + -- want to test some Custom setup scripts, which will be specific to + -- the test at hand and need to be compiled against Cabal. + -- + -- To be able to build the executable, there is some information + -- we need: + -- + -- 1. We need to know what ghc to use, + -- + -- 2. We need to know what package databases (plural!) contain + -- all of the necessary dependencies to make our Cabal package + -- well-formed. + -- + -- We could have the user pass these all in as arguments (TODO: this + -- should be an option), but there's a more convenient way to get + -- this information: the *build configuration* that was used to + -- build the Cabal library (and this test suite) in the first place. + -- To do this, we need to find the 'dist' directory that was set as + -- the build directory for Cabal. - wd <- getCurrentDirectory - let dbFile = wd "dist/package.conf.inplace" - inplaceSpec = PackageSpec - { directory = [] - , configOpts = [ "--package-db=" ++ dbFile - , "--constraint=Cabal == " ++ display cabalVersion - ] - , distPref = Nothing - } - 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) - (haddock, _) <- requireProgram normal haddockProgram (withPrograms lbi) - let ghcPath = programPath ghc - ghcPkgPath = programPath ghcPkg - haddockPath = programPath haddock - putStrLn $ "Using ghc: " ++ ghcPath - putStrLn $ "Using ghc-pkg: " ++ ghcPkgPath - putStrLn $ "Using haddock: " ++ haddockPath - setCurrentDirectory "tests" + dist_dir <- guessDistDir + -- Might be bottom, if we can't figure it out. If you override + -- all the relevant parameters you might still succeed. + lbi <- getPersistBuildConfig_ (dist_dir "setup-config") + + -- You need to run the test suite in the right directory, sorry. + test_dir <- getCurrentDirectory + + -- Pull out the information we need from the LBI + -- TODO: The paths to GHC are configurable by command line, but you + -- have to be careful: some tests might depend on the Cabal library, + -- in which case you REALLY need to have built and installed Cabal + -- for the version that the test suite is being built against. The + -- easiest thing to do is make sure you built Cabal the same way as + -- you will run the tests. + let getExePathFromEnvOrLBI env_name prog = do + r <- lookupEnv env_name + case r of + Nothing -> do + (conf, _) <- requireProgram normal prog (withPrograms lbi) + return (programPath conf) + Just x -> return x + -- It is too much damn work to actually properly configure it + -- (Cabal will go off and probe GHC and we really aren't keen + -- on doing this every time we run the test suite.) + ghc_path <- getExePathFromEnvOrLBI "CABAL_PACKAGETESTS_GHC" ghcProgram + ghc_pkg_path <- getExePathFromEnvOrLBI "CABAL_PACKAGETESTS_GHC_PKG" + ghcPkgProgram + haddock_path <- getExePathFromEnvOrLBI "CABAL_PACKAGETESTS_HADDOCK" + haddockProgram + + with_ghc_path <- fromMaybe ghc_path + `fmap` lookupEnv "CABAL_PACKAGETESTS_WITH_GHC" + + ghc_version_env <- lookupEnv "CABAL_PACKAGETESTS_GHC_VERSION" + ghc_version <- case ghc_version_env of + Nothing -> do + (ghcConf, _) <- requireProgram normal ghcProgram (withPrograms lbi) + return (fromJust (programVersion ghcConf)) + Just str -> + return (fromJust (simpleParse str)) + + with_ghc_version <- do + version <- programFindVersion ghcProgram normal with_ghc_path + case version of + Nothing -> error "Cannot determine version of GHC used for --with-ghc" + Just v -> return v + + -- Package DBs are not guaranteed to be absolute, so make them so in + -- case a subprocess using the package DB needs a different CWD. + db_stack_env <- lookupEnv "CABAL_PACKAGETESTS_DB_STACK" + let packageDBStack0 = case db_stack_env of + Nothing -> withPackageDB lbi + Just str -> interpretPackageDbFlags True -- user install? why not. + (concatMap readPackageDbList + (splitSearchPath str)) + packageDBStack1 <- mapM canonicalizePackageDB packageDBStack0 + + -- The packageDBStack is worth some commentary. The database + -- stack we extract from the LBI will contain enough package + -- databases to make the Cabal package well-formed. However, + -- it does not *contain* the inplace installed Cabal package. + -- So we need to add that to the stack. + let packageDBStack2 + = packageDBStack1 ++ + [SpecificPackageDB + (dist_dir "package.conf.inplace")] + + -- THIS ISN'T EVEN MY FINAL FORM. The package database stack + -- controls where we install a package; specifically, the package is + -- installed to the top-most package on the stack (this makes the + -- most sense, since it could depend on any of the packages below + -- it.) If the test wants to register anything (as opposed to just + -- working in place), then we need to have another temporary + -- database we can install into (and not accidentally clobber any of + -- the other stacks.) This is done on a per-test basis. + -- + -- ONE MORE THING. On the subject of installing the package (with + -- copy/register) it is EXTREMELY important that we also overload + -- the install directories, so we don't clobber anything in the + -- default install paths. VERY IMPORTANT. + + -- TODO: make this controllable by a flag + verbosity <- maybe normal (readEOrFail flagToVerbosity) + `fmap` lookupEnv "VERBOSE" + -- The inplaceDB is where the Cabal library was registered + -- in place (and is usable.) inplaceConfig is a convenient + -- set of flags to make sure we make it visible. + let suite = SuiteConfig + { cabalDistPref = dist_dir + , ghcPath = ghc_path + , ghcVersion = ghc_version + , ghcPkgPath = ghc_pkg_path + , withGhcPath = with_ghc_path + , withGhcVersion = with_ghc_version + , packageDBStack = packageDBStack2 + , suiteVerbosity = verbosity + , absoluteCWD = test_dir + } + + putStrLn $ "Cabal test suite - testing cabal version " + ++ display cabalVersion + putStrLn $ "Cabal build directory: " ++ dist_dir + putStrLn $ "Test directory: " ++ test_dir + -- TODO: it might be useful to factor this out so that ./Setup + -- configure dumps this file, so we can read it without in a version + -- stable way. + putStrLn $ "Environment:" + putStrLn $ "CABAL_PACKAGETESTS_GHC=" ++ show ghc_path ++ " \\" + putStrLn $ "CABAL_PACKAGETESTS_GHC_VERSION=" + ++ show (display ghc_version) ++ " \\" + putStrLn $ "CABAL_PACKAGETESTS_GHC_PKG=" ++ show ghc_pkg_path ++ " \\" + putStrLn $ "CABAL_PACKAGETESTS_WITH_GHC=" ++ show with_ghc_path ++ " \\" + putStrLn $ "CABAL_PACKAGETESTS_HADDOCK=" ++ show haddock_path ++ " \\" + -- For brevity, do pre-canonicalization + putStrLn $ "CABAL_PACKAGETESTS_DB_STACK=" ++ + show (intercalate [searchPathSeparator] + (showPackageDbList (uninterpretPackageDBFlags + packageDBStack0))) + -- Create a shared Setup executable to speed up Simple tests - compileSetup "." ghcPath - defaultMain (tests cabalVersion inplaceSpec ghcPath ghcPkgPath) + putStrLn $ "Building shared ./Setup executable" + rawCompileSetup verbosity suite [] "tests" --- Like Distribution.Simple.Configure.getPersistBuildConfig but + defaultMainWithIngredients options $ + runTestTree "Package Tests" (tests suite) + +-- Reverse of 'interpretPackageDbFlags'. +-- prop_idem stk b +-- = interpretPackageDbFlags b (uninterpretPackageDBFlags stk) == stk +uninterpretPackageDBFlags :: PackageDBStack -> [Maybe PackageDB] +uninterpretPackageDBFlags stk = Nothing : map (\x -> Just x) stk + +-- | Guess what the 'dist' directory Cabal was installed in is. There's +-- no 100% reliable way to find this, but there are a few good shots: +-- +-- 1. Test programs are ~always built in-place, in a directory +-- that looks like dist/build/package-tests/package-tests; +-- thus the directory can be determined by looking at $0. +-- This method is robust against sandboxes, Nix local +-- builds, and Stack, but doesn't work if you're running +-- in an interpreter. +-- +-- 2. We can use the normal input methods (as per Cabal), +-- checking for the CABAL_BUILDDIR environment variable as +-- well as the default location in the current working directory. +-- +-- NB: If you update this, also update its copy in cabal-install's +-- IntegrationTests +guessDistDir :: IO FilePath +guessDistDir = do +#if MIN_VERSION_base(4,6,0) + -- Method (1) + -- TODO: this needs to be BC'ified, probably. + exe_path <- canonicalizePath =<< getExecutablePath + -- exe_path is something like /path/to/dist/build/package-tests/package-tests + let dist0 = dropFileName exe_path ".." ".." + b <- doesFileExist (dist0 "setup-config") +#else + let dist0 = error "no path" + b = False +#endif + -- Method (2) + if b then canonicalizePath dist0 + else findDistPrefOrDefault NoFlag >>= canonicalizePath + +canonicalizePackageDB :: PackageDB -> IO PackageDB +canonicalizePackageDB (SpecificPackageDB path) + = SpecificPackageDB `fmap` canonicalizePath path +canonicalizePackageDB x = return x + +-- | 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. +-- Here's the situation: +-- +-- 1. There's some system Cabal-1.0 installed. We use this +-- to build Setup.hs +-- 2. We run ./Setup configure, which uses Cabal-1.0 to +-- write out the LocalBuildInfo +-- 3. We build the Cabal library, whose version is Cabal-2.0 +-- 4. We build the package-tests executable, which LINKS AGAINST +-- Cabal-2.0 +-- 5. We try to read the LocalBuildInfo that ./Setup configure +-- wrote out, but it's Cabal-1.0 format! +-- +-- It's a bit skeevy that we're trying to read Cabal-1.0 LocalBuildInfo +-- using Cabal-2.0's parser, but this seems to work OK in practice +-- because LocalBuildInfo is a slow-moving data structure. If +-- we ever make a major change, this won't work, and we'll have to +-- take a different approach (either setting "build-type: Custom" +-- so we bootstrap with the most recent Cabal, or by writing the +-- information we need in another format.) getPersistBuildConfig_ :: FilePath -> IO LocalBuildInfo getPersistBuildConfig_ filename = do eLBI <- try $ getConfigStateFile filename case eLBI of Left (ConfigStateFileBadVersion _ _ (Right lbi)) -> return lbi - Left (ConfigStateFileBadVersion _ _ (Left err)) -> throw err - Left err -> throw err + -- These errors are lazy! We might not need these parameters. + Left (ConfigStateFileBadVersion _ _ (Left err)) + -> return . error $ + "We couldn't understand the build configuration. Try " ++ + "editing Cabal.cabal to have 'build-type: Custom' " ++ + "and then rebuilding, or manually specifying CABAL_PACKAGETESTS_* " ++ + "environment variables (see README.md for more details)." ++ + "\n\nOriginal error: " ++ + show err + Left err -> return (throw err) Right lbi -> return lbi + +options :: [Ingredient] +options = includingOptions + [Option (Proxy :: Proxy OptionEnableAllTests)] : + defaultIngredients diff --git a/tests/PackageTests/AllowNewer/AllowNewer.cabal b/tests/PackageTests/AllowNewer/AllowNewer.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/AllowNewer/AllowNewer.cabal @@ -0,0 +1,25 @@ +name: AllowNewer +version: 0.1.0.0 +license: BSD3 +author: Foo Bar +maintainer: cabal-dev@haskell.org +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Foo + hs-source-dirs: src + build-depends: base < 1 + default-language: Haskell2010 + +test-suite foo-test + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: tests + build-depends: base < 1 + +benchmark foo-bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + hs-source-dirs: benchmarks + build-depends: base < 1 diff --git a/tests/PackageTests/AllowNewer/benchmarks/Bench.hs b/tests/PackageTests/AllowNewer/benchmarks/Bench.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/AllowNewer/benchmarks/Bench.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/PackageTests/AllowNewer/src/Foo.hs b/tests/PackageTests/AllowNewer/src/Foo.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/AllowNewer/src/Foo.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/PackageTests/AllowNewer/tests/Test.hs b/tests/PackageTests/AllowNewer/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/AllowNewer/tests/Test.hs @@ -0,0 +1,4 @@ +!module Main where + +main :: IO () +main = return () diff --git a/tests/PackageTests/BenchmarkExeV10/Check.hs b/tests/PackageTests/BenchmarkExeV10/Check.hs deleted file mode 100644 --- a/tests/PackageTests/BenchmarkExeV10/Check.hs +++ /dev/null @@ -1,16 +0,0 @@ -module PackageTests.BenchmarkExeV10.Check - ( checkBenchmark - ) where - -import PackageTests.PackageTester -import System.FilePath -import Test.HUnit - -dir :: FilePath -dir = "PackageTests" "BenchmarkExeV10" - -checkBenchmark :: FilePath -> Test -checkBenchmark ghcPath = TestCase $ do - let spec = PackageSpec dir Nothing ["--enable-benchmarks"] - buildResult <- cabal_build spec ghcPath - assertBuildSucceeded buildResult diff --git a/tests/PackageTests/BenchmarkOptions/Check.hs b/tests/PackageTests/BenchmarkOptions/Check.hs deleted file mode 100644 --- a/tests/PackageTests/BenchmarkOptions/Check.hs +++ /dev/null @@ -1,26 +0,0 @@ -module PackageTests.BenchmarkOptions.Check where - -import PackageTests.PackageTester -import System.FilePath -import Test.HUnit - -suite :: FilePath -> Test -suite ghcPath = TestCase $ do - let spec = PackageSpec - { directory = "PackageTests" "BenchmarkOptions" - , configOpts = ["--enable-benchmarks"] - , distPref = Nothing - } - _ <- 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 - result' <- cabal_bench spec [ "--benchmark-option=1" - , "--benchmark-option=2" - , "--benchmark-option=3" - ] - 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/BenchmarkStanza/Check.hs b/tests/PackageTests/BenchmarkStanza/Check.hs --- a/tests/PackageTests/BenchmarkStanza/Check.hs +++ b/tests/PackageTests/BenchmarkStanza/Check.hs @@ -1,52 +1,30 @@ module PackageTests.BenchmarkStanza.Check where -import Test.HUnit -import System.FilePath -import qualified Data.Map as Map import PackageTests.PackageTester + import Distribution.Version -import Distribution.PackageDescription.Parse - ( readPackageDescription ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) +import Distribution.Simple.LocalBuildInfo import Distribution.Package - ( PackageName(..), Dependency(..) ) import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), Benchmark(..) - , BenchmarkInterface(..) - , emptyBuildInfo - , emptyBenchmark, defaultRenaming ) -import Distribution.Verbosity (silent) -import Distribution.System (buildPlatform) -import Distribution.Compiler - ( CompilerId(..), CompilerFlavor(..), unknownCompilerInfo, AbiTag(..) ) -import Distribution.Text -suite :: FilePath -> Test -suite ghcPath = TestCase $ do - let dir = "PackageTests" "BenchmarkStanza" - pdFile = dir "my" <.> "cabal" - spec = PackageSpec { directory = dir, configOpts = [], distPref = Nothing } - result <- cabal_configure spec ghcPath - assertOutputDoesNotContain "unknown section type" result - genPD <- readPackageDescription silent pdFile - let compiler = unknownCompilerInfo (CompilerId GHC $ Version [6, 12, 2] []) NoAbiTag - anticipatedBenchmark = emptyBenchmark +suite :: TestM () +suite = do + assertOutputDoesNotContain "unknown section type" + =<< cabal' "configure" [] + dist_dir <- distDir + lbi <- liftIO $ getPersistBuildConfig dist_dir + let anticipatedBenchmark = emptyBenchmark { benchmarkName = "dummy" - , benchmarkInterface = BenchmarkExeV10 (Version [1,0] []) "dummy.hs" + , benchmarkInterface = BenchmarkExeV10 (Version [1,0] []) + "dummy.hs" , benchmarkBuildInfo = emptyBuildInfo { targetBuildDepends = [ Dependency (PackageName "base") anyVersion ] - , targetBuildRenaming = - Map.singleton (PackageName "base") defaultRenaming , hsSourceDirs = ["."] } , benchmarkEnabled = False } - case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of - Left xs -> let depMessage = "should not have missing dependencies:\n" ++ - (unlines $ map (show . disp) xs) - in assertEqual depMessage True False - Right (f, _) -> let gotBenchmark = head $ benchmarks f - in assertEqual "parsed benchmark stanza does not match anticipated" - gotBenchmark anticipatedBenchmark + gotBenchmark = head $ benchmarks (localPkgDescr lbi) + assertEqual "parsed benchmark stanza does not match anticipated" + anticipatedBenchmark gotBenchmark + return () diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs deleted file mode 100644 --- a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs +++ /dev/null @@ -1,22 +0,0 @@ -module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List -import Control.Exception -import Prelude hiding (catch) - - -suite :: FilePath -> Test -suite ghcPath = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive1") [] - 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'" - assertBool ("cabal output should be "++show sb) $ - sb `isInfixOf` outputText result - `catch` \exc -> do - putStrLn $ "Cabal result was "++show result - throwIO (exc :: SomeException) diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal --- a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal @@ -17,4 +17,4 @@ Library exposed-modules: MyLibrary - build-depends: bytestring, old-time + build-depends: bytestring, pretty diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs --- a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs @@ -1,10 +1,10 @@ module MyLibrary where import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - getClockTime + putStrLn (render (text "foo")) let text = "myLibFunc" C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs deleted file mode 100644 --- a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs +++ /dev/null @@ -1,22 +0,0 @@ -module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List -import Control.Exception -import Prelude hiding (catch) - - -suite :: FilePath -> Test -suite ghcPath = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive2") [] - 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'" - assertBool ("cabal output should be "++show sb) $ - sb `isInfixOf` outputText result - `catch` \exc -> do - putStrLn $ "Cabal result was "++show result - throwIO (exc :: SomeException) diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal --- a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal @@ -17,4 +17,4 @@ Executable lemon main-is: lemon.hs - build-depends: bytestring, old-time + build-depends: bytestring, pretty diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs --- a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs @@ -1,7 +1,7 @@ import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint main = do - getClockTime + putStrLn (render (text "foo")) let text = "lemon" C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs deleted file mode 100644 --- a/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs +++ /dev/null @@ -1,22 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary0.Check where - -import Control.Monad -import Data.Version -import PackageTests.PackageTester -import System.FilePath -import Test.HUnit - - -suite :: Version -> FilePath -> Test -suite cabalVersion ghcPath = TestCase $ do - let spec = PackageSpec - { directory = "PackageTests" "BuildDeps" "InternalLibrary0" - , configOpts = [] - , distPref = Nothing - } - 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 --- a/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs @@ -1,10 +1,10 @@ module MyLibrary where import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - getClockTime + putStrLn (render (text "foo")) let text = "myLibFunc" C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal --- a/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal +++ b/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal @@ -16,9 +16,9 @@ Library exposed-modules: MyLibrary - build-depends: base, bytestring, old-time + build-depends: base, bytestring, pretty Executable lemon main-is: lemon.hs hs-source-dirs: programs - build-depends: base, bytestring, old-time, InternalLibrary0 + build-depends: base, bytestring, pretty, InternalLibrary0 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs b/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs --- a/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs @@ -1,6 +1,6 @@ -import System.Time +import Text.PrettyPrint import MyLibrary main = do - getClockTime + putStrLn (render (text "foo")) myLibFunc diff --git a/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs deleted file mode 100644 --- a/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs +++ /dev/null @@ -1,16 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary1.Check where - -import PackageTests.PackageTester -import System.FilePath -import Test.HUnit - - -suite :: FilePath -> Test -suite ghcPath = TestCase $ do - let spec = PackageSpec - { directory = "PackageTests" "BuildDeps" "InternalLibrary1" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build spec ghcPath - assertBuildSucceeded result diff --git a/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs b/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs --- a/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs @@ -1,10 +1,10 @@ module MyLibrary where import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - getClockTime + putStrLn (render (text "foo")) let text = "myLibFunc" C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal --- a/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal +++ b/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal @@ -15,9 +15,9 @@ Library exposed-modules: MyLibrary - build-depends: base, bytestring, old-time + build-depends: base, bytestring, pretty Executable lemon main-is: lemon.hs hs-source-dirs: programs - build-depends: base, bytestring, old-time, InternalLibrary1 + build-depends: base, bytestring, pretty, InternalLibrary1 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs b/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs --- a/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs @@ -1,6 +1,6 @@ -import System.Time +import Text.PrettyPrint import MyLibrary main = do - getClockTime + putStrLn (render (text "foo")) myLibFunc diff --git a/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs deleted file mode 100644 --- a/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs +++ /dev/null @@ -1,32 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary2.Check where - -import qualified Data.ByteString.Char8 as C -import PackageTests.PackageTester -import System.FilePath -import Test.HUnit - - -suite :: FilePath -> FilePath -> Test -suite ghcPath ghcPkgPath = TestCase $ do - let spec = PackageSpec - { directory = "PackageTests" "BuildDeps" "InternalLibrary2" - , configOpts = [] - , distPref = Nothing - } - let specTI = PackageSpec - { directory = directory spec "to-install" - , configOpts = [] - , distPref = Nothing - } - - 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) (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 --- a/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs @@ -1,10 +1,10 @@ module MyLibrary where import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - getClockTime + putStrLn (render (text "foo")) 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 --- a/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal @@ -15,9 +15,9 @@ Library exposed-modules: MyLibrary - build-depends: base, bytestring, old-time + build-depends: base, bytestring, pretty Executable lemon main-is: lemon.hs hs-source-dirs: programs - build-depends: base, bytestring, old-time, InternalLibrary2 + build-depends: base, bytestring, pretty, InternalLibrary2 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs b/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs --- a/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs @@ -1,6 +1,6 @@ -import System.Time +import Text.PrettyPrint import MyLibrary main = do - getClockTime + putStrLn (render (text "foo")) myLibFunc diff --git a/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs b/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs --- a/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs @@ -1,10 +1,10 @@ module MyLibrary where import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - getClockTime + putStrLn (render (text "foo")) 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 --- a/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal @@ -15,4 +15,4 @@ Library exposed-modules: MyLibrary - build-depends: base, bytestring, old-time + build-depends: base, bytestring, pretty diff --git a/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs deleted file mode 100644 --- a/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs +++ /dev/null @@ -1,32 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary3.Check where - -import qualified Data.ByteString.Char8 as C -import PackageTests.PackageTester -import System.FilePath -import Test.HUnit - - -suite :: FilePath -> FilePath -> Test -suite ghcPath ghcPkgPath = TestCase $ do - let spec = PackageSpec - { directory = "PackageTests" "BuildDeps" "InternalLibrary3" - , configOpts = [] - , distPref = Nothing - } - let specTI = PackageSpec - { directory = directory spec "to-install" - , configOpts = [] - , distPref = Nothing - } - - 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) (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 --- a/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs @@ -1,10 +1,10 @@ module MyLibrary where import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - getClockTime + putStrLn (render (text "foo")) 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 --- a/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal @@ -15,9 +15,9 @@ Library exposed-modules: MyLibrary - build-depends: base, bytestring, old-time + build-depends: base, bytestring, pretty Executable lemon main-is: lemon.hs hs-source-dirs: programs - build-depends: base, bytestring, old-time, InternalLibrary3 + build-depends: base, bytestring, pretty, InternalLibrary3 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs b/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs --- a/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs @@ -1,6 +1,6 @@ -import System.Time +import Text.PrettyPrint import MyLibrary main = do - getClockTime + putStrLn (render (text "foo")) myLibFunc diff --git a/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs b/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs --- a/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs @@ -1,10 +1,10 @@ module MyLibrary where import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - getClockTime + putStrLn (render (text "foo")) 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 --- a/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal @@ -15,4 +15,4 @@ Library exposed-modules: MyLibrary - build-depends: base, bytestring, old-time + build-depends: base, bytestring, pretty diff --git a/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs deleted file mode 100644 --- a/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs +++ /dev/null @@ -1,32 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary4.Check where - -import qualified Data.ByteString.Char8 as C -import PackageTests.PackageTester -import System.FilePath -import Test.HUnit - - -suite :: FilePath -> FilePath -> Test -suite ghcPath ghcPkgPath = TestCase $ do - let spec = PackageSpec - { directory = "PackageTests" "BuildDeps" "InternalLibrary4" - , configOpts = [] - , distPref = Nothing - } - let specTI = PackageSpec - { directory = directory spec "to-install" - , configOpts = [] - , distPref = Nothing - } - - 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) (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 --- a/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs @@ -1,10 +1,10 @@ module MyLibrary where import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - getClockTime + putStrLn (render (text "foo")) 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 --- a/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal @@ -15,9 +15,9 @@ Library exposed-modules: MyLibrary - build-depends: base, bytestring, old-time + build-depends: base, bytestring, pretty Executable lemon main-is: lemon.hs hs-source-dirs: programs - build-depends: base, bytestring, old-time, InternalLibrary4 >= 0.2 + build-depends: base, bytestring, pretty, InternalLibrary4 >= 0.2 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs b/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs --- a/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs @@ -1,6 +1,6 @@ -import System.Time +import Text.PrettyPrint import MyLibrary main = do - getClockTime + putStrLn (render (text "foo")) myLibFunc diff --git a/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs b/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs --- a/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs @@ -1,10 +1,10 @@ module MyLibrary where import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - getClockTime + putStrLn (render (text "foo")) 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 --- a/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal @@ -15,4 +15,4 @@ Library exposed-modules: MyLibrary - build-depends: base, bytestring, old-time + build-depends: base, bytestring, pretty diff --git a/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs b/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs deleted file mode 100644 --- a/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs +++ /dev/null @@ -1,21 +0,0 @@ -module PackageTests.BuildDeps.SameDepsAllRound.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import qualified Control.Exception as E - - -suite :: FilePath -> Test -suite ghcPath = TestCase $ do - let spec = PackageSpec - { directory = "PackageTests" "BuildDeps" "SameDepsAllRound" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build spec ghcPath - do - assertEqual "cabal build should succeed - see test-log.txt" True (successful result) - `E.catch` \exc -> do - putStrLn $ "Cabal result was "++show result - E.throwIO (exc :: E.SomeException) diff --git a/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs b/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs --- a/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs +++ b/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs @@ -1,10 +1,10 @@ module MyLibrary where import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - getClockTime + putStrLn (render (text "foo")) let text = "myLibFunc" C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal b/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal --- a/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal +++ b/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal @@ -25,7 +25,7 @@ Executable lemon main-is: lemon.hs - build-depends: old-time + build-depends: pretty Executable pineapple main-is: pineapple.hs diff --git a/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs b/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs --- a/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs +++ b/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs @@ -1,7 +1,7 @@ import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint main = do - getClockTime + putStrLn (render (text "foo")) let text = "lemon" C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs b/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs --- a/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs +++ b/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs @@ -1,7 +1,7 @@ import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint main = do - getClockTime + putStrLn (render (text "foo")) let text = "pineapple" C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs deleted file mode 100644 --- a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs +++ /dev/null @@ -1,29 +0,0 @@ -module PackageTests.BuildDeps.TargetSpecificDeps1.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List -import qualified Control.Exception as E -import Text.Regex.Posix - - -suite :: FilePath -> Test -suite ghcPath = TestCase $ do - let spec = PackageSpec - { directory = "PackageTests" "BuildDeps" "TargetSpecificDeps1" - , configOpts = [] - , distPref = Nothing - } - 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\"" $ - (intercalate " " $ lines $ outputText result) - =~ "Could not find module.*System.Time" - - `E.catch` \exc -> do - putStrLn $ "Cabal result was "++show result - E.throwIO (exc :: E.SomeException) diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs --- a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs @@ -1,10 +1,10 @@ module MyLibrary where import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - getClockTime + putStrLn (render (text "foo")) let text = "myLibFunc" C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs --- a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs @@ -1,7 +1,7 @@ import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint main = do - getClockTime + putStrLn (render (text "foo")) let text = "lemon" C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal --- a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal @@ -19,4 +19,4 @@ Executable lemon main-is: lemon.hs - build-depends: base, bytestring, old-time + build-depends: base, bytestring, pretty diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs deleted file mode 100644 --- a/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs +++ /dev/null @@ -1,21 +0,0 @@ -module PackageTests.BuildDeps.TargetSpecificDeps2.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import qualified Control.Exception as E - - -suite :: FilePath -> Test -suite ghcPath = TestCase $ do - let spec = PackageSpec - { directory = "PackageTests" "BuildDeps" "TargetSpecificDeps2" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build spec ghcPath - do - assertEqual "cabal build should succeed - see test-log.txt" True (successful result) - `E.catch` \exc -> do - putStrLn $ "Cabal result was "++show result - E.throwIO (exc :: E.SomeException) diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs --- a/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs @@ -1,10 +1,10 @@ module MyLibrary where import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - getClockTime + putStrLn (render (text "foo")) let text = "myLibFunc" C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal --- a/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal @@ -17,7 +17,7 @@ Library exposed-modules: MyLibrary - build-depends: base, bytestring, old-time + build-depends: base, bytestring, pretty Executable lemon main-is: lemon.hs diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs deleted file mode 100644 --- a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs +++ /dev/null @@ -1,28 +0,0 @@ -module PackageTests.BuildDeps.TargetSpecificDeps3.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List -import qualified Control.Exception as E -import Text.Regex.Posix - - -suite :: FilePath -> Test -suite ghcPath = TestCase $ do - let spec = PackageSpec - { directory = "PackageTests" "BuildDeps" "TargetSpecificDeps3" - , configOpts = [] - , distPref = Nothing - } - 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\"" $ - (intercalate " " $ lines $ outputText result) - =~ "Could not find module.*System.Time" - `E.catch` \exc -> do - putStrLn $ "Cabal result was "++show result - E.throwIO (exc :: E.SomeException) diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs --- a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs @@ -1,10 +1,10 @@ module MyLibrary where import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint myLibFunc :: IO () myLibFunc = do - getClockTime + putStrLn (render (text "foo")) let text = "myLibFunc" C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs --- a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs @@ -1,7 +1,7 @@ import qualified Data.ByteString.Char8 as C -import System.Time +import Text.PrettyPrint main = do - getClockTime + putStrLn (render (text "foo")) let text = "lemon" C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal --- a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal @@ -15,7 +15,7 @@ Library exposed-modules: MyLibrary - build-depends: base, bytestring, old-time + build-depends: base, bytestring, pretty Executable lemon main-is: lemon.hs diff --git a/tests/PackageTests/BuildTestSuiteDetailedV09/Check.hs b/tests/PackageTests/BuildTestSuiteDetailedV09/Check.hs deleted file mode 100644 --- a/tests/PackageTests/BuildTestSuiteDetailedV09/Check.hs +++ /dev/null @@ -1,18 +0,0 @@ -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 deleted file mode 100644 --- a/tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Dummy where - -import Distribution.TestSuite (Test) - -tests :: IO [Test] -tests = return [] diff --git a/tests/PackageTests/BuildTestSuiteDetailedV09/Dummy2.hs b/tests/PackageTests/BuildTestSuiteDetailedV09/Dummy2.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildTestSuiteDetailedV09/Dummy2.hs @@ -0,0 +1,6 @@ +module Dummy2 where + +import Distribution.TestSuite (Test) + +tests :: IO [Test] +tests = return [] diff --git a/tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal b/tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal deleted file mode 100644 --- a/tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal +++ /dev/null @@ -1,19 +0,0 @@ -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/BuildableField/BuildableField.cabal b/tests/PackageTests/BuildableField/BuildableField.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildableField/BuildableField.cabal @@ -0,0 +1,16 @@ +name: BuildableField +version: 0.1.0.0 +cabal-version: >=1.2 +build-type: Simple +license: BSD3 + +flag build-exe + default: True + +library + +executable my-executable + build-depends: base, unavailable-package + main-is: Main.hs + if !flag(build-exe) + buildable: False diff --git a/tests/PackageTests/BuildableField/Main.hs b/tests/PackageTests/BuildableField/Main.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildableField/Main.hs @@ -0,0 +1,4 @@ +import UnavailableModule + +main :: IO () +main = putStrLn "Hello" diff --git a/tests/PackageTests/CMain/Check.hs b/tests/PackageTests/CMain/Check.hs deleted file mode 100644 --- a/tests/PackageTests/CMain/Check.hs +++ /dev/null @@ -1,20 +0,0 @@ -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 - { directory = dir - , distPref = Nothing - , configOpts = [] - } - buildResult <- cabal_build spec ghcPath - assertBuildSucceeded buildResult diff --git a/tests/PackageTests/CMain/Setup.hs b/tests/PackageTests/CMain/Setup.hs deleted file mode 100644 --- a/tests/PackageTests/CMain/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/tests/PackageTests/DeterministicAr/Check.hs b/tests/PackageTests/DeterministicAr/Check.hs --- a/tests/PackageTests/DeterministicAr/Check.hs +++ b/tests/PackageTests/DeterministicAr/Check.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module PackageTests.DeterministicAr.Check where @@ -7,92 +7,36 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.Char (isSpace) -import Data.List -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable -#endif import PackageTests.PackageTester -import System.Exit -import System.FilePath import System.IO -import Test.HUnit (Assertion, Test (TestCase), assertFailure) import Distribution.Compiler (CompilerFlavor(..), CompilerId(..)) -import Distribution.Package (packageKeyHash) +import Distribution.Package (getHSLibraryName) import Distribution.Version (Version(..)) import Distribution.Simple.Compiler (compilerId) -import Distribution.Simple.Configure (getPersistBuildConfig) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, compiler, pkgKey) - --- Perhaps these should live in PackageTester. - --- For a polymorphic @IO a@ rather than @Assertion = IO ()@. -assertFailure' :: String -> IO a -assertFailure' msg = assertFailure msg >> return {-unpossible!-}undefined - -ghcPkg_field :: String -> String -> FilePath -> IO [FilePath] -ghcPkg_field libraryName fieldName ghcPkgPath = do - (cmd, exitCode, raw) <- run Nothing ghcPkgPath [] - ["--user", "field", libraryName, fieldName] - let output = filter ('\r' /=) raw -- Windows - -- copypasta of PackageTester.requireSuccess - unless (exitCode == ExitSuccess) . assertFailure $ - "Command " ++ cmd ++ " failed.\n" ++ "output: " ++ output - - let prefix = fieldName ++ ": " - case traverse (stripPrefix prefix) (lines output) of - Nothing -> assertFailure' $ "Command " ++ cmd ++ " failed: expected " - ++ show prefix ++ " prefix on every line.\noutput: " ++ output - Just fields -> return fields - -ghcPkg_field1 :: String -> String -> FilePath -> IO FilePath -ghcPkg_field1 libraryName fieldName ghcPkgPath = do - fields <- ghcPkg_field libraryName fieldName ghcPkgPath - case fields of - [field] -> return field - _ -> assertFailure' $ "Command ghc-pkg field failed: " - ++ "output not a single line.\noutput: " ++ show fields - ------------------------------------------------------------------------- - -this :: String -this = "DeterministicAr" - -suite :: FilePath -> FilePath -> Test -suite ghcPath ghcPkgPath = TestCase $ do - let dir = "PackageTests" this - let spec = PackageSpec - { directory = dir - , configOpts = [] - , distPref = Nothing - } - - unregister this ghcPkgPath - iResult <- cabal_install spec ghcPath - assertInstallSucceeded iResult +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, compiler, localUnitId) - let distBuild = dir "dist" "build" - libdir <- ghcPkg_field1 this "library-dirs" ghcPkgPath - lbi <- getPersistBuildConfig (dir "dist") - mapM_ (checkMetadata lbi) [distBuild, libdir] - unregister this ghcPkgPath +suite :: TestM () +suite = do + cabal_build [] + dist_dir <- distDir + lbi <- liftIO $ getPersistBuildConfig dist_dir + liftIO $ checkMetadata lbi (dist_dir "build") -- Almost a copypasta of Distribution.Simple.Program.Ar.wipeMetadata -checkMetadata :: LocalBuildInfo -> FilePath -> Assertion +checkMetadata :: LocalBuildInfo -> FilePath -> IO () checkMetadata lbi dir = withBinaryFile path ReadMode $ \ h -> do hFileSize h >>= checkArchive h where - path = dir "libHS" ++ this ++ "-0" - ++ (if ghc_7_10 then ("-" ++ packageKeyHash (pkgKey lbi)) else "") - ++ ".a" + path = dir "lib" ++ getHSLibraryName (localUnitId lbi) ++ ".a" - ghc_7_10 = case compilerId (compiler lbi) of + _ghc_7_10 = case compilerId (compiler lbi) of CompilerId GHC version | version >= Version [7, 10] [] -> True _ -> False - checkError msg = assertFailure' $ + checkError msg = assertFailure ( "PackageTests.DeterministicAr.checkMetadata: " ++ msg ++ - " in " ++ path + " in " ++ path) >> undefined archLF = "!\x0a" -- global magic, 8 bytes x60LF = "\x60\x0a" -- header magic, 2 bytes metadata = BS.concat diff --git a/tests/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal b/tests/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal @@ -0,0 +1,25 @@ +name: DuplicateModuleName +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Foo + hs-source-dirs: src + build-depends: base, Cabal + default-language: Haskell2010 + +test-suite foo + type: detailed-0.9 + test-module: Foo + hs-source-dirs: tests + build-depends: base, Cabal, DuplicateModuleName + +test-suite foo2 + type: detailed-0.9 + test-module: Foo + hs-source-dirs: tests2 + build-depends: base, Cabal, DuplicateModuleName diff --git a/tests/PackageTests/DuplicateModuleName/src/Foo.hs b/tests/PackageTests/DuplicateModuleName/src/Foo.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/DuplicateModuleName/src/Foo.hs @@ -0,0 +1,12 @@ +module Foo where + +import Distribution.TestSuite + +tests :: IO [Test] +tests = return [Test $ TestInstance + { run = return (Finished (Fail "A")) + , name = "test A" + , tags = [] + , options = [] + , setOption = \_ _-> Left "No Options" + }] diff --git a/tests/PackageTests/DuplicateModuleName/tests/Foo.hs b/tests/PackageTests/DuplicateModuleName/tests/Foo.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/DuplicateModuleName/tests/Foo.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE PackageImports #-} +module Foo where + +import Distribution.TestSuite +import qualified "DuplicateModuleName" Foo as T + +tests :: IO [Test] +tests = do + r <- T.tests + return $ [Test $ TestInstance + { run = return (Finished (Fail "B")) + , name = "test B" + , tags = [] + , options = [] + , setOption = \_ _-> Left "No Options" + }] ++ r + +this_is_test = True diff --git a/tests/PackageTests/DuplicateModuleName/tests2/Foo.hs b/tests/PackageTests/DuplicateModuleName/tests2/Foo.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/DuplicateModuleName/tests2/Foo.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE PackageImports #-} +module Foo where + +import Distribution.TestSuite +import qualified "DuplicateModuleName" Foo as T + +tests :: IO [Test] +tests = do + r <- T.tests + return $ [Test $ TestInstance + { run = return (Finished (Fail "C")) + , name = "test C" + , tags = [] + , options = [] + , setOption = \_ _-> Left "No Options" + }] ++ r + +this_is_test2 = True diff --git a/tests/PackageTests/EmptyLib/Check.hs b/tests/PackageTests/EmptyLib/Check.hs deleted file mode 100644 --- a/tests/PackageTests/EmptyLib/Check.hs +++ /dev/null @@ -1,16 +0,0 @@ -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 - { directory = "PackageTests" "EmptyLib" "empty" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build spec ghcPath - assertBuildSucceeded result diff --git a/tests/PackageTests/GhcPkgGuess/SameDirectory/SameDirectory.cabal b/tests/PackageTests/GhcPkgGuess/SameDirectory/SameDirectory.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/SameDirectory/SameDirectory.cabal @@ -0,0 +1,11 @@ +name: SameDirectory +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base + default-language: Haskell2010 diff --git a/tests/PackageTests/GhcPkgGuess/SameDirectory/ghc b/tests/PackageTests/GhcPkgGuess/SameDirectory/ghc new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/SameDirectory/ghc @@ -0,0 +1,6 @@ +#!/bin/sh +if [ -z "$WITH_GHC" ]; then + echo "Need to set WITH_GHC" + exit 1 +fi +exec "$WITH_GHC" "$@" diff --git a/tests/PackageTests/GhcPkgGuess/SameDirectory/ghc-pkg b/tests/PackageTests/GhcPkgGuess/SameDirectory/ghc-pkg new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/SameDirectory/ghc-pkg @@ -0,0 +1,3 @@ +#!/bin/sh +echo "GHC package manager version 9999999" +exit 0 diff --git a/tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/SameDirectory.cabal b/tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/SameDirectory.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/SameDirectory.cabal @@ -0,0 +1,11 @@ +name: SameDirectory +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base + default-language: Haskell2010 diff --git a/tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-7.10 b/tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-7.10 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-7.10 @@ -0,0 +1,6 @@ +#!/bin/sh +if [ -z "$WITH_GHC" ]; then + echo "Need to set WITH_GHC" + exit 1 +fi +exec "$WITH_GHC" "$@" diff --git a/tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-pkg-ghc-7.10 b/tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-pkg-ghc-7.10 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-pkg-ghc-7.10 @@ -0,0 +1,3 @@ +#!/bin/sh +echo "GHC package manager version 9999999" +exit 0 diff --git a/tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/SameDirectory.cabal b/tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/SameDirectory.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/SameDirectory.cabal @@ -0,0 +1,11 @@ +name: SameDirectory +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base + default-language: Haskell2010 diff --git a/tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-7.10 b/tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-7.10 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-7.10 @@ -0,0 +1,6 @@ +#!/bin/sh +if [ -z "$WITH_GHC" ]; then + echo "Need to set WITH_GHC" + exit 1 +fi +exec "$WITH_GHC" "$@" diff --git a/tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-pkg-7.10 b/tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-pkg-7.10 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-pkg-7.10 @@ -0,0 +1,3 @@ +#!/bin/sh +echo "GHC package manager version 9999999" +exit 0 diff --git a/tests/PackageTests/GhcPkgGuess/Symlink/SameDirectory.cabal b/tests/PackageTests/GhcPkgGuess/Symlink/SameDirectory.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/Symlink/SameDirectory.cabal @@ -0,0 +1,11 @@ +name: SameDirectory +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base + default-language: Haskell2010 diff --git a/tests/PackageTests/GhcPkgGuess/Symlink/bin/ghc b/tests/PackageTests/GhcPkgGuess/Symlink/bin/ghc new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/Symlink/bin/ghc @@ -0,0 +1,6 @@ +#!/bin/sh +if [ -z "$WITH_GHC" ]; then + echo "Need to set WITH_GHC" + exit 1 +fi +exec "$WITH_GHC" "$@" diff --git a/tests/PackageTests/GhcPkgGuess/Symlink/bin/ghc-pkg b/tests/PackageTests/GhcPkgGuess/Symlink/bin/ghc-pkg new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/Symlink/bin/ghc-pkg @@ -0,0 +1,3 @@ +#!/bin/sh +echo "GHC package manager version 9999999" +exit 0 diff --git a/tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/SameDirectory.cabal b/tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/SameDirectory.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/SameDirectory.cabal @@ -0,0 +1,11 @@ +name: SameDirectory +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base + default-language: Haskell2010 diff --git a/tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-7.10 b/tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-7.10 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-7.10 @@ -0,0 +1,6 @@ +#!/bin/sh +if [ -z "$WITH_GHC" ]; then + echo "Need to set WITH_GHC" + exit 1 +fi +exec "$WITH_GHC" "$@" diff --git a/tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-pkg-7.10 b/tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-pkg-7.10 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-pkg-7.10 @@ -0,0 +1,3 @@ +#!/bin/sh +echo "GHC package manager version 9999999" +exit 0 diff --git a/tests/PackageTests/GhcPkgGuess/SymlinkVersion/SameDirectory.cabal b/tests/PackageTests/GhcPkgGuess/SymlinkVersion/SameDirectory.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/SymlinkVersion/SameDirectory.cabal @@ -0,0 +1,11 @@ +name: SameDirectory +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base + default-language: Haskell2010 diff --git a/tests/PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-7.10 b/tests/PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-7.10 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-7.10 @@ -0,0 +1,6 @@ +#!/bin/sh +if [ -z "$WITH_GHC" ]; then + echo "Need to set WITH_GHC" + exit 1 +fi +exec "$WITH_GHC" "$@" diff --git a/tests/PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-pkg-ghc-7.10 b/tests/PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-pkg-ghc-7.10 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-pkg-ghc-7.10 @@ -0,0 +1,3 @@ +#!/bin/sh +echo "GHC package manager version 9999999" +exit 0 diff --git a/tests/PackageTests/Haddock/Check.hs b/tests/PackageTests/Haddock/Check.hs deleted file mode 100644 --- a/tests/PackageTests/Haddock/Check.hs +++ /dev/null @@ -1,42 +0,0 @@ -module PackageTests.Haddock.Check (suite) where - -import Control.Monad (unless, when) -import Data.List (isInfixOf) - -import System.FilePath (()) -import System.Directory (doesDirectoryExist, removeDirectoryRecursive) -import Test.HUnit (Assertion, Test (TestCase), assertFailure) - -import Distribution.Simple.Utils (withFileContents) -import PackageTests.PackageTester - (PackageSpec(..), assertHaddockSucceeded, cabal_haddock) - -this :: String -this = "Haddock" - -suite :: FilePath -> Test -suite ghcPath = TestCase $ do - let dir = "PackageTests" this - haddocksDir = dir "dist" "doc" "html" "Haddock" - spec = PackageSpec - { directory = dir - , configOpts = [] - , distPref = Nothing - } - - haddocksDirExists <- doesDirectoryExist haddocksDir - when haddocksDirExists (removeDirectoryRecursive haddocksDir) - hResult <- cabal_haddock spec [] ghcPath - assertHaddockSucceeded hResult - - let docFiles = map (haddocksDir ) - ["CPP.html", "Literate.html", "NoCPP.html", "Simple.html"] - mapM_ (assertFindInFile "For hiding needles.") docFiles - -assertFindInFile :: String -> FilePath -> Assertion -assertFindInFile needle path = - withFileContents path - (\contents -> - unless (needle `isInfixOf` contents) - (assertFailure ("expected: " ++ needle ++ "\n" ++ - " in file: " ++ path))) diff --git a/tests/PackageTests/HaddockNewline/A.hs b/tests/PackageTests/HaddockNewline/A.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/HaddockNewline/A.hs @@ -0,0 +1,1 @@ +module A where diff --git a/tests/PackageTests/HaddockNewline/HaddockNewline.cabal b/tests/PackageTests/HaddockNewline/HaddockNewline.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/HaddockNewline/HaddockNewline.cabal @@ -0,0 +1,20 @@ +name: HaddockNewline +version: 0.1.0.0 +synopsis: This has a + newline yo. +-- description: +license: BSD3 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +library + exposed-modules: A + -- other-modules: + -- other-extensions: + build-depends: base + -- hs-source-dirs: + default-language: Haskell2010 diff --git a/tests/PackageTests/HaddockNewline/Setup.hs b/tests/PackageTests/HaddockNewline/Setup.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/HaddockNewline/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/tests/PackageTests/Options.hs b/tests/PackageTests/Options.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/Options.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module PackageTests.Options + ( OptionEnableAllTests(..) + ) where + +import Data.Typeable (Typeable) + +import Test.Tasty.Options (IsOption(..), flagCLParser, safeRead) + +newtype OptionEnableAllTests = OptionEnableAllTests Bool + deriving Typeable + +instance IsOption OptionEnableAllTests where + defaultValue = OptionEnableAllTests False + parseValue = fmap OptionEnableAllTests . safeRead + optionName = return "enable-all-tests" + optionHelp = return "Enable all tests" + optionCLParser = flagCLParser Nothing (OptionEnableAllTests True) diff --git a/tests/PackageTests/OrderFlags/Check.hs b/tests/PackageTests/OrderFlags/Check.hs deleted file mode 100644 --- a/tests/PackageTests/OrderFlags/Check.hs +++ /dev/null @@ -1,24 +0,0 @@ -module PackageTests.OrderFlags.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import Control.Exception - -#if !MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif - -suite :: FilePath -> Test -suite ghcPath = TestCase $ do - let spec = PackageSpec - { directory = "PackageTests" "OrderFlags" - , configOpts = [] - , distPref = Nothing - } - 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/PackageTester.hs b/tests/PackageTests/PackageTester.hs --- a/tests/PackageTests/PackageTester.hs +++ b/tests/PackageTests/PackageTester.hs @@ -1,308 +1,693 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE CPP #-} --- You can set the following VERBOSE environment variable to control --- the verbosity of the output generated by this module. module PackageTests.PackageTester - ( PackageSpec(..) - , Success(..) + ( PackageSpec + , SuiteConfig(..) + , TestConfig(..) , Result(..) + , TestM + , runTestM + -- * Paths + , packageDir + , distDir + , relativeDistDir + , sharedDBPath + , getWithGhcPath + -- * Running cabal commands - , cabal_configure + , cabal + , cabal' , cabal_build - , cabal_haddock - , cabal_test - , cabal_bench , cabal_install - , unregister + , ghcPkg + , ghcPkg' , compileSetup , run + , runExe + , runExe' + , rawRun + , rawCompileSetup + , withPackage + , withEnv + , withPackageDb + -- * Polymorphic versions of HUnit functions + , assertFailure + , assertEqual + , assertBool + , shouldExist + , shouldNotExist + -- * Test helpers - , assertBuildSucceeded - , assertBuildFailed - , assertHaddockSucceeded - , assertTestSucceeded - , assertInstallSucceeded + , shouldFail + , whenGhcVersion , assertOutputContains , assertOutputDoesNotContain + , assertFindInFile + , concatOutput + , withSymlink + + -- * Test trees + , TestTreeM + , runTestTree + , testTree + , testTree' + , groupTests + , mapTestTrees + , testWhen + , testUnless + , unlessWindows + , hasSharedLibraries + + , getPersistBuildConfig + + -- Common utilities + , module System.FilePath + , module Data.List + , module Control.Monad.IO.Class + , module Text.Regex.Posix ) where -import qualified Control.Exception.Extensible as E +import PackageTests.Options + +import Distribution.Compat.CreatePipe (createPipe) +import Distribution.Simple.Compiler (PackageDBStack, PackageDB(..)) +import Distribution.Simple.Program.Run (getEffectiveEnvironment) +import Distribution.System (OS(Windows), buildOS) +import Distribution.Simple.Utils + ( printRawCommandAndArgsAndEnv, withFileContents ) +import Distribution.Simple.Configure + ( getPersistBuildConfig ) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.BuildPaths (exeExtension) + +#ifndef CURRENT_COMPONENT_ID +import Distribution.Simple.Utils (cabalVersion) +import Distribution.Text (display) +#endif + +import qualified Test.Tasty.HUnit as HUnit +import Text.Regex.Posix + +import qualified Control.Exception as E import Control.Monad +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Writer +import Control.Monad.IO.Class import qualified Data.ByteString.Char8 as C import Data.List -import Data.Maybe -import System.Directory (canonicalizePath, doesFileExist, getCurrentDirectory) -import System.Environment (getEnv) -import System.Exit (ExitCode(ExitSuccess)) +import Data.Version +import System.Directory + ( doesFileExist, canonicalizePath, createDirectoryIfMissing + , removeDirectoryRecursive, getPermissions, setPermissions + , setOwnerExecutable ) +import System.Exit import System.FilePath -import System.IO (hIsEOF, hGetChar, hClose) +import System.IO import System.IO.Error (isDoesNotExistError) -import System.Process (runProcess, waitForProcess) -import Test.HUnit (Assertion, assertFailure) +import System.Process (runProcess, waitForProcess, showCommandForUser) +import Test.Tasty (TestTree, askOption, testGroup) -import Distribution.Compat.CreatePipe (createPipe) -import Distribution.Simple.BuildPaths (exeExtension) -import Distribution.Simple.Program.Run (getEffectiveEnvironment) -import Distribution.Simple.Utils (printRawCommandAndArgsAndEnv) -import Distribution.ReadE (readEOrFail) -import Distribution.Verbosity (Verbosity, flagToVerbosity, normal) +#ifndef mingw32_HOST_OS +import Control.Monad.Catch ( bracket_ ) +import System.Directory ( removeFile ) +import System.Posix.Files ( createSymbolicLink ) +#endif -data PackageSpec = PackageSpec - { directory :: FilePath - , distPref :: Maybe FilePath - , configOpts :: [String] - } +-- | Our test monad maintains an environment recording the global test +-- suite configuration 'SuiteConfig', and the local per-test +-- configuration 'TestConfig'. +type TestM = ReaderT (SuiteConfig, TestConfig) IO -data Success = Failure - | ConfigureSuccess - | BuildSuccess - | HaddockSuccess - | InstallSuccess - | TestSuccess - | BenchSuccess - deriving (Eq, Show) +-- | Run a test in the test monad. +runTestM :: SuiteConfig -> FilePath -> Maybe String -> TestM a -> IO () +runTestM suite name subname m = do + let test = TestConfig { + testMainName = name, + testSubName = subname, + testShouldFail = False, + testCurrentPackage = ".", + testPackageDb = False, + testEnvironment = [] + } + void (runReaderT (cleanup >> m) (suite, test)) + where + -- TODO: option not to clean up dist dirs; this should be + -- harmless! + cleanup = do + onlyIfExists . removeDirectoryRecursive =<< topDir -data Result = Result - { successful :: Bool - , success :: Success - , outputText :: String - } deriving Show +-- | Run an IO action, and suppress a "does not exist" error. +onlyIfExists :: MonadIO m => IO () -> m () +onlyIfExists m = liftIO $ + E.catch m $ \(e :: IOError) -> + if isDoesNotExistError e + then return () + else E.throwIO e -nullResult :: Result -nullResult = Result True Failure "" +-- cleaning up: +-- cabal clean will clean up dist directory, but we also need to zap +-- Setup etc. +-- +-- Suggestion: just copy the files somewhere else! +-- | Global configuration for the entire test suite. +data SuiteConfig = SuiteConfig + -- | Path to GHC that was used to compile Cabal library under test. + { ghcPath :: FilePath + -- | Version of GHC that compiled Cabal. + , ghcVersion :: Version + -- | Path to ghc-pkg corresponding to 'ghcPath'. + , ghcPkgPath :: FilePath + -- | Path to GHC that we should use to "./Setup --with-ghc" + , withGhcPath :: FilePath + -- | Version of GHC at 'withGhcPath'. + , withGhcVersion :: Version + -- | The build directory that was used to build Cabal (used + -- to compile Setup scripts.) + , cabalDistPref :: FilePath + -- | Configuration options you can use to make the Cabal + -- being tested visible (e.g. if you're using the test runner). + -- We don't add these by default because then you have to + -- link against Cabal which makes the build go longer. + , packageDBStack :: PackageDBStack + -- | How verbose should we be + , suiteVerbosity :: Verbosity + -- | The absolute current working directory + , absoluteCWD :: FilePath + } + +data TestConfig = TestConfig + -- | Test name, MUST be the directory the test packages live in + -- relative to tests/PackageTests + { testMainName :: FilePath + -- | Test sub-name, used to qualify dist/database directory to avoid + -- conflicts. + , testSubName :: Maybe String + -- | This gets modified sometimes + , testShouldFail :: Bool + -- | The "current" package, ala current directory + , testCurrentPackage :: PackageSpec + -- | Says if we've initialized the per-test package DB + , testPackageDb :: Bool + -- | Environment override + , testEnvironment :: [(String, Maybe String)] + } + +-- | A package that can be built. +type PackageSpec = FilePath + ------------------------------------------------------------------------ --- * Running cabal commands +-- * Directories -recordRun :: (String, ExitCode, String) -> Success -> Result -> Result -recordRun (cmd, exitCode, exeOutput) thisSucc res = - res { successful = successful res && exitCode == ExitSuccess - , success = if exitCode == ExitSuccess then thisSucc - else success res - , outputText = - (if null $ outputText res then "" else outputText res ++ "\n") ++ - cmd ++ "\n" ++ exeOutput - } +simpleSetupPath :: TestM FilePath +simpleSetupPath = do + (suite, _) <- ask + return (absoluteCWD suite "tests/Setup") -cabal_configure :: PackageSpec -> FilePath -> IO Result -cabal_configure spec ghcPath = do - res <- doCabalConfigure spec ghcPath - record spec res - return res +-- | The absolute path to the directory containing the files for +-- this tests; usually @Check.hs@ and any test packages. +testDir :: TestM FilePath +testDir = do + (suite, test) <- ask + return $ absoluteCWD suite "tests/PackageTests" testMainName test -doCabalConfigure :: PackageSpec -> FilePath -> IO Result -doCabalConfigure spec ghcPath = do - cleanResult@(_, _, _) <- cabal spec [] ["clean"] ghcPath - requireSuccess cleanResult - res <- cabal spec [] - (["configure", "--user", "-w", ghcPath] ++ configOpts spec) - ghcPath - return $ recordRun res ConfigureSuccess nullResult +-- | The absolute path to the root of the package directory; it's +-- where the Cabal file lives. This is what you want the CWD of cabal +-- calls to be. +packageDir :: TestM FilePath +packageDir = do + (_, test) <- ask + test_dir <- testDir + return $ test_dir testCurrentPackage test -doCabalBuild :: PackageSpec -> FilePath -> IO Result -doCabalBuild spec ghcPath = do - configResult <- doCabalConfigure spec ghcPath - if successful configResult - then do - res <- cabal spec [] ["build", "-v"] ghcPath - return $ recordRun res BuildSuccess configResult - else - return configResult +-- | The absolute path to the directory containing all the +-- files for ALL tests associated with a test (respecting +-- subtests.) To clean, you ONLY need to delete this directory. +topDir :: TestM FilePath +topDir = do + test_dir <- testDir + (_, test) <- ask + return $ test_dir + case testSubName test of + Nothing -> "dist-test" + Just n -> "dist-test." ++ n -cabal_build :: PackageSpec -> FilePath -> IO Result -cabal_build spec ghcPath = do - res <- doCabalBuild spec ghcPath - record spec res - return res +prefixDir :: TestM FilePath +prefixDir = do + top_dir <- topDir + return $ top_dir "usr" -cabal_haddock :: PackageSpec -> [String] -> FilePath -> IO Result -cabal_haddock spec extraArgs ghcPath = do - res <- doCabalHaddock spec extraArgs ghcPath - record spec res - return res +-- | The absolute path to the build directory that should be used +-- for the current package in a test. +distDir :: TestM FilePath +distDir = do + top_dir <- topDir + (_, test) <- ask + return $ top_dir testCurrentPackage test "dist" -doCabalHaddock :: PackageSpec -> [String] -> FilePath -> IO Result -doCabalHaddock spec extraArgs ghcPath = do - configResult <- doCabalConfigure spec ghcPath - if successful configResult - then do - res <- cabal spec [] ("haddock" : extraArgs) ghcPath - return $ recordRun res HaddockSuccess configResult - else - return configResult +definitelyMakeRelative :: FilePath -> FilePath -> FilePath +definitelyMakeRelative base0 path0 = + let go [] path = joinPath path + go base [] = joinPath (replicate (length base) "..") + go (".":xs) ys = go xs ys + go xs (".":ys) = go xs ys + go (x:xs) (y:ys) + | x == y = go xs ys + | otherwise = go (x:xs) [] go [] (y:ys) + in go (splitPath base0) (splitPath path0) -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 +-- hpc is stupid and doesn't understand absolute paths. +relativeDistDir :: TestM FilePath +relativeDistDir = do + dist_dir0 <- distDir + pkg_dir <- packageDir + return $ definitelyMakeRelative pkg_dir dist_dir0 --- | Install this library in the user area -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"] ghcPath - return $ recordRun res InstallSuccess buildResult - else - return buildResult - record spec res - return res +-- | The absolute path to the shared package database that should +-- be used by all packages in this test. +sharedDBPath :: TestM FilePath +sharedDBPath = do + top_dir <- topDir + return $ top_dir "packagedb" -cabal_test :: PackageSpec -> [(String, Maybe String)] -> [String] -> FilePath -> IO Result -cabal_test spec envOverrides extraArgs ghcPath = do - res <- cabal spec envOverrides ("test" : extraArgs) ghcPath - let r = recordRun res TestSuccess nullResult - record spec r - return r +getWithGhcPath :: TestM FilePath +getWithGhcPath = do + (suite, _) <- ask + return $ withGhcPath suite -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 +------------------------------------------------------------------------ +-- * Running cabal -compileSetup :: FilePath -> FilePath -> IO () -compileSetup packageDir ghcPath = do - wd <- getCurrentDirectory - r <- run (Just $ packageDir) ghcPath [] - [ "--make" --- HPC causes trouble -- see #1012 --- , "-fhpc" - , "-package-conf " ++ wd "../dist/package.conf.inplace" - , "Setup.hs" - ] - requireSuccess r +cabal :: String -> [String] -> TestM () +cabal cmd extraArgs0 = void (cabal' cmd extraArgs0) --- | Returns the command that was issued, the return code, and the output text. -cabal :: PackageSpec -> [(String, Maybe String)] -> [String] -> FilePath -> IO (String, ExitCode, String) -cabal spec envOverrides cabalArgs_ ghcPath = do - let cabalArgs = case distPref spec of - Nothing -> cabalArgs_ - Just dist -> ("--builddir=" ++ dist) : cabalArgs_ - customSetup <- doesFileExist (directory spec "Setup.hs") +cabal' :: String -> [String] -> TestM Result +cabal' cmd extraArgs0 = do + (suite, test) <- ask + prefix_dir <- prefixDir + when ((cmd == "register" || cmd == "copy") && not (testPackageDb test)) $ + error "Cannot register/copy without using 'withPackageDb'" + let extraArgs1 = case cmd of + "configure" -> + -- If the package database is empty, setting --global + -- here will make us error loudly if we try to install + -- into a bad place. + [ "--global" + , "--with-ghc", withGhcPath suite + -- This improves precision but it increases the number + -- of flags one has to specify and I don't like that; + -- Cabal is going to configure it and usually figure + -- out the right location in any case. + -- , "--with-ghc-pkg", withGhcPkgPath suite + -- Would really like to do this, but we're not always + -- going to be building against sufficiently recent + -- Cabal which provides this macro. + -- , "--dependency=Cabal=" ++ THIS_PACKAGE_KEY + -- These flags make the test suite run faster + -- Can't do this unless we LD_LIBRARY_PATH correctly + -- , "--enable-executable-dynamic" + , "--disable-optimization" + -- Specify where we want our installed packages to go + , "--prefix=" ++ prefix_dir + ] -- Only add the LBI package stack if the GHC version + -- matches. + ++ (if withGhcPath suite == ghcPath suite + then packageDBParams (packageDBStack suite) + else []) + ++ extraArgs0 + -- This gives us MUCH better error messages + "build" -> "-v" : extraArgs0 + _ -> extraArgs0 + -- This is a horrible hack to make hpc work correctly + dist_dir <- relativeDistDir + let extraArgs = ["--distdir", dist_dir] ++ extraArgs1 + doCabal (cmd:extraArgs) + +-- | This abstracts the common pattern of configuring and then building. +cabal_build :: [String] -> TestM () +cabal_build args = do + cabal "configure" args + cabal "build" [] + return () + +-- | This abstracts the common pattern of "installing" a package. +cabal_install :: [String] -> TestM () +cabal_install args = do + cabal "configure" args + cabal "build" [] + cabal "copy" [] + cabal "register" [] + return () + +-- | Determines what Setup executable to run and runs it +doCabal :: [String] -- ^ extra arguments + -> TestM Result +doCabal cabalArgs = do + pkg_dir <- packageDir + customSetup <- liftIO $ doesFileExist (pkg_dir "Setup.hs") if customSetup then do - compileSetup (directory spec) ghcPath - path <- canonicalizePath $ directory spec "Setup" - run (Just $ directory spec) path envOverrides cabalArgs + compileSetup + -- TODO make this less racey + let path = pkg_dir "Setup" + run (Just pkg_dir) path cabalArgs else do -- Use shared Setup executable (only for Simple build types). - path <- canonicalizePath "Setup" - run (Just $ directory spec) path envOverrides cabalArgs + path <- simpleSetupPath + run (Just pkg_dir) path cabalArgs --- | Returns the command that was issued, the return code, and the output text -run :: Maybe FilePath -> String -> [(String, Maybe String)] -> [String] -> IO (String, ExitCode, String) -run cwd path envOverrides args = do +packageDBParams :: PackageDBStack -> [String] +packageDBParams dbs = "--package-db=clear" + : map (("--package-db=" ++) . convert) dbs + where + convert :: PackageDB -> String + convert GlobalPackageDB = "global" + convert UserPackageDB = "user" + convert (SpecificPackageDB path) = path + +------------------------------------------------------------------------ +-- * Compiling setup scripts + +compileSetup :: TestM () +compileSetup = do + (suite, test) <- ask + pkg_path <- packageDir + liftIO $ rawCompileSetup (suiteVerbosity suite) suite (testEnvironment test) pkg_path + +rawCompileSetup :: Verbosity -> SuiteConfig -> [(String, Maybe String)] -> FilePath -> IO () +rawCompileSetup verbosity suite e path = do + -- NB: Use 'ghcPath', not 'withGhcPath', since we need to be able to + -- link against the Cabal library which was built with 'ghcPath'. + r <- rawRun verbosity (Just path) (ghcPath suite) e $ + [ "--make"] ++ + ghcPackageDBParams (ghcVersion suite) (packageDBStack suite) ++ + [ "-hide-all-packages" + , "-package base" +#ifdef CURRENT_COMPONENT_ID + -- This is best, but we don't necessarily have it + -- if we're bootstrapping with old Cabal. + , "-package-id " ++ CURRENT_COMPONENT_ID +#else + -- This mostly works, UNLESS you've installed a + -- version of Cabal with the SAME version number. + -- Then old GHCs will incorrectly select the installed + -- version (because it prefers the FIRST package it finds.) + -- It also semi-works to not specify "-hide-all-packages" + -- at all, except if there's a later version of Cabal + -- installed GHC will prefer that. + , "-package Cabal-" ++ display cabalVersion +#endif + , "-O0" + , "Setup.hs" ] + unless (resultExitCode r == ExitSuccess) $ + error $ + "could not build shared Setup executable\n" ++ + " ran: " ++ resultCommand r ++ "\n" ++ + " output:\n" ++ resultOutput r ++ "\n\n" + +ghcPackageDBParams :: Version -> PackageDBStack -> [String] +ghcPackageDBParams ghc_version dbs + | ghc_version >= Version [7,6] [] + = "-clear-package-db" : map convert dbs + | otherwise + = concatMap convertLegacy dbs + where + convert :: PackageDB -> String + convert GlobalPackageDB = "-global-package-db" + convert UserPackageDB = "-user-package-db" + convert (SpecificPackageDB path) = "-package-db=" ++ path + + convertLegacy :: PackageDB -> [String] + convertLegacy (SpecificPackageDB path) = ["-package-conf=" ++ path] + convertLegacy _ = [] + +------------------------------------------------------------------------ +-- * Running ghc-pkg + +ghcPkg :: String -> [String] -> TestM () +ghcPkg cmd args = void (ghcPkg' cmd args) + +ghcPkg' :: String -> [String] -> TestM Result +ghcPkg' cmd args = do + db_path <- sharedDBPath + (config, test) <- ask + unless (testPackageDb test) $ + error "Must initialize package database using withPackageDb" + let db_stack = packageDBStack config ++ [SpecificPackageDB db_path] + extraArgs = ghcPkgPackageDBParams (ghcVersion config) db_stack + run Nothing (ghcPkgPath config) (cmd : extraArgs ++ args) + +ghcPkgPackageDBParams :: Version -> PackageDBStack -> [String] +ghcPkgPackageDBParams version dbs = concatMap convert dbs where + convert :: PackageDB -> [String] + -- Ignoring global/user is dodgy but there's no way good + -- way to give ghc-pkg the correct flags in this case. + convert GlobalPackageDB = [] + convert UserPackageDB = [] + convert (SpecificPackageDB path) + | version >= Version [7,6] [] + = ["--package-db=" ++ path] + | otherwise + = ["--package-conf=" ++ path] + +------------------------------------------------------------------------ +-- * Running other things + +-- | Run an executable that was produced by cabal. The @exe_name@ +-- is precisely the name of the executable section in the file. +runExe :: String -> [String] -> TestM () +runExe exe_name args = void (runExe' exe_name args) + +runExe' :: String -> [String] -> TestM Result +runExe' exe_name args = do + dist_dir <- distDir + let exe = dist_dir "build" exe_name exe_name + run Nothing exe args + +run :: Maybe FilePath -> String -> [String] -> TestM Result +run mb_cwd path args = do verbosity <- getVerbosity + (_, test) <- ask + r <- liftIO $ rawRun verbosity mb_cwd path (testEnvironment test) args + record r + requireSuccess r + +rawRun :: Verbosity -> Maybe FilePath -> String -> [(String, Maybe String)] -> [String] -> IO Result +rawRun verbosity mb_cwd path envOverrides args = do -- 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) + canonicalizePath (if pathExists then path + else path <.> exeExtension) menv <- getEffectiveEnvironment envOverrides printRawCommandAndArgsAndEnv verbosity path' args menv (readh, writeh) <- createPipe - pid <- runProcess path' args cwd menv Nothing (Just writeh) (Just writeh) + pid <- runProcess path' args mb_cwd menv Nothing (Just writeh) (Just writeh) - -- fork off a thread to start consuming the output - out <- suckH [] readh + out <- hGetContents readh + void $ E.evaluate (length out) -- force the output hClose readh -- wait for the program to terminate exitcode <- waitForProcess pid - let fullCmd = unwords (path' : args) - return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, exitcode, out) - where - suckH output h = do - eof <- hIsEOF h - if eof - then return (reverse output) - else do - c <- hGetChar h - suckH (c:output) h + return Result { + resultExitCode = exitcode, + resultDirectory = mb_cwd, + resultCommand = showCommandForUser path' args, + resultOutput = out + } +------------------------------------------------------------------------ +-- * Subprocess run results -requireSuccess :: (String, ExitCode, String) -> IO () -requireSuccess (cmd, exitCode, output) = - unless (exitCode == ExitSuccess) $ +data Result = Result + { resultExitCode :: ExitCode + , resultDirectory :: Maybe FilePath + , resultCommand :: String + , resultOutput :: String + } deriving Show + +requireSuccess :: Result -> TestM Result +requireSuccess r@Result { resultCommand = cmd + , resultExitCode = exitCode + , resultOutput = output } = do + (_, test) <- ask + when (exitCode /= ExitSuccess && not (testShouldFail test)) $ assertFailure $ "Command " ++ cmd ++ " failed.\n" ++ - "output: " ++ output + "Output:\n" ++ output ++ "\n" + when (exitCode == ExitSuccess && testShouldFail test) $ + assertFailure $ "Command " ++ cmd ++ " succeeded.\n" ++ + "Output:\n" ++ output ++ "\n" + return r -record :: PackageSpec -> Result -> IO () -record spec res = do - C.writeFile (directory spec "test-log.txt") (C.pack $ outputText res) +record :: Result -> TestM () +record res = do + build_dir <- distDir + (suite, _) <- ask + liftIO $ createDirectoryIfMissing True build_dir + liftIO $ C.appendFile (build_dir "test.log") + (C.pack $ "+ " ++ resultCommand res ++ "\n" + ++ resultOutput res ++ "\n\n") + let test_sh = build_dir "test.sh" + b <- liftIO $ doesFileExist test_sh + when (not b) . liftIO $ do + -- This is hella racey but this is not that security important + C.appendFile test_sh + (C.pack $ "#/bin/sh\nset -ev\n" ++ + "cd "++ show (absoluteCWD suite) ++"\n") + perms <- getPermissions test_sh + setPermissions test_sh (setOwnerExecutable True perms) + liftIO $ C.appendFile test_sh + (C.pack + (case resultDirectory res of + Nothing -> resultCommand res + Just d -> "(cd " ++ show d ++ " && " ++ resultCommand res ++ ")\n")) + ------------------------------------------------------------------------ -- * Test helpers -assertBuildSucceeded :: Result -> Assertion -assertBuildSucceeded result = unless (successful result) $ - assertFailure $ - "expected: \'setup build\' should succeed\n" ++ - " output: " ++ outputText result +assertFailure :: MonadIO m => String -> m () +assertFailure = liftIO . HUnit.assertFailure -assertBuildFailed :: Result -> Assertion -assertBuildFailed result = when (successful result) $ - assertFailure $ - "expected: \'setup build\' should fail\n" ++ - " output: " ++ outputText result +assertEqual :: (Eq a, Show a, MonadIO m) => String -> a -> a -> m () +assertEqual s x y = liftIO $ HUnit.assertEqual s x y -assertHaddockSucceeded :: Result -> Assertion -assertHaddockSucceeded result = unless (successful result) $ - assertFailure $ - "expected: \'setup haddock\' should succeed\n" ++ - " output: " ++ outputText result +assertBool :: MonadIO m => String -> Bool -> m () +assertBool s x = liftIO $ HUnit.assertBool s x -assertTestSucceeded :: Result -> Assertion -assertTestSucceeded result = unless (successful result) $ - assertFailure $ - "expected: \'setup test\' should succeed\n" ++ - " output: " ++ outputText result +shouldExist :: MonadIO m => FilePath -> m () +shouldExist path = liftIO $ doesFileExist path >>= assertBool (path ++ " should exist") -assertInstallSucceeded :: Result -> Assertion -assertInstallSucceeded result = unless (successful result) $ - assertFailure $ - "expected: \'setup install\' should succeed\n" ++ - " output: " ++ outputText result +shouldNotExist :: MonadIO m => FilePath -> m () +shouldNotExist path = + liftIO $ doesFileExist path >>= assertBool (path ++ " should exist") . not -assertOutputContains :: String -> Result -> Assertion +shouldFail :: TestM a -> TestM a +shouldFail = withReaderT (\(suite, test) -> (suite, test { testShouldFail = not (testShouldFail test) })) + +whenGhcVersion :: (Version -> Bool) -> TestM () -> TestM () +whenGhcVersion p m = do + (suite, _) <- ask + when (p (ghcVersion suite)) m + +withPackage :: FilePath -> TestM a -> TestM a +withPackage f = withReaderT (\(suite, test) -> (suite, test { testCurrentPackage = f })) + +-- TODO: Really should accumulate... but I think to do this +-- properly we can't just append +withEnv :: [(String, Maybe String)] -> TestM a -> TestM a +withEnv e m = do + (_, test0) <- ask + when (not (null (testEnvironment test0))) + $ error "nested withEnv (not yet) supported" + withReaderT (\(suite, test) -> (suite, test { testEnvironment = e })) m + +withPackageDb :: TestM a -> TestM a +withPackageDb m = do + (_, test0) <- ask + db_path <- sharedDBPath + if testPackageDb test0 + then m + else withReaderT (\(suite, test) -> + (suite { packageDBStack + = packageDBStack suite + ++ [SpecificPackageDB db_path] }, + test { testPackageDb = True })) + $ do ghcPkg "init" [db_path] + m + +assertOutputContains :: MonadIO m => String -> Result -> m () assertOutputContains needle result = unless (needle `isInfixOf` (concatOutput output)) $ assertFailure $ " expected: " ++ needle ++ "\n" ++ " in output: " ++ output ++ "" - where output = outputText result + where output = resultOutput result -assertOutputDoesNotContain :: String -> Result -> Assertion +assertOutputDoesNotContain :: MonadIO m => String -> Result -> m () assertOutputDoesNotContain needle result = when (needle `isInfixOf` (concatOutput output)) $ assertFailure $ "unexpected: " ++ needle ++ " in output: " ++ output - where output = outputText result + where output = resultOutput result +assertFindInFile :: MonadIO m => String -> FilePath -> m () +assertFindInFile needle path = + liftIO $ withFileContents path + (\contents -> + unless (needle `isInfixOf` contents) + (assertFailure ("expected: " ++ needle ++ "\n" ++ + " in file: " ++ path))) + -- | Replace line breaks with spaces, correctly handling "\r\n". concatOutput :: String -> String concatOutput = unwords . lines . filter ((/=) '\r') +-- | Create a symlink for the duration of the provided action. If the symlink +-- already exists, it is deleted. Does not work on Windows. +withSymlink :: FilePath -> FilePath -> TestM a -> TestM a +#ifdef mingw32_HOST_OS +withSymlink _oldpath _newpath _act = + error "PackageTests.PackageTester.withSymlink: does not work on Windows!" +#else +withSymlink oldpath newpath act = do + symlinkExists <- liftIO $ doesFileExist newpath + when symlinkExists $ liftIO $ removeFile newpath + bracket_ (liftIO $ createSymbolicLink oldpath newpath) + (liftIO $ removeFile newpath) act +#endif + ------------------------------------------------------------------------ --- Verbosity +-- * Test trees -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 +-- | Monad for creating test trees. The option --enable-all-tests determines +-- whether to filter tests with 'testWhen' and 'testUnless'. +type TestTreeM = WriterT [TestTree] (Reader OptionEnableAllTests) --- TODO: Convert to a "-v" flag instead. -getVerbosity :: IO Verbosity -getVerbosity = do - maybe normal (readEOrFail flagToVerbosity) `fmap` lookupEnv "VERBOSE" +runTestTree :: String -> TestTreeM () -> TestTree +runTestTree name ts = askOption $ + testGroup name . runReader (execWriterT ts) + +testTree :: SuiteConfig -> String -> Maybe String -> TestM a -> TestTreeM () +testTree config name subname m = + testTree' $ HUnit.testCase name $ runTestM config name subname m + +testTree' :: TestTree -> TestTreeM () +testTree' tc = tell [tc] + +-- | Create a test group from the output of the given action. +groupTests :: String -> TestTreeM () -> TestTreeM () +groupTests name = censor (\ts -> [testGroup name ts]) + +-- | Apply a function to each top-level test tree. +mapTestTrees :: (TestTree -> TestTree) -> TestTreeM a -> TestTreeM a +mapTestTrees = censor . map + +testWhen :: Bool -> TestTreeM () -> TestTreeM () +testWhen c test = do + OptionEnableAllTests enableAll <- lift ask + when (enableAll || c) test + +testUnless :: Bool -> TestTreeM () -> TestTreeM () +testUnless = testWhen . not + +unlessWindows :: TestTreeM () -> TestTreeM () +unlessWindows = testUnless (buildOS == Windows) + +hasSharedLibraries :: SuiteConfig -> Bool +hasSharedLibraries config = + buildOS /= Windows || withGhcVersion config < Version [7,8] [] + +------------------------------------------------------------------------ +-- Verbosity + +getVerbosity :: TestM Verbosity +getVerbosity = fmap (suiteVerbosity . fst) ask diff --git a/tests/PackageTests/PathsModule/Executable/Check.hs b/tests/PackageTests/PathsModule/Executable/Check.hs deleted file mode 100644 --- a/tests/PackageTests/PathsModule/Executable/Check.hs +++ /dev/null @@ -1,16 +0,0 @@ -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 - { directory = "PackageTests" "PathsModule" "Executable" - , distPref = Nothing - , configOpts = [] - } - result <- cabal_build spec ghcPath - assertBuildSucceeded result diff --git a/tests/PackageTests/PathsModule/Library/Check.hs b/tests/PackageTests/PathsModule/Library/Check.hs deleted file mode 100644 --- a/tests/PackageTests/PathsModule/Library/Check.hs +++ /dev/null @@ -1,16 +0,0 @@ -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 - { directory = "PackageTests" "PathsModule" "Library" - , distPref = Nothing - , configOpts = [] - } - result <- cabal_build spec ghcPath - assertBuildSucceeded result diff --git a/tests/PackageTests/PreProcess/Check.hs b/tests/PackageTests/PreProcess/Check.hs deleted file mode 100644 --- a/tests/PackageTests/PreProcess/Check.hs +++ /dev/null @@ -1,16 +0,0 @@ -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 - { directory = "PackageTests" "PreProcess" - , distPref = Nothing - , configOpts = ["--enable-tests", "--enable-benchmarks"] - } - result <- cabal_build spec ghcPath - assertBuildSucceeded result diff --git a/tests/PackageTests/PreProcessExtraSources/Foo.hsc b/tests/PackageTests/PreProcessExtraSources/Foo.hsc new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PreProcessExtraSources/Foo.hsc @@ -0,0 +1,9 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Foo where + +import Foreign.C.Types + +#def int incr(int x) { return x + 1; } + +foreign import ccall unsafe "Foo_hsc.h incr" + incr :: CInt -> CInt diff --git a/tests/PackageTests/PreProcessExtraSources/Main.hs b/tests/PackageTests/PreProcessExtraSources/Main.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PreProcessExtraSources/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import Foo + +main :: IO () +main = do + let x = incr 4 + return () diff --git a/tests/PackageTests/PreProcessExtraSources/my.cabal b/tests/PackageTests/PreProcessExtraSources/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PreProcessExtraSources/my.cabal @@ -0,0 +1,32 @@ +name: PreProcessExtraSources +version: 0.1 +license: BSD3 +author: Ian Ross +stability: stable +category: PackageTests +build-type: Simple +Cabal-version: >= 1.2 + +description: + Check that preprocessors that generate extra C sources are handled. + +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/ReexportedModules/Check.hs b/tests/PackageTests/ReexportedModules/Check.hs deleted file mode 100644 --- a/tests/PackageTests/ReexportedModules/Check.hs +++ /dev/null @@ -1,41 +0,0 @@ -module PackageTests.ReexportedModules.Check where - -import Data.Version -import PackageTests.PackageTester -import System.FilePath -import Test.HUnit -import Data.Maybe -import Data.List -import Control.Monad -import Data.Char -import Text.ParserCombinators.ReadP - -orFail :: String -> [(a, String)] -> a -orFail err r = case find (all isSpace . snd) r of - Nothing -> error err - Just (i, _) -> i - -find' :: (a -> Bool) -> [a] -> Maybe a -find' = find - -suite :: FilePath -> Test -suite ghcPath = TestCase $ do - -- ToDo: Turn this into a utility function - (_, _, xs) <- run Nothing ghcPath [] ["--info"] - let compat = (>= Version [7,9] []) - . orFail "could not parse version" - . readP_to_S parseVersion - . snd - . fromJust - . find' ((=="Project version").fst) - . orFail "could not parse ghc --info output" - . reads - $ xs - when compat $ do - let spec = PackageSpec - { directory = "PackageTests" "ReexportedModules" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build spec ghcPath - assertBuildSucceeded result diff --git a/tests/PackageTests/TemplateHaskell/Check.hs b/tests/PackageTests/TemplateHaskell/Check.hs deleted file mode 100644 --- a/tests/PackageTests/TemplateHaskell/Check.hs +++ /dev/null @@ -1,41 +0,0 @@ -module PackageTests.TemplateHaskell.Check where - -import PackageTests.PackageTester -import System.FilePath -import Test.HUnit - -vanilla :: FilePath -> Test -vanilla ghcPath = TestCase $ do - let spec = PackageSpec - { directory = "PackageTests" "TemplateHaskell" "vanilla" - , configOpts = [] - , distPref = Nothing - } - result <- cabal_build spec ghcPath - assertBuildSucceeded result - -profiling :: FilePath -> Test -profiling ghcPath = TestCase $ do - let flags = ["--enable-library-profiling" --- ,"--disable-library-vanilla" - ,"--enable-profiling"] - spec = PackageSpec - { directory = "PackageTests" "TemplateHaskell" "profiling" - , configOpts = flags - , distPref = Nothing - } - result <- cabal_build spec ghcPath - assertBuildSucceeded result - -dynamic :: FilePath -> Test -dynamic ghcPath = TestCase $ do - let flags = ["--enable-shared" --- ,"--disable-library-vanilla" - ,"--enable-executable-dynamic"] - spec = PackageSpec - { directory = "PackageTests" "TemplateHaskell" "dynamic" - , configOpts = flags - , distPref = Nothing - } - result <- cabal_build spec ghcPath - assertBuildSucceeded result diff --git a/tests/PackageTests/TestNameCollision/child/Child.hs b/tests/PackageTests/TestNameCollision/child/Child.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestNameCollision/child/Child.hs @@ -0,0 +1,2 @@ +module Child where +import Parent diff --git a/tests/PackageTests/TestNameCollision/child/child.cabal b/tests/PackageTests/TestNameCollision/child/child.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestNameCollision/child/child.cabal @@ -0,0 +1,19 @@ +name: child +version: 0.1 +description: This defines the colliding detailed-0.9 test suite +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Child + build-depends: base, parent + default-language: Haskell2010 + +test-suite parent + type: detailed-0.9 + test-module: Test + hs-source-dirs: tests + build-depends: base, Cabal, child diff --git a/tests/PackageTests/TestNameCollision/child/tests/Test.hs b/tests/PackageTests/TestNameCollision/child/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestNameCollision/child/tests/Test.hs @@ -0,0 +1,13 @@ +module Test where + +import Distribution.TestSuite +import Child + +tests :: IO [Test] +tests = return $ [Test $ TestInstance + { run = return (Finished Pass) + , name = "test" + , tags = [] + , options = [] + , setOption = \_ _-> Left "No Options" + }] diff --git a/tests/PackageTests/TestNameCollision/parent/Parent.hs b/tests/PackageTests/TestNameCollision/parent/Parent.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestNameCollision/parent/Parent.hs @@ -0,0 +1,1 @@ +module Parent where diff --git a/tests/PackageTests/TestNameCollision/parent/parent.cabal b/tests/PackageTests/TestNameCollision/parent/parent.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestNameCollision/parent/parent.cabal @@ -0,0 +1,13 @@ +name: parent +version: 0.1 +description: This package is what the test suite is going to collide with +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Parent + build-depends: base + default-language: Haskell2010 diff --git a/tests/PackageTests/TestOptions/Check.hs b/tests/PackageTests/TestOptions/Check.hs deleted file mode 100644 --- a/tests/PackageTests/TestOptions/Check.hs +++ /dev/null @@ -1,26 +0,0 @@ -module PackageTests.TestOptions.Check where - -import PackageTests.PackageTester -import System.FilePath -import Test.HUnit - -suite :: FilePath -> Test -suite ghcPath = TestCase $ do - let spec = PackageSpec - { directory = "PackageTests" "TestOptions" - , configOpts = ["--enable-tests"] - , distPref = Nothing - } - _ <- 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 - result' <- cabal_test spec [] [ "--test-option=1" - , "--test-option=2" - , "--test-option=3" - ] - 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/TestStanza/Check.hs b/tests/PackageTests/TestStanza/Check.hs --- a/tests/PackageTests/TestStanza/Check.hs +++ b/tests/PackageTests/TestStanza/Check.hs @@ -1,53 +1,29 @@ module PackageTests.TestStanza.Check where -import Test.HUnit -import System.FilePath -import qualified Data.Map as Map import PackageTests.PackageTester + import Distribution.Version -import Distribution.PackageDescription.Parse (readPackageDescription) -import Distribution.PackageDescription.Configuration - (finalizePackageDescription) -import Distribution.Package (PackageName(..), Dependency(..)) +import Distribution.Simple.LocalBuildInfo +import Distribution.Package import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), TestSuite(..) - , TestSuiteInterface(..), emptyBuildInfo, emptyTestSuite - , defaultRenaming) -import Distribution.Verbosity (silent) -import Distribution.System (buildPlatform) -import Distribution.Compiler - ( CompilerId(..), CompilerFlavor(..), unknownCompilerInfo, AbiTag(..) ) -import Distribution.Text -suite :: FilePath -> Test -suite ghcPath = TestCase $ do - let dir = "PackageTests" "TestStanza" - pdFile = dir "my" <.> "cabal" - spec = PackageSpec - { directory = dir - , configOpts = [] - , distPref = Nothing - } - result <- cabal_configure spec ghcPath - assertOutputDoesNotContain "unknown section type" result - genPD <- readPackageDescription silent pdFile - let compiler = unknownCompilerInfo (CompilerId GHC $ Version [6, 12, 2] []) NoAbiTag - anticipatedTestSuite = emptyTestSuite +suite :: TestM () +suite = do + assertOutputDoesNotContain "unknown section type" + =<< cabal' "configure" [] + dist_dir <- distDir + lbi <- liftIO $ getPersistBuildConfig dist_dir + let anticipatedTestSuite = emptyTestSuite { testName = "dummy" , testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs" , testBuildInfo = emptyBuildInfo { targetBuildDepends = [ Dependency (PackageName "base") anyVersion ] - , targetBuildRenaming = - Map.singleton (PackageName "base") defaultRenaming , hsSourceDirs = ["."] } , testEnabled = False } - case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of - Left xs -> let depMessage = "should not have missing dependencies:\n" ++ - (unlines $ map (show . disp) xs) - in assertEqual depMessage True False - Right (f, _) -> let gotTest = head $ testSuites f - in assertEqual "parsed test-suite stanza does not match anticipated" - gotTest anticipatedTestSuite + gotTestSuite = head $ testSuites (localPkgDescr lbi) + assertEqual "parsed test-suite stanza does not match anticipated" + anticipatedTestSuite gotTestSuite + return () diff --git a/tests/PackageTests/TestSuiteExeV10/Check.hs b/tests/PackageTests/TestSuiteExeV10/Check.hs deleted file mode 100644 --- a/tests/PackageTests/TestSuiteExeV10/Check.hs +++ /dev/null @@ -1,147 +0,0 @@ -module PackageTests.TestSuiteExeV10.Check (checks) where - -import qualified Control.Exception as E (IOException, catch) -import Control.Monad (when) -import Data.Maybe (catMaybes) -import System.Directory ( doesFileExist ) -import System.FilePath -import qualified Test.Framework as TF -import Test.Framework (testGroup) -import Test.Framework.Providers.HUnit (hUnitTestToTests) -import Test.HUnit hiding ( path ) - -import Distribution.Compiler (CompilerFlavor(..), CompilerId(..)) -import Distribution.PackageDescription (package) -import Distribution.Simple.Compiler (compilerId) -import Distribution.Simple.Configure (getPersistBuildConfig) -import Distribution.Simple.LocalBuildInfo (compiler, localPkgDescr, pkgKey) -import Distribution.Simple.Hpc -import Distribution.Simple.Program.Builtin (hpcProgram) -import Distribution.Simple.Program.Db - ( emptyProgramDb, configureProgram, requireProgramVersion ) -import Distribution.Text (display) -import qualified Distribution.Verbosity as Verbosity -import Distribution.Version (Version(..), orLaterVersion) - -import PackageTests.PackageTester - -checks :: FilePath -> [TF.Test] -checks ghcPath = - [ hunit "Test" $ checkTest ghcPath ] - ++ hpcTestMatrix ghcPath ++ - [ hunit "TestNoHpc/NoTix" $ checkTestNoHpcNoTix ghcPath - , hunit "TestNoHpc/NoMarkup" $ checkTestNoHpcNoMarkup ghcPath - ] - -hpcTestMatrix :: FilePath -> [TF.Test] -hpcTestMatrix ghcPath = do - libProf <- [True, False] - exeProf <- [True, False] - exeDyn <- [True, False] - shared <- [True, False] - let name = concat - [ "WithHpc-" - , if libProf then "LibProf" else "" - , if exeProf then "ExeProf" else "" - , if exeDyn then "ExeDyn" else "" - , if shared then "Shared" else "" - ] - enable cond flag - | cond = Just $ "--enable-" ++ flag - | otherwise = Nothing - opts = catMaybes - [ enable libProf "library-profiling" - , enable exeProf "profiling" - , enable exeDyn "executable-dynamic" - , enable shared "shared" - ] - return $ hunit name $ checkTestWithHpc ghcPath name opts - -dir :: FilePath -dir = "PackageTests" "TestSuiteExeV10" - -checkTest :: FilePath -> Test -checkTest ghcPath = TestCase $ buildAndTest ghcPath "Default" [] [] - -shouldExist :: FilePath -> Assertion -shouldExist path = doesFileExist path >>= assertBool (path ++ " should exist") - -shouldNotExist :: FilePath -> Assertion -shouldNotExist path = - doesFileExist path >>= assertBool (path ++ " should exist") . not - --- | Ensure that both .tix file and markup are generated if coverage is enabled. -checkTestWithHpc :: FilePath -> String -> [String] -> Test -checkTestWithHpc ghcPath name extraOpts = TestCase $ do - isCorrectVersion <- correctHpcVersion - when isCorrectVersion $ do - let distPref' = dir "dist-" ++ name - buildAndTest ghcPath name [] ("--enable-coverage" : extraOpts) - lbi <- getPersistBuildConfig distPref' - let way = guessWay lbi - CompilerId comp version = compilerId (compiler lbi) - subdir - | comp == GHC && version >= Version [7, 10] [] = - display (pkgKey lbi) - | otherwise = display (package $ localPkgDescr lbi) - mapM_ shouldExist - [ mixDir distPref' way "my-0.1" subdir "Foo.mix" - , mixDir distPref' way "test-Foo" "Main.mix" - , tixFilePath distPref' way "test-Foo" - , htmlDir distPref' way "test-Foo" "hpc_index.html" - ] - --- | Ensures that even if -fhpc is manually provided no .tix file is output. -checkTestNoHpcNoTix :: FilePath -> Test -checkTestNoHpcNoTix ghcPath = TestCase $ do - buildAndTest ghcPath "NoHpcNoTix" [] - [ "--ghc-option=-fhpc" - , "--ghc-option=-hpcdir" - , "--ghc-option=dist-NoHpcNoTix/hpc/vanilla" ] - lbi <- getPersistBuildConfig (dir "dist-NoHpcNoTix") - let way = guessWay lbi - shouldNotExist $ tixFilePath (dir "dist-NoHpcNoTix") way "test-Foo" - --- | Ensures that even if a .tix file happens to be left around --- markup isn't generated. -checkTestNoHpcNoMarkup :: FilePath -> Test -checkTestNoHpcNoMarkup ghcPath = TestCase $ do - let tixFile = tixFilePath "dist-NoHpcNoMarkup" Vanilla "test-Foo" - buildAndTest ghcPath "NoHpcNoMarkup" - [("HPCTIXFILE", Just tixFile)] - [ "--ghc-option=-fhpc" - , "--ghc-option=-hpcdir" - , "--ghc-option=dist-NoHpcNoMarkup/hpc/vanilla" ] - shouldNotExist $ htmlDir (dir "dist-NoHpcNoMarkup") Vanilla "test-Foo" "hpc_index.html" - --- | Build and test a package and ensure that both were successful. --- --- The flag "--enable-tests" is provided in addition to the given flags. -buildAndTest :: FilePath -> String -> [(String, Maybe String)] -> [String] -> IO () -buildAndTest ghcPath name envOverrides flags = do - let spec = PackageSpec - { directory = dir - , distPref = Just $ "dist-" ++ name - , configOpts = "--enable-tests" : flags - } - buildResult <- cabal_build spec ghcPath - assertBuildSucceeded buildResult - testResult <- cabal_test spec envOverrides [] ghcPath - assertTestSucceeded testResult - -hunit :: TF.TestName -> Test -> TF.Test -hunit name = testGroup name . hUnitTestToTests - --- | Checks for a suitable HPC version for testing. -correctHpcVersion :: IO Bool -correctHpcVersion = 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) - where - -- Distribution.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 deleted file mode 100644 --- a/tests/PackageTests/TestSuiteExeV10/Foo.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Foo where - -fooTest :: [String] -> Bool -fooTest _ = True diff --git a/tests/PackageTests/TestSuiteExeV10/my.cabal b/tests/PackageTests/TestSuiteExeV10/my.cabal deleted file mode 100644 --- a/tests/PackageTests/TestSuiteExeV10/my.cabal +++ /dev/null @@ -1,15 +0,0 @@ -name: my -version: 0.1 -license: BSD3 -cabal-version: >= 1.9.2 -build-type: Simple - -library - exposed-modules: Foo - build-depends: base - -test-suite test-Foo - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: test-Foo.hs - build-depends: base, my diff --git a/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs b/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs deleted file mode 100644 --- a/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Main where - -import Foo -import System.Exit - -main :: IO () -main | fooTest [] = exitSuccess - | otherwise = exitFailure diff --git a/tests/PackageTests/TestSuiteTests/ExeV10/Check.hs b/tests/PackageTests/TestSuiteTests/ExeV10/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteTests/ExeV10/Check.hs @@ -0,0 +1,129 @@ +module PackageTests.TestSuiteTests.ExeV10.Check (tests) where + +import qualified Control.Exception as E (IOException, catch) +import Control.Monad (forM_, liftM4, when) +import Data.Maybe (catMaybes) +import System.FilePath +import Test.Tasty.HUnit (testCase) + +import Distribution.Compiler (CompilerFlavor(..), CompilerId(..)) +import Distribution.PackageDescription (package) +import Distribution.Simple.Compiler (compilerId) +import Distribution.Simple.LocalBuildInfo (compiler, localPkgDescr, localCompatPackageKey) +import Distribution.Simple.Hpc +import Distribution.Simple.Program.Builtin (hpcProgram) +import Distribution.Simple.Program.Db + ( emptyProgramDb, configureProgram, requireProgramVersion ) +import Distribution.Text (display) +import qualified Distribution.Verbosity as Verbosity +import Distribution.Version (Version(..), orLaterVersion) + +import PackageTests.PackageTester + +tests :: SuiteConfig -> TestTreeM () +tests config = do + -- TODO: hierarchy and subnaming is a little unfortunate + tc "Test" "Default" $ do + cabal_build ["--enable-tests"] + -- This one runs both tests, including the very LONG Foo + -- test which prints a lot of output + cabal "test" ["--show-details=direct"] + groupTests "WithHpc" $ hpcTestMatrix config + groupTests "WithoutHpc" $ do + -- Ensures that even if -fhpc is manually provided no .tix file is output. + tc "NoTix" "NoHpcNoTix" $ do + dist_dir <- distDir + cabal_build + [ "--enable-tests" + , "--ghc-option=-fhpc" + , "--ghc-option=-hpcdir" + , "--ghc-option=" ++ dist_dir ++ "/hpc/vanilla" ] + cabal "test" ["test-Short", "--show-details=direct"] + lbi <- liftIO $ getPersistBuildConfig dist_dir + let way = guessWay lbi + shouldNotExist $ tixFilePath dist_dir way "test-Short" + -- Ensures that even if a .tix file happens to be left around + -- markup isn't generated. + tc "NoMarkup" "NoHpcNoMarkup" $ do + dist_dir <- distDir + let tixFile = tixFilePath dist_dir Vanilla "test-Short" + withEnv [("HPCTIXFILE", Just tixFile)] $ do + cabal_build + [ "--enable-tests" + , "--ghc-option=-fhpc" + , "--ghc-option=-hpcdir" + , "--ghc-option=" ++ dist_dir ++ "/hpc/vanilla" ] + cabal "test" ["test-Short", "--show-details=direct"] + shouldNotExist $ htmlDir dist_dir Vanilla "test-Short" "hpc_index.html" + where + tc :: String -> String -> TestM a -> TestTreeM () + tc name subname m + = testTree' $ testCase name + (runTestM config "TestSuiteTests/ExeV10" (Just subname) m) + +hpcTestMatrix :: SuiteConfig -> TestTreeM () +hpcTestMatrix config = forM_ (choose4 [True, False]) $ + \(libProf, exeProf, exeDyn, shared) -> do + let name | null suffixes = "Vanilla" + | otherwise = intercalate "-" suffixes + where + suffixes = catMaybes + [ if libProf then Just "LibProf" else Nothing + , if exeProf then Just "ExeProf" else Nothing + , if exeDyn then Just "ExeDyn" else Nothing + , if shared then Just "Shared" else Nothing + ] + opts = catMaybes + [ enable libProf "library-profiling" + , enable exeProf "profiling" + , enable exeDyn "executable-dynamic" + , enable shared "shared" + ] + where + enable cond flag + | cond = Just $ "--enable-" ++ flag + | otherwise = Nothing + -- Ensure that both .tix file and markup are generated if coverage + -- is enabled. + testUnless ((exeDyn || shared) && not (hasSharedLibraries config)) $ + tc name ("WithHpc-" ++ name) $ do + isCorrectVersion <- liftIO $ correctHpcVersion + when isCorrectVersion $ do + dist_dir <- distDir + cabal_build ("--enable-tests" : "--enable-coverage" : opts) + cabal "test" ["test-Short", "--show-details=direct"] + lbi <- liftIO $ getPersistBuildConfig dist_dir + let way = guessWay lbi + CompilerId comp version = compilerId (compiler lbi) + subdir + | comp == GHC && version >= Version [7, 10] [] = + localCompatPackageKey lbi + | otherwise = display (package $ localPkgDescr lbi) + mapM_ shouldExist + [ mixDir dist_dir way "my-0.1" subdir "Foo.mix" + , mixDir dist_dir way "test-Short" "Main.mix" + , tixFilePath dist_dir way "test-Short" + , htmlDir dist_dir way "test-Short" "hpc_index.html" + ] + where + tc :: String -> String -> TestM a -> TestTreeM () + tc name subname m + = testTree' $ testCase name + (runTestM config "TestSuiteTests/ExeV10" (Just subname) m) + + choose4 :: [a] -> [(a, a, a, a)] + choose4 xs = liftM4 (,,,) xs xs xs xs + +-- | Checks for a suitable HPC version for testing. +correctHpcVersion :: IO Bool +correctHpcVersion = 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) + where + -- Distribution.Compat.Exception is hidden. + catchIO :: IO a -> (E.IOException -> IO a) -> IO a + catchIO = E.catch diff --git a/tests/PackageTests/TestSuiteTests/ExeV10/Foo.hs b/tests/PackageTests/TestSuiteTests/ExeV10/Foo.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteTests/ExeV10/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +fooTest :: [String] -> Bool +fooTest _ = True diff --git a/tests/PackageTests/TestSuiteTests/ExeV10/my.cabal b/tests/PackageTests/TestSuiteTests/ExeV10/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteTests/ExeV10/my.cabal @@ -0,0 +1,21 @@ +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 + +test-suite test-Short + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: test-Short.hs + build-depends: base, my diff --git a/tests/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs b/tests/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs @@ -0,0 +1,12 @@ +module Main where + +import Foo +import System.Exit +import Control.Monad + +main :: IO () +main | fooTest [] = do + -- Make sure that the output buffer is drained + replicateM 10000 $ putStrLn "The quick brown fox jumps over the lazy dog" + exitSuccess + | otherwise = exitFailure diff --git a/tests/PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs b/tests/PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs @@ -0,0 +1,11 @@ +module Main where + +import Foo +import System.Exit +import Control.Monad + +main :: IO () +main | fooTest [] = do + replicateM 5 $ putStrLn "The quick brown fox jumps over the lazy dog" + exitSuccess + | otherwise = exitFailure diff --git a/tests/PackageTests/TestSuiteTests/LibV09/Lib.hs b/tests/PackageTests/TestSuiteTests/LibV09/Lib.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteTests/LibV09/Lib.hs @@ -0,0 +1,11 @@ +module Lib where + +import Distribution.TestSuite + +nullt x = Test $ TestInstance + { run = return $ Finished (Fail "no reason") + , name = "test " ++ show x + , tags = [] + , options = [] + , setOption = \_ _-> Left "No Options" + } diff --git a/tests/PackageTests/TestSuiteTests/LibV09/LibV09.cabal b/tests/PackageTests/TestSuiteTests/LibV09/LibV09.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteTests/LibV09/LibV09.cabal @@ -0,0 +1,21 @@ +name: LibV09 +version: 0.1 +cabal-version: >= 1.2 +license: BSD3 +author: Thomas Tuegel +stability: stable +category: PackageTests +build-type: Simple +cabal-version: >= 1.9.2 + +description: Check type detailed-0.9 test suites. + +library + exposed-modules: Lib + build-depends: base, Cabal + +test-suite LibV09-Deadlock + type: detailed-0.9 + hs-source-dirs: tests + test-module: Deadlock + build-depends: base, Cabal, LibV09 diff --git a/tests/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs b/tests/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs @@ -0,0 +1,8 @@ +module Deadlock where + +import Distribution.TestSuite + +import Lib + +tests :: IO [Test] +tests = return [nullt x | x <- [1 .. 1000]] diff --git a/tests/PackageTests/Tests.hs b/tests/PackageTests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/Tests.hs @@ -0,0 +1,307 @@ +module PackageTests.Tests(tests) where + +import PackageTests.PackageTester + +import qualified PackageTests.BenchmarkStanza.Check +import qualified PackageTests.TestStanza.Check +import qualified PackageTests.DeterministicAr.Check +import qualified PackageTests.TestSuiteTests.ExeV10.Check + +import Control.Monad + +import Data.Version +import Test.Tasty (mkTimeout, localOption) +import Test.Tasty.HUnit (testCase) + +tests :: SuiteConfig -> TestTreeM () +tests config = do + + --------------------------------------------------------------------- + -- * External tests + + -- Test that Cabal parses 'benchmark' sections correctly + tc "BenchmarkStanza" PackageTests.BenchmarkStanza.Check.suite + + -- Test that Cabal parses 'test' sections correctly + tc "TestStanza" PackageTests.TestStanza.Check.suite + + -- Test that Cabal determinstically generates object archives + tc "DeterministicAr" PackageTests.DeterministicAr.Check.suite + + --------------------------------------------------------------------- + -- * Test suite tests + + groupTests "TestSuiteTests" $ do + + -- Test exitcode-stdio-1.0 test suites (and HPC) + groupTests "ExeV10" + (PackageTests.TestSuiteTests.ExeV10.Check.tests config) + + -- Test detailed-0.9 test suites + groupTests "LibV09" $ + let + tcs :: FilePath -> TestM a -> TestTreeM () + tcs name m + = testTree' $ testCase name (runTestM config + "TestSuiteTests/LibV09" (Just name) m) + in do + -- Test if detailed-0.9 builds correctly + tcs "Build" $ cabal_build ["--enable-tests"] + + -- Tests for #2489, stdio deadlock + mapTestTrees (localOption (mkTimeout $ 10 ^ (8 :: Int))) + . tcs "Deadlock" $ do + cabal_build ["--enable-tests"] + shouldFail $ cabal "test" [] + + --------------------------------------------------------------------- + -- * Inline tests + + -- Test if exitcode-stdio-1.0 benchmark builds correctly + tc "BenchmarkExeV10" $ cabal_build ["--enable-benchmarks"] + + -- Test --benchmark-option(s) flags on ./Setup bench + tc "BenchmarkOptions" $ do + cabal_build ["--enable-benchmarks"] + cabal "bench" [ "--benchmark-options=1 2 3" ] + cabal "bench" [ "--benchmark-option=1" + , "--benchmark-option=2" + , "--benchmark-option=3" + ] + + -- Test --test-option(s) flags on ./Setup test + tc "TestOptions" $ do + cabal_build ["--enable-tests"] + cabal "test" ["--test-options=1 2 3"] + cabal "test" [ "--test-option=1" + , "--test-option=2" + , "--test-option=3" + ] + + -- Test attempt to have executable depend on internal + -- library, but cabal-version is too old. + tc "BuildDeps/InternalLibrary0" $ do + r <- shouldFail $ cabal' "configure" [] + -- Should tell you how to enable the desired behavior + let sb = "library which is defined within the same package." + assertOutputContains sb r + + -- Test executable depends on internal library. + tc "BuildDeps/InternalLibrary1" $ cabal_build [] + + -- Test that internal library is preferred to an installed on + -- with the same name and version + tc "BuildDeps/InternalLibrary2" $ internal_lib_test "internal" + + -- Test that internal library is preferred to an installed on + -- with the same name and LATER version + tc "BuildDeps/InternalLibrary3" $ internal_lib_test "internal" + + -- Test that an explicit dependency constraint which doesn't + -- match the internal library causes us to use external library + tc "BuildDeps/InternalLibrary4" $ internal_lib_test "installed" + + -- Test "old build-dep behavior", where we should get the + -- same package dependencies on all targets if cabal-version + -- is sufficiently old. + tc "BuildDeps/SameDepsAllRound" $ cabal_build [] + + -- Test "new build-dep behavior", where each target gets + -- separate dependencies. This tests that an executable + -- dep does not leak into the library. + tc "BuildDeps/TargetSpecificDeps1" $ do + cabal "configure" [] + r <- shouldFail $ cabal' "build" [] + assertRegex "error should be in MyLibrary.hs" "^MyLibrary.hs:" r + assertRegex + "error should be \"Could not find module `Text\\.PrettyPrint\"" + "(Could not find module|Failed to load interface for).*Text\\.PrettyPrint" r + + -- This is a control on TargetSpecificDeps1; it should + -- succeed. + tc "BuildDeps/TargetSpecificDeps2" $ cabal_build [] + + -- Test "new build-dep behavior", where each target gets + -- separate dependencies. This tests that an library + -- dep does not leak into the executable. + tc "BuildDeps/TargetSpecificDeps3" $ do + cabal "configure" [] + r <- shouldFail $ cabal' "build" [] + assertRegex "error should be in lemon.hs" "^lemon.hs:" r + assertRegex + "error should be \"Could not find module `Text\\.PrettyPrint\"" + "(Could not find module|Failed to load interface for).*Text\\.PrettyPrint" r + + -- Test that Paths module is generated and available for executables. + tc "PathsModule/Executable" $ cabal_build [] + + -- Test that Paths module is generated and available for libraries. + tc "PathsModule/Library" $ cabal_build [] + + -- Check that preprocessors (hsc2hs) are run + tc "PreProcess" $ cabal_build ["--enable-tests", "--enable-benchmarks"] + + -- Check that preprocessors that generate extra C sources are handled + tc "PreProcessExtraSources" $ cabal_build ["--enable-tests", + "--enable-benchmarks"] + + -- Test building a vanilla library/executable which uses Template Haskell + tc "TemplateHaskell/vanilla" $ cabal_build [] + + -- Test building a profiled library/executable which uses Template Haskell + -- (Cabal has to build the non-profiled version first) + tc "TemplateHaskell/profiling" $ cabal_build ["--enable-library-profiling", + "--enable-profiling"] + + -- Test building a dynamic library/executable which uses Template + -- Haskell + testWhen (hasSharedLibraries config) $ + tc "TemplateHaskell/dynamic" $ cabal_build ["--enable-shared", + "--enable-executable-dynamic"] + + -- Test building an executable whose main() function is defined in a C + -- file + tc "CMain" $ cabal_build [] + + -- Test build when the library is empty, for #1241 + tc "EmptyLib" $ + withPackage "empty" $ cabal_build [] + + -- Test that "./Setup haddock" works correctly + tc "Haddock" $ do + dist_dir <- distDir + let haddocksDir = dist_dir "doc" "html" "Haddock" + cabal "configure" [] + cabal "haddock" [] + let docFiles + = map (haddocksDir ) + ["CPP.html", "Literate.html", "NoCPP.html", "Simple.html"] + mapM_ (assertFindInFile "For hiding needles.") docFiles + + -- Test that Haddock with a newline in synopsis works correctly, #3004 + tc "HaddockNewline" $ do + cabal "configure" [] + cabal "haddock" [] + + -- Test that Cabal properly orders GHC flags passed to GHC (when + -- there are multiple ghc-options fields.) + tc "OrderFlags" $ cabal_build [] + + -- Test that reexported modules build correctly + -- TODO: should also test that they import OK! + tc "ReexportedModules" $ do + whenGhcVersion (>= Version [7,9] []) $ cabal_build [] + + -- Test that Cabal computes different IPIDs when the source changes. + tc "UniqueIPID" . withPackageDb $ do + withPackage "P1" $ cabal "configure" [] + withPackage "P2" $ cabal "configure" [] + withPackage "P1" $ cabal "build" [] + withPackage "P1" $ cabal "build" [] -- rebuild should work + r1 <- withPackage "P1" $ cabal' "register" ["--print-ipid", "--inplace"] + withPackage "P2" $ cabal "build" [] + r2 <- withPackage "P2" $ cabal' "register" ["--print-ipid", "--inplace"] + let exIPID s = takeWhile (/= '\n') $ + head . filter (isPrefixOf $ "UniqueIPID-0.1-") $ (tails s) + when ((exIPID $ resultOutput r1) == (exIPID $ resultOutput r2)) $ + assertFailure $ "cabal has not calculated different Installed " ++ + "package ID when source is changed." + + tc "DuplicateModuleName" $ do + cabal_build ["--enable-tests"] + r1 <- shouldFail $ cabal' "test" ["foo"] + assertOutputContains "test B" r1 + assertOutputContains "test A" r1 + r2 <- shouldFail $ cabal' "test" ["foo2"] + assertOutputContains "test C" r2 + assertOutputContains "test A" r2 + + tc "TestNameCollision" $ do + withPackageDb $ do + withPackage "parent" $ cabal_install [] + withPackage "child" $ do + cabal_build ["--enable-tests"] + cabal "test" [] + + -- Test that '--allow-newer' works via the 'Setup.hs configure' interface. + tc "AllowNewer" $ do + shouldFail $ cabal "configure" [] + cabal "configure" ["--allow-newer"] + shouldFail $ cabal "configure" ["--allow-newer=baz,quux"] + cabal "configure" ["--allow-newer=base", "--allow-newer=baz,quux"] + cabal "configure" ["--allow-newer=bar", "--allow-newer=base,baz" + ,"--allow-newer=quux"] + shouldFail $ cabal "configure" ["--enable-tests"] + cabal "configure" ["--enable-tests", "--allow-newer"] + shouldFail $ cabal "configure" ["--enable-benchmarks"] + cabal "configure" ["--enable-benchmarks", "--allow-newer"] + shouldFail $ cabal "configure" ["--enable-benchmarks", "--enable-tests"] + cabal "configure" ["--enable-benchmarks", "--enable-tests" + ,"--allow-newer"] + shouldFail $ cabal "configure" ["--allow-newer=Foo:base"] + shouldFail $ cabal "configure" ["--allow-newer=Foo:base" + ,"--enable-tests", "--enable-benchmarks"] + cabal "configure" ["--allow-newer=AllowNewer:base"] + cabal "configure" ["--allow-newer=AllowNewer:base" + ,"--allow-newer=Foo:base"] + cabal "configure" ["--allow-newer=AllowNewer:base" + ,"--allow-newer=Foo:base" + ,"--enable-tests", "--enable-benchmarks"] + + -- Test that Cabal can choose flags to disable building a component when that + -- component's dependencies are unavailable. The build should succeed without + -- requiring the component's dependencies or imports. + tc "BuildableField" $ do + r <- cabal' "configure" ["-v"] + assertOutputContains "Flags chosen: build-exe=False" r + cabal "build" [] + + -- TODO: Enable these tests on Windows + unlessWindows $ do + tc "GhcPkgGuess/SameDirectory" $ ghc_pkg_guess "ghc" + tc "GhcPkgGuess/SameDirectoryVersion" $ ghc_pkg_guess "ghc-7.10" + tc "GhcPkgGuess/SameDirectoryGhcVersion" $ ghc_pkg_guess "ghc-7.10" + + unlessWindows $ do + tc "GhcPkgGuess/Symlink" $ do + -- We don't want to distribute a tarball with symlinks. See #3190. + withSymlink "bin/ghc" + "tests/PackageTests/GhcPkgGuess/Symlink/ghc" $ + ghc_pkg_guess "ghc" + + tc "GhcPkgGuess/SymlinkVersion" $ do + withSymlink "bin/ghc-7.10" + "tests/PackageTests/GhcPkgGuess/SymlinkVersion/ghc" $ + ghc_pkg_guess "ghc" + + tc "GhcPkgGuess/SymlinkGhcVersion" $ do + withSymlink "bin/ghc-7.10" + "tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/ghc" $ + ghc_pkg_guess "ghc" + + where + ghc_pkg_guess bin_name = do + cwd <- packageDir + with_ghc <- getWithGhcPath + r <- withEnv [("WITH_GHC", Just with_ghc)] + . shouldFail $ cabal' "configure" ["-w", cwd bin_name] + assertOutputContains "is version 9999999" r + return () + + -- Shared test function for BuildDeps/InternalLibrary* tests. + internal_lib_test expect = withPackageDb $ do + withPackage "to-install" $ cabal_install [] + cabal_build [] + r <- runExe' "lemon" [] + assertEqual + ("executable should have linked with the " ++ expect ++ " library") + ("foo foo myLibFunc " ++ expect) + (concatOutput (resultOutput r)) + + assertRegex :: String -> String -> Result -> TestM () + assertRegex msg regex r = let out = resultOutput r + in assertBool (msg ++ ",\nactual output:\n" ++ out) + (out =~ regex) + + tc :: FilePath -> TestM a -> TestTreeM () + tc name = testTree config name Nothing diff --git a/tests/PackageTests/UniqueIPID/P1/M.hs b/tests/PackageTests/UniqueIPID/P1/M.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/UniqueIPID/P1/M.hs @@ -0,0 +1,3 @@ +module M(m) where + +m = print "1" diff --git a/tests/PackageTests/UniqueIPID/P1/my.cabal b/tests/PackageTests/UniqueIPID/P1/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/UniqueIPID/P1/my.cabal @@ -0,0 +1,15 @@ +name: UniqueIPID +version: 0.1 +license: BSD3 +author: Vishal Agrawal +stability: stable +category: PackageTests +build-type: Simple +Cabal-version: >= 1.2 + +description: + Check that Cabal generates unique IPID based on source. + +Library + exposed-modules: M + build-depends: base diff --git a/tests/PackageTests/UniqueIPID/P2/M.hs b/tests/PackageTests/UniqueIPID/P2/M.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/UniqueIPID/P2/M.hs @@ -0,0 +1,3 @@ +module M(m) where + +m = print "2" diff --git a/tests/PackageTests/UniqueIPID/P2/my.cabal b/tests/PackageTests/UniqueIPID/P2/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/UniqueIPID/P2/my.cabal @@ -0,0 +1,15 @@ +name: UniqueIPID +version: 0.1 +license: BSD3 +author: Vishal Agrawal +stability: stable +category: PackageTests +build-type: Simple +Cabal-version: >= 1.2 + +description: + Check that Cabal generates unique IPID based on source. + +Library + exposed-modules: M + build-depends: base, containers diff --git a/tests/PackageTests/multInst/my.cabal b/tests/PackageTests/multInst/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/multInst/my.cabal @@ -0,0 +1,16 @@ +name: Haddock +version: 0.1 +license: BSD3 +author: Iain Nicol +stability: stable +category: PackageTests +build-type: Simple +Cabal-version: >= 1.2 + +description: + Check that Cabal successfully invokes Haddock. + +Library + exposed-modules: CPP, Literate, NoCPP, Simple + other-extensions: CPP + build-depends: base diff --git a/tests/README.md b/tests/README.md --- a/tests/README.md +++ b/tests/README.md @@ -8,23 +8,27 @@ of Cabal's build process in [PackageTests/PackageTester.hs]; have a look at an existing test case to see how they are used. -It is 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: +In order to run the tests, `PackageTests` needs to know where the inplace +copy of Cabal being tested is, as well as some information which was +used to configure it. By default, `PackageTests` tries to look at the +`LocalBuildInfo`, but if the format of `LocalBuildInfo` has changed +between the version of Cabal which ran the configure step, and the +version of Cabal we are testing against, this may fail. In that +case, you can manually specify the information we need using +the following environment variables: -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]. +* `CABAL_PACKAGETESTS_GHC` is the path to the GHC you compiled Cabal with +* `CABAL_PACKAGETESTS_GHC_PKG` is the path to the ghc-pkg associated with this GHC +* `CABAL_PACKAGETESTS_HADDOCK` is the path to the haddock associated with this GHC +* `CABAL_PACKAGETESTS_GHC_VERSION` is the version of your GHC +* `CABAL_PACKAGETESTS_DB_STACK` is a PATH-style list of package database paths, + `clear`, `global` and `user`. Each component of the list is + interpreted the same way as Cabal's `-package-db` flag. This list + must contain the copy of Cabal you are planning to test against + (as well as its transitive dependencies). -2. Compiling a package which depends on Cabal. In particular, packages - with the [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. +If you can successfully run the test suite, we'll print out examples +of all of these values for you under "Environment". [PackageTests]: PackageTests [HUnit]: http://hackage.haskell.org/package/HUnit diff --git a/tests/Test/Laws.hs b/tests/Test/Laws.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Laws.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Test.Laws where + +import Prelude hiding (Num((+), (*))) +import Data.Monoid (Monoid(..), Endo(..)) +import qualified Data.Foldable as Foldable + +idempotent_unary f x = f fx == fx where fx = f x + +-- Basic laws on binary operators + +idempotent_binary (+) x = x + x == x + +commutative (+) x y = x + y == y + x + +associative (+) x y z = (x + y) + z == x + (y + z) + +distributive_left (*) (+) x y z = x * (y + z) == (x * y) + (x * z) + +distributive_right (*) (+) x y z = (y + z) * x == (y * x) + (z * x) + + +-- | The first 'fmap' law +-- +-- > fmap id == id +-- +fmap_1 :: (Eq (f a), Functor f) => f a -> Bool +fmap_1 x = fmap id x == x + +-- | The second 'fmap' law +-- +-- > fmap (f . g) == fmap f . fmap g +-- +fmap_2 :: (Eq (f c), Functor f) => (b -> c) -> (a -> b) -> f a -> Bool +fmap_2 f g x = fmap (f . g) x == (fmap f . fmap g) x + + +-- | The monoid identity law, 'mempty' is a left and right identity of +-- 'mappend': +-- +-- > mempty `mappend` x = x +-- > x `mappend` mempty = x +-- +monoid_1 :: (Eq a, Data.Monoid.Monoid a) => a -> Bool +monoid_1 x = mempty `mappend` x == x + && x `mappend` mempty == x + +-- | The monoid associativity law, 'mappend' must be associative. +-- +-- > (x `mappend` y) `mappend` z = x `mappend` (y `mappend` z) +-- +monoid_2 :: (Eq a, Data.Monoid.Monoid a) => a -> a -> a -> Bool +monoid_2 x y z = (x `mappend` y) `mappend` z + == x `mappend` (y `mappend` z) + +-- | The 'mconcat' definition. It can be overidden for the sake of effeciency +-- but it must still satisfy the property given by the default definition: +-- +-- > mconcat = foldr mappend mempty +-- +monoid_3 :: (Eq a, Data.Monoid.Monoid a) => [a] -> Bool +monoid_3 xs = mconcat xs == foldr mappend mempty xs + + +-- | First 'Foldable' law +-- +-- > Foldable.fold = Foldable.foldr mappend mempty +-- +foldable_1 :: (Foldable.Foldable t, Monoid m, Eq m) => t m -> Bool +foldable_1 x = Foldable.fold x == Foldable.foldr mappend mempty x + +-- | Second 'Foldable' law +-- +-- > foldr f z t = appEndo (foldMap (Endo . f) t) z +-- +foldable_2 :: (Foldable.Foldable t, Eq b) + => (a -> b -> b) -> b -> t a -> Bool +foldable_2 f z t = Foldable.foldr f z t + == appEndo (Foldable.foldMap (Endo . f) t) z diff --git a/tests/Test/QuickCheck/Utils.hs b/tests/Test/QuickCheck/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Test/QuickCheck/Utils.hs @@ -0,0 +1,29 @@ +module Test.QuickCheck.Utils where + +import Test.QuickCheck.Gen + + +-- | Adjust the size of the generated value. +-- +-- In general the size gets bigger and bigger linearly. For some types +-- it is not appropriate to generate ever bigger values but instead +-- to generate lots of intermediate sized values. You could do that using: +-- +-- > adjustSize (\n -> min n 5) +-- +-- Similarly, for some types the linear size growth may mean getting too big +-- too quickly relative to other values. So you may want to adjust how +-- quickly the size grows. For example dividing by a constant, or even +-- something like the integer square root or log. +-- +-- > adjustSize (\n -> n `div` 2) +-- +-- Putting this together we can make for example a relatively short list: +-- +-- > adjustSize (\n -> min 5 (n `div` 3)) (listOf1 arbitrary) +-- +-- Not only do we put a limit on the length but we also scale the growth to +-- prevent it from hitting the maximum size quite so early. +-- +adjustSize :: (Int -> Int) -> Gen a -> Gen a +adjustSize adjust gen = sized (\n -> resize (adjust n) gen) diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -2,26 +2,33 @@ ( main ) where -import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout) -import Test.Framework +import Test.Tasty import qualified UnitTests.Distribution.Compat.CreatePipe import qualified UnitTests.Distribution.Compat.ReadP +import qualified UnitTests.Distribution.Simple.Program.Internal +import qualified UnitTests.Distribution.Simple.Utils +import qualified UnitTests.Distribution.System import qualified UnitTests.Distribution.Utils.NubList +import qualified UnitTests.Distribution.Version (versionTests) -tests :: [Test] -tests = - [ testGroup "Distribution.Compat.ReadP" - UnitTests.Distribution.Compat.ReadP.tests - , testGroup "Distribution.Compat.CreatePipe" +tests :: TestTree +tests = testGroup "Unit Tests" $ + [ testGroup "Distribution.Compat.CreatePipe" UnitTests.Distribution.Compat.CreatePipe.tests + , testGroup "Distribution.Compat.ReadP" + UnitTests.Distribution.Compat.ReadP.tests + , testGroup "Distribution.Simple.Program.Internal" + UnitTests.Distribution.Simple.Program.Internal.tests + , testGroup "Distribution.Simple.Utils" + UnitTests.Distribution.Simple.Utils.tests , testGroup "Distribution.Utils.NubList" UnitTests.Distribution.Utils.NubList.tests + , testGroup "Distribution.System" + UnitTests.Distribution.System.tests + , testGroup "Distribution.Version" + UnitTests.Distribution.Version.versionTests ] main :: IO () -main = do - -- WORKAROUND: disable buffering on stdout to get streaming test logs - -- test providers _should_ do this themselves - hSetBuffering stdout NoBuffering - defaultMain tests +main = defaultMain tests diff --git a/tests/UnitTests/Distribution/Compat/CreatePipe.hs b/tests/UnitTests/Distribution/Compat/CreatePipe.hs --- a/tests/UnitTests/Distribution/Compat/CreatePipe.hs +++ b/tests/UnitTests/Distribution/Compat/CreatePipe.hs @@ -2,11 +2,10 @@ import Distribution.Compat.CreatePipe import System.IO (hClose, hGetContents, hPutStr, hSetEncoding, localeEncoding) -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) +import Test.Tasty +import Test.Tasty.HUnit -tests :: [Test] +tests :: [TestTree] tests = [testCase "Locale Encoding" case_Locale_Encoding] case_Locale_Encoding :: Assertion diff --git a/tests/UnitTests/Distribution/Compat/ReadP.hs b/tests/UnitTests/Distribution/Compat/ReadP.hs --- a/tests/UnitTests/Distribution/Compat/ReadP.hs +++ b/tests/UnitTests/Distribution/Compat/ReadP.hs @@ -20,10 +20,10 @@ import Data.List import Distribution.Compat.ReadP -import Test.Framework -import Test.Framework.Providers.QuickCheck2 +import Test.Tasty +import Test.Tasty.QuickCheck -tests :: [Test] +tests :: [TestTree] tests = [ testProperty "Get Nil" prop_Get_Nil , testProperty "Get Cons" prop_Get_Cons diff --git a/tests/UnitTests/Distribution/Simple/Program/Internal.hs b/tests/UnitTests/Distribution/Simple/Program/Internal.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Simple/Program/Internal.hs @@ -0,0 +1,36 @@ +module UnitTests.Distribution.Simple.Program.Internal + ( tests + ) where + +import Distribution.Simple.Program.Internal ( stripExtractVersion ) + +import Test.Tasty +import Test.Tasty.HUnit + +v :: String +v = "GNU strip (GNU Binutils; openSUSE 13.2) 2.24.0.20140403-6.1\nCopyright 2013\ + \ Free Software Foundation, Inc.\nThis program is free software; you may\ + \ redistribute it under the terms of\nthe GNU General Public License version 3\ + \ or (at your option) any later version.\nThis program has absolutely no\ + \ warranty.\n" + +v' :: String +v' = "GNU strip 2.17.50.0.6-26.el5 20061020" + +v'' :: String +v'' = "GNU strip (openSUSE-13.2) 2.23.50.0.6-26.el5 20061020" + +v''' :: String +v''' = "GNU strip (GNU (Binutils for) Ubuntu 12.04 ) 2.22" + +tests :: [TestTree] +tests = + [ testCase "Handles parentheses" $ + (stripExtractVersion v) @=? "2.24" + , testCase "Handles dashes and alphabetic characters" $ + (stripExtractVersion v') @=? "2.17" + , testCase "Handles single-word parenthetical expressions" $ + (stripExtractVersion v'') @=? "2.23" + , testCase "Handles nested parentheses" $ + (stripExtractVersion v''') @=? "2.22" + ] diff --git a/tests/UnitTests/Distribution/Simple/Utils.hs b/tests/UnitTests/Distribution/Simple/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Simple/Utils.hs @@ -0,0 +1,59 @@ +module UnitTests.Distribution.Simple.Utils + ( tests + ) where + +import Distribution.Simple.Utils +import Distribution.Verbosity + +import Data.IORef +import System.Directory ( doesDirectoryExist, doesFileExist + , getTemporaryDirectory + , removeDirectoryRecursive, removeFile ) +import System.IO (hClose) + +import Test.Tasty +import Test.Tasty.HUnit + +withTempFileTest :: Assertion +withTempFileTest = do + fileName <- newIORef "" + tempDir <- getTemporaryDirectory + withTempFile tempDir ".foo" $ \fileName' _handle -> do + writeIORef fileName fileName' + fileExists <- readIORef fileName >>= doesFileExist + assertBool "Temporary file not deleted by 'withTempFile'!" (not fileExists) + +withTempFileRemovedTest :: Assertion +withTempFileRemovedTest = do + tempDir <- getTemporaryDirectory + withTempFile tempDir ".foo" $ \fileName handle -> do + hClose handle + removeFile fileName + +withTempDirTest :: Assertion +withTempDirTest = do + dirName <- newIORef "" + tempDir <- getTemporaryDirectory + withTempDirectory normal tempDir "foo" $ \dirName' -> do + writeIORef dirName dirName' + dirExists <- readIORef dirName >>= doesDirectoryExist + assertBool "Temporary directory not deleted by 'withTempDirectory'!" + (not dirExists) + +withTempDirRemovedTest :: Assertion +withTempDirRemovedTest = do + tempDir <- getTemporaryDirectory + withTempDirectory normal tempDir "foo" $ \dirPath -> do + removeDirectoryRecursive dirPath + +tests :: [TestTree] +tests = + [ testCase "withTempFile works as expected" $ + withTempFileTest + , testCase "withTempFile can handle removed files" $ + withTempFileRemovedTest + , testCase "withTempDirectory works as expected" $ + withTempDirTest + , testCase "withTempDirectory can handle removed directories" $ + withTempDirRemovedTest + ] diff --git a/tests/UnitTests/Distribution/System.hs b/tests/UnitTests/Distribution/System.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/System.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module UnitTests.Distribution.System + ( tests + ) where + +import Control.Monad (liftM2) +import Distribution.Text (Text(..), display, simpleParse) +import Distribution.System +import Test.Tasty +import Test.Tasty.QuickCheck + +textRoundtrip :: (Show a, Eq a, Text a) => a -> Property +textRoundtrip x = simpleParse (display x) === Just x + +tests :: [TestTree] +tests = + [ testProperty "Text OS round trip" (textRoundtrip :: OS -> Property) + , testProperty "Text Arch round trip" (textRoundtrip :: Arch -> Property) + , testProperty "Text Platform round trip" (textRoundtrip :: Platform -> Property) + ] + +instance Arbitrary OS where + arbitrary = elements knownOSs + +instance Arbitrary Arch where + arbitrary = elements knownArches + +instance Arbitrary Platform where + arbitrary = liftM2 Platform arbitrary arbitrary diff --git a/tests/UnitTests/Distribution/Utils/NubList.hs b/tests/UnitTests/Distribution/Utils/NubList.hs --- a/tests/UnitTests/Distribution/Utils/NubList.hs +++ b/tests/UnitTests/Distribution/Utils/NubList.hs @@ -7,12 +7,11 @@ import Data.Monoid #endif import Distribution.Utils.NubList -import Test.Framework -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 -import Test.HUnit (Assertion, assertBool) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck -tests :: [Test] +tests :: [TestTree] tests = [ testCase "Numlist retains ordering" testOrdering , testCase "Numlist removes duplicates" testDeDupe diff --git a/tests/UnitTests/Distribution/Version.hs b/tests/UnitTests/Distribution/Version.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Version.hs @@ -0,0 +1,711 @@ +{-# OPTIONS_GHC -fno-warn-orphans + -fno-warn-incomplete-patterns + -fno-warn-deprecations + -fno-warn-unused-binds #-} --FIXME +module UnitTests.Distribution.Version (versionTests) where + +import Distribution.Version +import Distribution.Text + +import Text.PrettyPrint as Disp (text, render, parens, hcat + ,punctuate, int, char, (<>), (<+>)) + +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.QuickCheck.Utils +import qualified Test.Laws as Laws + +import Control.Monad (liftM, liftM2) +import Data.Maybe (isJust, fromJust) +import Data.List (sort, sortBy, nub) +import Data.Ord (comparing) + +versionTests :: [TestTree] +versionTests = + zipWith (\n p -> testProperty ("Range Property " ++ show n) p) [1::Int ..] + -- properties to validate the test framework + [ property prop_nonNull + , property prop_gen_intervals1 + , property prop_gen_intervals2 +--, property prop_equivalentVersionRange --FIXME: runs out of test cases + , property prop_intermediateVersion + + -- the basic syntactic version range functions + , property prop_anyVersion + , property prop_noVersion + , property prop_thisVersion + , property prop_notThisVersion + , property prop_laterVersion + , property prop_orLaterVersion + , property prop_earlierVersion + , property prop_orEarlierVersion + , property prop_unionVersionRanges + , property prop_intersectVersionRanges + , property prop_invertVersionRange + , property prop_withinVersion + , property prop_foldVersionRange + , property prop_foldVersionRange' + + -- the semantic query functions +--, property prop_isAnyVersion1 --FIXME: runs out of test cases +--, property prop_isAnyVersion2 --FIXME: runs out of test cases +--, property prop_isNoVersion --FIXME: runs out of test cases +--, property prop_isSpecificVersion1 --FIXME: runs out of test cases +--, property prop_isSpecificVersion2 --FIXME: runs out of test cases + , property prop_simplifyVersionRange1 + , property prop_simplifyVersionRange1' +--, property prop_simplifyVersionRange2 --FIXME: runs out of test cases +--, property prop_simplifyVersionRange2' --FIXME: runs out of test cases +--, property prop_simplifyVersionRange2'' --FIXME: actually wrong + + -- converting between version ranges and version intervals + , property prop_to_intervals +--, property prop_to_intervals_canonical --FIXME: runs out of test cases +--, property prop_to_intervals_canonical' --FIXME: runs out of test cases + , property prop_from_intervals + , property prop_to_from_intervals + , property prop_from_to_intervals + , property prop_from_to_intervals' + + -- union and intersection of version intervals + , property prop_unionVersionIntervals + , property prop_unionVersionIntervals_idempotent + , property prop_unionVersionIntervals_commutative + , property prop_unionVersionIntervals_associative + , property prop_intersectVersionIntervals + , property prop_intersectVersionIntervals_idempotent + , property prop_intersectVersionIntervals_commutative + , property prop_intersectVersionIntervals_associative + , property prop_union_intersect_distributive + , property prop_intersect_union_distributive + + -- inversion of version intervals + , property prop_invertVersionIntervals + , property prop_invertVersionIntervalsTwice + ] + +-- parseTests :: [TestTree] +-- parseTests = +-- zipWith (\n p -> testProperty ("Parse Property " ++ show n) p) [1::Int ..] +-- -- parsing and pretty printing +-- [ -- property prop_parse_disp1 --FIXME: actually wrong + +-- -- These are also wrong, see +-- -- https://github.com/haskell/cabal/issues/3037#issuecomment-177671011 + +-- -- property prop_parse_disp2 +-- -- , property prop_parse_disp3 +-- -- , property prop_parse_disp4 +-- -- , property prop_parse_disp5 +-- ] + +instance Arbitrary Version where + arbitrary = do + branch <- smallListOf1 $ + frequency [(3, return 0) + ,(3, return 1) + ,(2, return 2) + ,(1, return 3)] + return (Version branch []) -- deliberate [] + where + smallListOf1 = adjustSize (\n -> min 5 (n `div` 3)) . listOf1 + + shrink (Version branch []) = + [ Version branch' [] | branch' <- shrink branch, not (null branch') ] + shrink (Version branch _tags) = + [ Version branch [] ] + +instance Arbitrary VersionRange where + arbitrary = sized verRangeExp + where + verRangeExp n = frequency $ + [ (2, return anyVersion) + , (1, liftM thisVersion arbitrary) + , (1, liftM laterVersion arbitrary) + , (1, liftM orLaterVersion arbitrary) + , (1, liftM orLaterVersion' arbitrary) + , (1, liftM earlierVersion arbitrary) + , (1, liftM orEarlierVersion arbitrary) + , (1, liftM orEarlierVersion' arbitrary) + , (1, liftM withinVersion arbitrary) + , (2, liftM VersionRangeParens arbitrary) + ] ++ if n == 0 then [] else + [ (2, liftM2 unionVersionRanges verRangeExp2 verRangeExp2) + , (2, liftM2 intersectVersionRanges verRangeExp2 verRangeExp2) + ] + where + verRangeExp2 = verRangeExp (n `div` 2) + + orLaterVersion' v = + unionVersionRanges (LaterVersion v) (ThisVersion v) + orEarlierVersion' v = + unionVersionRanges (EarlierVersion v) (ThisVersion v) + +--------------------------- +-- VersionRange properties +-- + +prop_nonNull :: Version -> Bool +prop_nonNull = not . null . versionBranch + +prop_anyVersion :: Version -> Bool +prop_anyVersion v' = + withinRange v' anyVersion == True + +prop_noVersion :: Version -> Bool +prop_noVersion v' = + withinRange v' noVersion == False + +prop_thisVersion :: Version -> Version -> Bool +prop_thisVersion v v' = + withinRange v' (thisVersion v) + == (v' == v) + +prop_notThisVersion :: Version -> Version -> Bool +prop_notThisVersion v v' = + withinRange v' (notThisVersion v) + == (v' /= v) + +prop_laterVersion :: Version -> Version -> Bool +prop_laterVersion v v' = + withinRange v' (laterVersion v) + == (v' > v) + +prop_orLaterVersion :: Version -> Version -> Bool +prop_orLaterVersion v v' = + withinRange v' (orLaterVersion v) + == (v' >= v) + +prop_earlierVersion :: Version -> Version -> Bool +prop_earlierVersion v v' = + withinRange v' (earlierVersion v) + == (v' < v) + +prop_orEarlierVersion :: Version -> Version -> Bool +prop_orEarlierVersion v v' = + withinRange v' (orEarlierVersion v) + == (v' <= v) + +prop_unionVersionRanges :: VersionRange -> VersionRange -> Version -> Bool +prop_unionVersionRanges vr1 vr2 v' = + withinRange v' (unionVersionRanges vr1 vr2) + == (withinRange v' vr1 || withinRange v' vr2) + +prop_intersectVersionRanges :: VersionRange -> VersionRange -> Version -> Bool +prop_intersectVersionRanges vr1 vr2 v' = + withinRange v' (intersectVersionRanges vr1 vr2) + == (withinRange v' vr1 && withinRange v' vr2) + +prop_invertVersionRange :: VersionRange -> Version -> Bool +prop_invertVersionRange vr v' = + withinRange v' (invertVersionRange vr) + == not (withinRange v' vr) + +prop_withinVersion :: Version -> Version -> Bool +prop_withinVersion v v' = + withinRange v' (withinVersion v) + == (v' >= v && v' < upper v) + where + upper (Version lower t) = Version (init lower ++ [last lower + 1]) t + +prop_foldVersionRange :: VersionRange -> Bool +prop_foldVersionRange range = + expandWildcard range + == foldVersionRange anyVersion thisVersion + laterVersion earlierVersion + unionVersionRanges intersectVersionRanges + range + where + expandWildcard (WildcardVersion v) = + intersectVersionRanges (orLaterVersion v) (earlierVersion (upper v)) + where + upper (Version lower t) = Version (init lower ++ [last lower + 1]) t + + expandWildcard (UnionVersionRanges v1 v2) = + UnionVersionRanges (expandWildcard v1) (expandWildcard v2) + expandWildcard (IntersectVersionRanges v1 v2) = + IntersectVersionRanges (expandWildcard v1) (expandWildcard v2) + expandWildcard (VersionRangeParens v) = expandWildcard v + expandWildcard v = v + + +prop_foldVersionRange' :: VersionRange -> Bool +prop_foldVersionRange' range = + canonicalise range + == foldVersionRange' anyVersion thisVersion + laterVersion earlierVersion + orLaterVersion orEarlierVersion + (\v _ -> withinVersion v) + unionVersionRanges intersectVersionRanges id + range + where + canonicalise (UnionVersionRanges (LaterVersion v) + (ThisVersion v')) | v == v' + = UnionVersionRanges (ThisVersion v') + (LaterVersion v) + canonicalise (UnionVersionRanges (EarlierVersion v) + (ThisVersion v')) | v == v' + = UnionVersionRanges (ThisVersion v') + (EarlierVersion v) + canonicalise (UnionVersionRanges v1 v2) = + UnionVersionRanges (canonicalise v1) (canonicalise v2) + canonicalise (IntersectVersionRanges v1 v2) = + IntersectVersionRanges (canonicalise v1) (canonicalise v2) + canonicalise (VersionRangeParens v) = canonicalise v + canonicalise v = v + + +prop_isAnyVersion1 :: VersionRange -> Version -> Property +prop_isAnyVersion1 range version = + isAnyVersion range ==> withinRange version range + +prop_isAnyVersion2 :: VersionRange -> Property +prop_isAnyVersion2 range = + isAnyVersion range ==> + foldVersionRange True (\_ -> False) (\_ -> False) (\_ -> False) + (\_ _ -> False) (\_ _ -> False) + (simplifyVersionRange range) + +prop_isNoVersion :: VersionRange -> Version -> Property +prop_isNoVersion range version = + isNoVersion range ==> not (withinRange version range) + +prop_isSpecificVersion1 :: VersionRange -> NonEmptyList Version -> Property +prop_isSpecificVersion1 range (NonEmpty versions) = + isJust version && not (null versions') ==> + allEqual (fromJust version : versions') + where + version = isSpecificVersion range + versions' = filter (`withinRange` range) versions + allEqual xs = and (zipWith (==) xs (tail xs)) + +prop_isSpecificVersion2 :: VersionRange -> Property +prop_isSpecificVersion2 range = + isJust version ==> + foldVersionRange Nothing Just (\_ -> Nothing) (\_ -> Nothing) + (\_ _ -> Nothing) (\_ _ -> Nothing) + (simplifyVersionRange range) + == version + + where + version = isSpecificVersion range + +-- | 'simplifyVersionRange' is a semantic identity on 'VersionRange'. +-- +prop_simplifyVersionRange1 :: VersionRange -> Version -> Bool +prop_simplifyVersionRange1 range version = + withinRange version range == withinRange version (simplifyVersionRange range) + +prop_simplifyVersionRange1' :: VersionRange -> Bool +prop_simplifyVersionRange1' range = + range `equivalentVersionRange` (simplifyVersionRange range) + +-- | 'simplifyVersionRange' produces a canonical form for ranges with +-- equivalent semantics. +-- +prop_simplifyVersionRange2 :: VersionRange -> VersionRange -> Version -> Property +prop_simplifyVersionRange2 r r' v = + r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==> + withinRange v r == withinRange v r' + +prop_simplifyVersionRange2' :: VersionRange -> VersionRange -> Property +prop_simplifyVersionRange2' r r' = + r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==> + r `equivalentVersionRange` r' + +--FIXME: see equivalentVersionRange for details +prop_simplifyVersionRange2'' :: VersionRange -> VersionRange -> Property +prop_simplifyVersionRange2'' r r' = + r /= r' && r `equivalentVersionRange` r' ==> + simplifyVersionRange r == simplifyVersionRange r' + || isNoVersion r + || isNoVersion r' + +-------------------- +-- VersionIntervals +-- + +-- | Generating VersionIntervals +-- +-- This is a tad tricky as VersionIntervals is an abstract type, so we first +-- make a local type for generating the internal representation. Then we check +-- that this lets us construct valid 'VersionIntervals'. +-- +newtype VersionIntervals' = VersionIntervals' [VersionInterval] + deriving (Eq, Show) + +instance Arbitrary VersionIntervals' where + arbitrary = do + ubound <- arbitrary + bounds <- arbitrary + let intervals = mergeTouching + . map fixEmpty + . replaceUpper ubound + . pairs + . sortBy (comparing fst) + $ bounds + return (VersionIntervals' intervals) + + where + pairs ((l, lb):(u, ub):bs) = (LowerBound l lb, UpperBound u ub) + : pairs bs + pairs _ = [] + + replaceUpper NoUpperBound [(l,_)] = [(l, NoUpperBound)] + replaceUpper NoUpperBound (i:is) = i : replaceUpper NoUpperBound is + replaceUpper _ is = is + + -- merge adjacent intervals that touch + mergeTouching (i1@(l,u):i2@(l',u'):is) + | doesNotTouch u l' = i1 : mergeTouching (i2:is) + | otherwise = mergeTouching ((l,u'):is) + mergeTouching is = is + + doesNotTouch :: UpperBound -> LowerBound -> Bool + doesNotTouch NoUpperBound _ = False + doesNotTouch (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) + + fixEmpty (LowerBound l _, UpperBound u _) + | l == u = (LowerBound l InclusiveBound, UpperBound u InclusiveBound) + fixEmpty i = i + + shrink (VersionIntervals' intervals) = + [ VersionIntervals' intervals' | intervals' <- shrink intervals ] + +instance Arbitrary Bound where + arbitrary = elements [ExclusiveBound, InclusiveBound] + +instance Arbitrary LowerBound where + arbitrary = liftM2 LowerBound arbitrary arbitrary + +instance Arbitrary UpperBound where + arbitrary = oneof [return NoUpperBound + ,liftM2 UpperBound arbitrary arbitrary] + +-- | Check that our VersionIntervals' arbitrary instance generates intervals +-- that satisfies the invariant. +-- +prop_gen_intervals1 :: VersionIntervals' -> Bool +prop_gen_intervals1 (VersionIntervals' intervals) = + isJust (mkVersionIntervals intervals) + +instance Arbitrary VersionIntervals where + arbitrary = do + VersionIntervals' intervals <- arbitrary + case mkVersionIntervals intervals of + Just xs -> return xs + +-- | Check that constructing our intervals type and converting it to a +-- 'VersionRange' and then into the true intervals type gives us back +-- the exact same sequence of intervals. This tells us that our arbitrary +-- instance for 'VersionIntervals'' is ok. +-- +prop_gen_intervals2 :: VersionIntervals' -> Bool +prop_gen_intervals2 (VersionIntervals' intervals') = + asVersionIntervals (fromVersionIntervals intervals) == intervals' + where + Just intervals = mkVersionIntervals intervals' + +-- | Check that 'VersionIntervals' models 'VersionRange' via +-- 'toVersionIntervals'. +-- +prop_to_intervals :: VersionRange -> Version -> Bool +prop_to_intervals range version = + withinRange version range == withinIntervals version intervals + where + intervals = toVersionIntervals range + +-- | Check that semantic equality on 'VersionRange's is the same as converting +-- to 'VersionIntervals' and doing syntactic equality. +-- +prop_to_intervals_canonical :: VersionRange -> VersionRange -> Property +prop_to_intervals_canonical r r' = + r /= r' && r `equivalentVersionRange` r' ==> + toVersionIntervals r == toVersionIntervals r' + +prop_to_intervals_canonical' :: VersionRange -> VersionRange -> Property +prop_to_intervals_canonical' r r' = + r /= r' && toVersionIntervals r == toVersionIntervals r' ==> + r `equivalentVersionRange` r' + +-- | Check that 'VersionIntervals' models 'VersionRange' via +-- 'fromVersionIntervals'. +-- +prop_from_intervals :: VersionIntervals -> Version -> Bool +prop_from_intervals intervals version = + withinRange version range == withinIntervals version intervals + where + range = fromVersionIntervals intervals + +-- | @'toVersionIntervals' . 'fromVersionIntervals'@ is an exact identity on +-- 'VersionIntervals'. +-- +prop_to_from_intervals :: VersionIntervals -> Bool +prop_to_from_intervals intervals = + toVersionIntervals (fromVersionIntervals intervals) == intervals + +-- | @'fromVersionIntervals' . 'toVersionIntervals'@ is a semantic identity on +-- 'VersionRange', though not necessarily a syntactic identity. +-- +prop_from_to_intervals :: VersionRange -> Bool +prop_from_to_intervals range = + range' `equivalentVersionRange` range + where + range' = fromVersionIntervals (toVersionIntervals range) + +-- | Equivalent of 'prop_from_to_intervals' +-- +prop_from_to_intervals' :: VersionRange -> Version -> Bool +prop_from_to_intervals' range version = + withinRange version range' == withinRange version range + where + range' = fromVersionIntervals (toVersionIntervals range) + +-- | The semantics of 'unionVersionIntervals' is (||). +-- +prop_unionVersionIntervals :: VersionIntervals -> VersionIntervals + -> Version -> Bool +prop_unionVersionIntervals is1 is2 v = + withinIntervals v (unionVersionIntervals is1 is2) + == (withinIntervals v is1 || withinIntervals v is2) + +-- | 'unionVersionIntervals' is idempotent +-- +prop_unionVersionIntervals_idempotent :: VersionIntervals -> Bool +prop_unionVersionIntervals_idempotent = + Laws.idempotent_binary unionVersionIntervals + +-- | 'unionVersionIntervals' is commutative +-- +prop_unionVersionIntervals_commutative :: VersionIntervals + -> VersionIntervals -> Bool +prop_unionVersionIntervals_commutative = + Laws.commutative unionVersionIntervals + +-- | 'unionVersionIntervals' is associative +-- +prop_unionVersionIntervals_associative :: VersionIntervals + -> VersionIntervals + -> VersionIntervals -> Bool +prop_unionVersionIntervals_associative = + Laws.associative unionVersionIntervals + +-- | The semantics of 'intersectVersionIntervals' is (&&). +-- +prop_intersectVersionIntervals :: VersionIntervals -> VersionIntervals + -> Version -> Bool +prop_intersectVersionIntervals is1 is2 v = + withinIntervals v (intersectVersionIntervals is1 is2) + == (withinIntervals v is1 && withinIntervals v is2) + +-- | 'intersectVersionIntervals' is idempotent +-- +prop_intersectVersionIntervals_idempotent :: VersionIntervals -> Bool +prop_intersectVersionIntervals_idempotent = + Laws.idempotent_binary intersectVersionIntervals + +-- | 'intersectVersionIntervals' is commutative +-- +prop_intersectVersionIntervals_commutative :: VersionIntervals + -> VersionIntervals -> Bool +prop_intersectVersionIntervals_commutative = + Laws.commutative intersectVersionIntervals + +-- | 'intersectVersionIntervals' is associative +-- +prop_intersectVersionIntervals_associative :: VersionIntervals + -> VersionIntervals + -> VersionIntervals -> Bool +prop_intersectVersionIntervals_associative = + Laws.associative intersectVersionIntervals + +-- | 'unionVersionIntervals' distributes over 'intersectVersionIntervals' +-- +prop_union_intersect_distributive :: Property +prop_union_intersect_distributive = + Laws.distributive_left unionVersionIntervals intersectVersionIntervals + .&. Laws.distributive_right unionVersionIntervals intersectVersionIntervals + +-- | 'intersectVersionIntervals' distributes over 'unionVersionIntervals' +-- +prop_intersect_union_distributive :: Property +prop_intersect_union_distributive = + Laws.distributive_left intersectVersionIntervals unionVersionIntervals + .&. Laws.distributive_right intersectVersionIntervals unionVersionIntervals + +-- | The semantics of 'invertVersionIntervals' is 'not'. +-- +prop_invertVersionIntervals :: VersionIntervals + -> Version -> Bool +prop_invertVersionIntervals vi v = + withinIntervals v (invertVersionIntervals vi) + == not (withinIntervals v vi) + +-- | Double application of 'invertVersionIntervals' is the identity function +prop_invertVersionIntervalsTwice :: VersionIntervals -> Bool +prop_invertVersionIntervalsTwice vi = + invertVersionIntervals (invertVersionIntervals vi) == vi + + + +-------------------------------- +-- equivalentVersionRange helper + +prop_equivalentVersionRange :: VersionRange -> VersionRange + -> Version -> Property +prop_equivalentVersionRange range range' version = + equivalentVersionRange range range' && range /= range' ==> + withinRange version range == withinRange version range' + +--FIXME: this is wrong. consider version ranges "<=1" and "<1.0" +-- this algorithm cannot distinguish them because there is no version +-- that is included by one that is excluded by the other. +-- Alternatively we must reconsider the semantics of '<' and '<=' +-- in version ranges / version intervals. Perhaps the canonical +-- representation should use just < v and interpret "<= v" as "< v.0". +equivalentVersionRange :: VersionRange -> VersionRange -> Bool +equivalentVersionRange vr1 vr2 = + let allVersionsUsed = nub (sort (versionsUsed vr1 ++ versionsUsed vr2)) + minPoint = Version [0] [] + maxPoint | null allVersionsUsed = minPoint + | otherwise = case maximum allVersionsUsed of + Version vs _ -> Version (vs ++ [1]) [] + probeVersions = minPoint : maxPoint + : intermediateVersions allVersionsUsed + + in all (\v -> withinRange v vr1 == withinRange v vr2) probeVersions + + where + versionsUsed = foldVersionRange [] (\x->[x]) (\x->[x]) (\x->[x]) (++) (++) + intermediateVersions (v1:v2:vs) = v1 : intermediateVersion v1 v2 + : intermediateVersions (v2:vs) + intermediateVersions vs = vs + +intermediateVersion :: Version -> Version -> Version +intermediateVersion v1 v2 | v1 >= v2 = error "intermediateVersion: v1 >= v2" +intermediateVersion (Version v1 _) (Version v2 _) = + Version (intermediateList v1 v2) [] + where + intermediateList :: [Int] -> [Int] -> [Int] + intermediateList [] (_:_) = [0] + intermediateList (x:xs) (y:ys) + | x < y = x : xs ++ [0] + | otherwise = x : intermediateList xs ys + +prop_intermediateVersion :: Version -> Version -> Property +prop_intermediateVersion v1 v2 = + (v1 /= v2) && not (adjacentVersions v1 v2) ==> + if v1 < v2 + then let v = intermediateVersion v1 v2 + in (v1 < v && v < v2) + else let v = intermediateVersion v2 v1 + in v1 > v && v > v2 + +adjacentVersions :: Version -> Version -> Bool +adjacentVersions (Version v1 _) (Version v2 _) = v1 ++ [0] == v2 + || v2 ++ [0] == v1 + +-------------------------------- +-- Parsing and pretty printing +-- + +prop_parse_disp1 :: VersionRange -> Bool +prop_parse_disp1 vr = + fmap stripParens (simpleParse (display vr)) == Just (canonicalise vr) + + where + canonicalise = swizzle . swap + + swizzle (UnionVersionRanges (UnionVersionRanges v1 v2) v3) + | not (isOrLaterVersion v1 v2) && not (isOrEarlierVersion v1 v2) + = swizzle (UnionVersionRanges v1 (UnionVersionRanges v2 v3)) + + swizzle (IntersectVersionRanges (IntersectVersionRanges v1 v2) v3) + = swizzle (IntersectVersionRanges v1 (IntersectVersionRanges v2 v3)) + + swizzle (UnionVersionRanges v1 v2) = + UnionVersionRanges (swizzle v1) (swizzle v2) + swizzle (IntersectVersionRanges v1 v2) = + IntersectVersionRanges (swizzle v1) (swizzle v2) + swizzle (VersionRangeParens v) = swizzle v + swizzle v = v + + isOrLaterVersion (ThisVersion v) (LaterVersion v') = v == v' + isOrLaterVersion _ _ = False + + isOrEarlierVersion (ThisVersion v) (EarlierVersion v') = v == v' + isOrEarlierVersion _ _ = False + + swap = + foldVersionRange' anyVersion thisVersion + laterVersion earlierVersion + orLaterVersion orEarlierVersion + (\v _ -> withinVersion v) + unionVersionRanges intersectVersionRanges id + + stripParens :: VersionRange -> VersionRange + stripParens (VersionRangeParens v) = stripParens v + stripParens (UnionVersionRanges v1 v2) = + UnionVersionRanges (stripParens v1) (stripParens v2) + stripParens (IntersectVersionRanges v1 v2) = + IntersectVersionRanges (stripParens v1) (stripParens v2) + stripParens v = v + +prop_parse_disp2 :: VersionRange -> Property +prop_parse_disp2 vr = + let b = fmap (display :: VersionRange -> String) (simpleParse (display vr)) + a = Just (display vr) + in + counterexample ("Expected: " ++ show a) $ + counterexample ("But got: " ++ show b) $ + b == a + +prop_parse_disp3 :: VersionRange -> Property +prop_parse_disp3 vr = + let a = Just (display vr) + b = fmap displayRaw (simpleParse (display vr)) + in + counterexample ("Expected: " ++ show a) $ + counterexample ("But got: " ++ show b) $ + b == a + +prop_parse_disp4 :: VersionRange -> Property +prop_parse_disp4 vr = + let a = Just vr + b = (simpleParse (display vr)) + in + counterexample ("Expected: " ++ show a) $ + counterexample ("But got: " ++ show b) $ + b == a + +prop_parse_disp5 :: VersionRange -> Property +prop_parse_disp5 vr = + let a = Just vr + b = simpleParse (displayRaw vr) + in + counterexample ("Expected: " ++ show a) $ + counterexample ("But got: " ++ show b) $ + b == a + +displayRaw :: VersionRange -> String +displayRaw = + Disp.render + . foldVersionRange' -- precedence: + -- All the same as the usual pretty printer, except for the parens + ( Disp.text "-any") + (\v -> Disp.text "==" <> disp v) + (\v -> Disp.char '>' <> disp v) + (\v -> Disp.char '<' <> disp v) + (\v -> Disp.text ">=" <> disp v) + (\v -> Disp.text "<=" <> disp v) + (\v _ -> Disp.text "==" <> dispWild v) + (\r1 r2 -> r1 <+> Disp.text "||" <+> r2) + (\r1 r2 -> r1 <+> Disp.text "&&" <+> r2) + (\r -> Disp.parens r) -- parens + + where + dispWild (Version b _) = + Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) + <> Disp.text ".*"