diff --git a/Cabal-ide-backend.cabal b/Cabal-ide-backend.cabal new file mode 100644 --- /dev/null +++ b/Cabal-ide-backend.cabal @@ -0,0 +1,336 @@ +name: Cabal-ide-backend +version: 1.23.0.0 +copyright: 2003-2006, Isaac Jones + 2005-2011, Duncan Coutts +license: BSD3 +license-file: LICENSE +author: Isaac Jones + Duncan Coutts +maintainer: cabal-devel@haskell.org +homepage: http://www.haskell.org/cabal/ +bug-reports: https://github.com/haskell/cabal/issues +synopsis: A framework for packaging Haskell software +description: + NOTE: This is a temporary fork of Cabal necessary for + . It is not intended as a replacement for + the standard Cabal package, and should in general not be used at all outside of + ide-backend. + . + The Haskell Common Architecture for Building Applications and + Libraries: a framework defining a common interface for authors to more + easily build their Haskell applications in a portable way. + . + The Haskell Cabal is part of a larger infrastructure for distributing, + organizing, and cataloging Haskell libraries and tools. +category: Distribution +cabal-version: >=1.10 +build-type: Custom +-- Even though we do use the default Setup.lhs it's vital to bootstrapping +-- that we build Setup.lhs using our own local Cabal source code. + +extra-source-files: + README.md tests/README.md changelog + 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': + tests/PackageTests/BenchmarkExeV10/Foo.hs + tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs + tests/PackageTests/BenchmarkExeV10/my.cabal + tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal + tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs + tests/PackageTests/BenchmarkStanza/my.cabal + tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal + tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs + tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal + tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs + tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs + tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal + tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs + tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs + tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal + tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs + tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs + tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal + tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs + tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs + tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal + tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs + tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal + tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs + tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs + tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal + tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs + tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal + tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs + tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs + tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal + tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs + tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal + tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs + tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs + tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs + tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs + tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal + tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs + tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs + tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal + tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs + tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs + tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal + tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs + tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal + tests/PackageTests/CMain/Bar.hs + tests/PackageTests/CMain/Setup.hs + tests/PackageTests/CMain/foo.c + tests/PackageTests/CMain/my.cabal + tests/PackageTests/DeterministicAr/Lib.hs + tests/PackageTests/DeterministicAr/my.cabal + tests/PackageTests/EmptyLib/empty/empty.cabal + 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/OrderFlags/Foo.hs + tests/PackageTests/OrderFlags/my.cabal + tests/PackageTests/PathsModule/Executable/Main.hs + tests/PackageTests/PathsModule/Executable/my.cabal + tests/PackageTests/PathsModule/Library/my.cabal + tests/PackageTests/PreProcess/Foo.hsc + tests/PackageTests/PreProcess/Main.hs + tests/PackageTests/PreProcess/my.cabal + tests/PackageTests/ReexportedModules/ReexportedModules.cabal + tests/PackageTests/TemplateHaskell/dynamic/Exe.hs + tests/PackageTests/TemplateHaskell/dynamic/Lib.hs + tests/PackageTests/TemplateHaskell/dynamic/TH.hs + tests/PackageTests/TemplateHaskell/dynamic/my.cabal + tests/PackageTests/TemplateHaskell/profiling/Exe.hs + tests/PackageTests/TemplateHaskell/profiling/Lib.hs + tests/PackageTests/TemplateHaskell/profiling/TH.hs + tests/PackageTests/TemplateHaskell/profiling/my.cabal + tests/PackageTests/TemplateHaskell/vanilla/Exe.hs + tests/PackageTests/TemplateHaskell/vanilla/Lib.hs + tests/PackageTests/TemplateHaskell/vanilla/TH.hs + tests/PackageTests/TemplateHaskell/vanilla/my.cabal + tests/PackageTests/TestOptions/TestOptions.cabal + tests/PackageTests/TestOptions/test-TestOptions.hs + tests/PackageTests/TestStanza/my.cabal + tests/PackageTests/TestSuiteExeV10/Foo.hs + tests/PackageTests/TestSuiteExeV10/my.cabal + tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs + tests/Setup.hs + tests/hackage/check.sh + tests/hackage/download.sh + tests/hackage/unpack.sh + tests/misc/ghc-supported-languages.hs + +source-repository head + type: git + location: https://github.com/haskell/cabal/ + subdir: Cabal + +flag bundled-binary-generic + default: False + +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 + + if flag(bundled-binary-generic) + build-depends: binary >= 0.5 && < 0.7 + else + build-depends: binary >= 0.7 && < 0.8 + + -- Needed for GHC.Generics before GHC 7.6 + if impl(ghc < 7.6) + build-depends: ghc-prim >= 0.2 && < 0.3 + + if !os(windows) + build-depends: + unix >= 2.0 && < 2.8 + + ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs + + exposed-modules: + Distribution.Compat.CreatePipe + Distribution.Compat.Environment + Distribution.Compat.Exception + Distribution.Compat.ReadP + Distribution.Compiler + Distribution.InstalledPackageInfo + Distribution.License + Distribution.Make + Distribution.ModuleName + Distribution.Package + Distribution.PackageDescription + Distribution.PackageDescription.Check + Distribution.PackageDescription.Configuration + Distribution.PackageDescription.Parse + Distribution.PackageDescription.PrettyPrint + Distribution.PackageDescription.Utils + Distribution.ParseUtils + Distribution.ReadE + Distribution.Simple + Distribution.Simple.Bench + Distribution.Simple.Build + Distribution.Simple.Build.Macros + Distribution.Simple.Build.PathsModule + Distribution.Simple.BuildPaths + Distribution.Simple.BuildTarget + Distribution.Simple.CCompiler + Distribution.Simple.Command + Distribution.Simple.Compiler + Distribution.Simple.Configure + Distribution.Simple.GHC + Distribution.Simple.GHCJS + Distribution.Simple.Haddock + Distribution.Simple.HaskellSuite + Distribution.Simple.Hpc + Distribution.Simple.Install + Distribution.Simple.InstallDirs + Distribution.Simple.JHC + Distribution.Simple.LHC + Distribution.Simple.LocalBuildInfo + Distribution.Simple.PackageIndex + Distribution.Simple.PreProcess + Distribution.Simple.PreProcess.Unlit + Distribution.Simple.Program + Distribution.Simple.Program.Ar + Distribution.Simple.Program.Builtin + Distribution.Simple.Program.Db + Distribution.Simple.Program.Find + Distribution.Simple.Program.GHC + Distribution.Simple.Program.HcPkg + Distribution.Simple.Program.Hpc + Distribution.Simple.Program.Ld + Distribution.Simple.Program.Run + Distribution.Simple.Program.Script + Distribution.Simple.Program.Strip + Distribution.Simple.Program.Types + Distribution.Simple.Register + Distribution.Simple.Setup + Distribution.Simple.SrcDist + Distribution.Simple.Test + Distribution.Simple.Test.ExeV10 + Distribution.Simple.Test.LibV09 + Distribution.Simple.Test.Log + Distribution.Simple.UHC + Distribution.Simple.UserHooks + Distribution.Simple.Utils + Distribution.System + Distribution.TestSuite + Distribution.Text + Distribution.Utils.NubList + Distribution.Verbosity + Distribution.Version + Language.Haskell.Extension + + other-modules: + Distribution.Compat.Binary + Distribution.Compat.CopyFile + Distribution.Compat.TempFile + Distribution.GetOpt + Distribution.Simple.GHC.Internal + Distribution.Simple.GHC.IPI641 + Distribution.Simple.GHC.IPI642 + Distribution.Simple.GHC.ImplInfo + Paths_Cabal_ide_backend + + if flag(bundled-binary-generic) + other-modules: + Distribution.Compat.Binary.Class + Distribution.Compat.Binary.Generic + + default-language: Haskell98 + default-extensions: CPP + + -- avoid clashing with standard Cabal + exposed: False + +-- Small, fast running tests. +test-suite unit-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + other-modules: + UnitTests.Distribution.Compat.CreatePipe + UnitTests.Distribution.Compat.ReadP + UnitTests.Distribution.Utils.NubList + main-is: UnitTests.hs + build-depends: + base, + test-framework, + test-framework-hunit, + test-framework-quickcheck2, + HUnit, + QuickCheck < 2.8, + Cabal + ghc-options: -Wall + default-language: Haskell98 + +-- Large, system tests that build packages. +test-suite package-tests + type: exitcode-stdio-1.0 + main-is: PackageTests.hs + other-modules: + 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.DeterministicAr.Check + PackageTests.EmptyLib.Check + PackageTests.Haddock.Check + PackageTests.OrderFlags.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.8, + Cabal-ide-backend, + process, + directory, + filepath, + extensible-exceptions, + bytestring, + regex-posix, + old-time + if !os(windows) + build-depends: unix + ghc-options: -Wall + default-extensions: CPP + default-language: Haskell98 diff --git a/Distribution/Compat/Binary.hs b/Distribution/Compat/Binary.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Binary.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} + +#ifndef MIN_VERSION_binary +#define MIN_VERSION_binary(x, y, z) 0 +#endif + +module Distribution.Compat.Binary + ( decodeOrFailIO +#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0) + , module Data.Binary +#else + , Binary(..) + , decode, encode +#endif + ) where + +import Control.Exception (ErrorCall(..), catch, evaluate) +import Data.ByteString.Lazy (ByteString) + +#if __GLASGOW_HASKELL__ < 706 +import Prelude hiding (catch) +#endif + +#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0) + +import Data.Binary + +#else + +import Data.Binary.Get +import Data.Binary.Put + +import Distribution.Compat.Binary.Class +import Distribution.Compat.Binary.Generic () + +-- | Decode a value from a lazy ByteString, reconstructing the original structure. +-- +decode :: Binary a => ByteString -> a +decode = runGet get + +-- | Encode a value using binary serialisation to a lazy ByteString. +-- +encode :: Binary a => a -> ByteString +encode = runPut . put +{-# INLINE encode #-} + +#endif + +decodeOrFailIO :: Binary a => ByteString -> IO (Either String a) +decodeOrFailIO bs = + catch (evaluate (decode bs) >>= return . Right) + $ \(ErrorCall str) -> return $ Left str diff --git a/Distribution/Compat/Binary/Class.hs b/Distribution/Compat/Binary/Class.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Binary/Class.hs @@ -0,0 +1,530 @@ +{-# LANGUAGE CPP, FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DefaultSignatures #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compat.Binary.Class +-- Copyright : Lennart Kolmodin +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : unstable +-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances +-- +-- Typeclass and instances for binary serialization. +-- +----------------------------------------------------------------------------- + +module Distribution.Compat.Binary.Class ( + + -- * The Binary class + Binary(..) + + -- * Support for generics + , GBinary(..) + + ) where + +import Data.Word + +import Data.Binary.Put +import Data.Binary.Get + +import Control.Monad +import Foreign + +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as L + +import Data.Char (chr,ord) +import Data.List (unfoldr) + +-- And needed for the instances: +import qualified Data.ByteString as B +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Ratio as R + +import qualified Data.Tree as T + +import Data.Array.Unboxed + +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 + +------------------------------------------------------------------------ + +class GBinary f where + gput :: f t -> Put + gget :: Get (f t) + +-- | The 'Binary' class provides 'put' and 'get', methods to encode and +-- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and +-- 'Show' classes for textual representation of Haskell types, and is +-- suitable for serialising Haskell values to disk, over the network. +-- +-- For decoding and generating simple external binary formats (e.g. C +-- structures), Binary may be used, but in general is not suitable +-- for complex protocols. Instead use the 'Put' and 'Get' primitives +-- directly. +-- +-- Instances of Binary should satisfy the following property: +-- +-- > decode . encode == id +-- +-- That is, the 'get' and 'put' methods should be the inverse of each +-- other. A range of instances are provided for basic Haskell types. +-- +class Binary t where + -- | Encode a value in the Put monad. + put :: t -> Put + -- | Decode a value in the Get monad + get :: Get t + + default put :: (Generic t, GBinary (Rep t)) => t -> Put + put = gput . from + + default get :: (Generic t, GBinary (Rep t)) => Get t + get = to `fmap` gget + +------------------------------------------------------------------------ +-- Simple instances + +-- The () type need never be written to disk: values of singleton type +-- can be reconstructed from the type alone +instance Binary () where + put () = return () + get = return () + +-- Bools are encoded as a byte in the range 0 .. 1 +instance Binary Bool where + put = putWord8 . fromIntegral . fromEnum + get = liftM (toEnum . fromIntegral) getWord8 + +-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2 +instance Binary Ordering where + put = putWord8 . fromIntegral . fromEnum + get = liftM (toEnum . fromIntegral) getWord8 + +------------------------------------------------------------------------ +-- Words and Ints + +-- Words8s are written as bytes +instance Binary Word8 where + put = putWord8 + get = getWord8 + +-- Words16s are written as 2 bytes in big-endian (network) order +instance Binary Word16 where + put = putWord16be + get = getWord16be + +-- Words32s are written as 4 bytes in big-endian (network) order +instance Binary Word32 where + put = putWord32be + get = getWord32be + +-- Words64s are written as 8 bytes in big-endian (network) order +instance Binary Word64 where + put = putWord64be + get = getWord64be + +-- Int8s are written as a single byte. +instance Binary Int8 where + put i = put (fromIntegral i :: Word8) + get = liftM fromIntegral (get :: Get Word8) + +-- Int16s are written as a 2 bytes in big endian format +instance Binary Int16 where + put i = put (fromIntegral i :: Word16) + get = liftM fromIntegral (get :: Get Word16) + +-- Int32s are written as a 4 bytes in big endian format +instance Binary Int32 where + put i = put (fromIntegral i :: Word32) + get = liftM fromIntegral (get :: Get Word32) + +-- Int64s are written as a 4 bytes in big endian format +instance Binary Int64 where + put i = put (fromIntegral i :: Word64) + get = liftM fromIntegral (get :: Get Word64) + +------------------------------------------------------------------------ + +-- Words are are written as Word64s, that is, 8 bytes in big endian format +instance Binary Word where + put i = put (fromIntegral i :: Word64) + get = liftM fromIntegral (get :: Get Word64) + +-- Ints are are written as Int64s, that is, 8 bytes in big endian format +instance Binary Int where + put i = put (fromIntegral i :: Int64) + get = liftM fromIntegral (get :: Get Int64) + +------------------------------------------------------------------------ +-- +-- Portable, and pretty efficient, serialisation of Integer +-- + +-- Fixed-size type for a subset of Integer +type SmallInt = Int32 + +-- Integers are encoded in two ways: if they fit inside a SmallInt, +-- they're written as a byte tag, and that value. If the Integer value +-- is too large to fit in a SmallInt, it is written as a byte array, +-- along with a sign and length field. + +instance Binary Integer where + + {-# INLINE put #-} + put n | n >= lo && n <= hi = do + putWord8 0 + put (fromIntegral n :: SmallInt) -- fast path + where + lo = fromIntegral (minBound :: SmallInt) :: Integer + hi = fromIntegral (maxBound :: SmallInt) :: Integer + + put n = do + putWord8 1 + put sign + put (unroll (abs n)) -- unroll the bytes + where + sign = fromIntegral (signum n) :: Word8 + + {-# INLINE get #-} + get = do + tag <- get :: Get Word8 + case tag of + 0 -> liftM fromIntegral (get :: Get SmallInt) + _ -> do sign <- get + bytes <- get + let v = roll bytes + return $! if sign == (1 :: Word8) then v else - v + +-- +-- Fold and unfold an Integer to and from a list of its bytes +-- +unroll :: Integer -> [Word8] +unroll = unfoldr step + where + step 0 = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + +roll :: [Word8] -> Integer +roll = foldr unstep 0 + where + unstep b a = a `shiftL` 8 .|. fromIntegral b + +{- + +-- +-- An efficient, raw serialisation for Integer (GHC only) +-- + +-- TODO This instance is not architecture portable. GMP stores numbers as +-- arrays of machine sized words, so the byte format is not portable across +-- architectures with different endianness and word size. + +import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy) +import GHC.Base hiding (ord, chr) +import GHC.Prim +import GHC.Ptr (Ptr(..)) +import GHC.IOBase (IO(..)) + +instance Binary Integer where + put (S# i) = putWord8 0 >> put (I# i) + put (J# s ba) = do + putWord8 1 + put (I# s) + put (BA ba) + + get = do + b <- getWord8 + case b of + 0 -> do (I# i#) <- get + return (S# i#) + _ -> do (I# s#) <- get + (BA a#) <- get + return (J# s# a#) + +instance Binary ByteArray where + + -- Pretty safe. + put (BA ba) = + let sz = sizeofByteArray# ba -- (primitive) in *bytes* + addr = byteArrayContents# ba + bs = unsafePackAddress (I# sz) addr + in put bs -- write as a ByteString. easy, yay! + + -- Pretty scary. Should be quick though + get = do + (fp, off, n@(I# sz)) <- liftM toForeignPtr get -- so decode a ByteString + assert (off == 0) $ return $ unsafePerformIO $ do + (MBA arr) <- newByteArray sz -- and copy it into a ByteArray# + let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe? + withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n) + freezeByteArray arr + +-- wrapper for ByteArray# +data ByteArray = BA {-# UNPACK #-} !ByteArray# +data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newPinnedByteArray# sz s of { (# s', arr #) -> + (# s', MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s', arr' #) -> + (# s', BA arr' #) } + +-} + +instance (Binary a,Integral a) => Binary (R.Ratio a) where + put r = put (R.numerator r) >> put (R.denominator r) + get = liftM2 (R.%) get get + +------------------------------------------------------------------------ + +-- Char is serialised as UTF-8 +instance Binary Char where + put a | c <= 0x7f = put (fromIntegral c :: Word8) + | c <= 0x7ff = do put (0xc0 .|. y) + put (0x80 .|. z) + | c <= 0xffff = do put (0xe0 .|. x) + put (0x80 .|. y) + put (0x80 .|. z) + | c <= 0x10ffff = do put (0xf0 .|. w) + put (0x80 .|. x) + put (0x80 .|. y) + put (0x80 .|. z) + | otherwise = error "Not a valid Unicode code point" + where + c = ord a + z, y, x, w :: Word8 + z = fromIntegral (c .&. 0x3f) + y = fromIntegral (shiftR c 6 .&. 0x3f) + x = fromIntegral (shiftR c 12 .&. 0x3f) + w = fromIntegral (shiftR c 18 .&. 0x7) + + get = do + let getByte = liftM (fromIntegral :: Word8 -> Int) get + shiftL6 = flip shiftL 6 :: Int -> Int + w <- getByte + r <- case () of + _ | w < 0x80 -> return w + | w < 0xe0 -> do + x <- liftM (xor 0x80) getByte + return (x .|. shiftL6 (xor 0xc0 w)) + | w < 0xf0 -> do + x <- liftM (xor 0x80) getByte + y <- liftM (xor 0x80) getByte + return (y .|. shiftL6 (x .|. shiftL6 + (xor 0xe0 w))) + | otherwise -> do + x <- liftM (xor 0x80) getByte + y <- liftM (xor 0x80) getByte + z <- liftM (xor 0x80) getByte + return (z .|. shiftL6 (y .|. shiftL6 + (x .|. shiftL6 (xor 0xf0 w)))) + return $! chr r + +------------------------------------------------------------------------ +-- Instances for the first few tuples + +instance (Binary a, Binary b) => Binary (a,b) where + put (a,b) = put a >> put b + get = liftM2 (,) get get + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + put (a,b,c) = put a >> put b >> put c + get = liftM3 (,,) get get get + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + put (a,b,c,d) = put a >> put b >> put c >> put d + get = liftM4 (,,,) get get get get + +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where + put (a,b,c,d,e) = put a >> put b >> put c >> put d >> put e + get = liftM5 (,,,,) get get get get get + +-- +-- and now just recurse: +-- + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) + => Binary (a,b,c,d,e,f) where + put (a,b,c,d,e,f) = put (a,(b,c,d,e,f)) + get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) + => Binary (a,b,c,d,e,f,g) where + put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g)) + get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, + Binary f, Binary g, Binary h) + => Binary (a,b,c,d,e,f,g,h) where + put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h)) + get = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, + Binary f, Binary g, Binary h, Binary i) + => Binary (a,b,c,d,e,f,g,h,i) where + put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i)) + get = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, + Binary f, Binary g, Binary h, Binary i, Binary j) + => Binary (a,b,c,d,e,f,g,h,i,j) where + put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j)) + get = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j) + +------------------------------------------------------------------------ +-- Container types + +instance Binary a => Binary [a] where + put l = put (length l) >> mapM_ put l + get = do n <- get :: Get Int + getMany n + +-- | 'getMany n' get 'n' elements in order, without blowing the stack. +getMany :: Binary a => Int -> Get [a] +getMany n = go [] n + where + go xs 0 = return $! reverse xs + go xs i = do x <- get + -- we must seq x to avoid stack overflows due to laziness in + -- (>>=) + x `seq` go (x:xs) (i-1) +{-# INLINE getMany #-} + +instance (Binary a) => Binary (Maybe a) where + put Nothing = putWord8 0 + put (Just x) = putWord8 1 >> put x + get = do + w <- getWord8 + case w of + 0 -> return Nothing + _ -> liftM Just get + +instance (Binary a, Binary b) => Binary (Either a b) where + put (Left a) = putWord8 0 >> put a + put (Right b) = putWord8 1 >> put b + get = do + w <- getWord8 + case w of + 0 -> liftM Left get + _ -> liftM Right get + +------------------------------------------------------------------------ +-- ByteStrings (have specially efficient instances) + +instance Binary B.ByteString where + put bs = do put (B.length bs) + putByteString bs + get = get >>= getByteString + +-- +-- Using old versions of fps, this is a type synonym, and non portable +-- +-- Requires 'flexible instances' +-- +instance Binary ByteString where + put bs = do put (fromIntegral (L.length bs) :: Int) + putLazyByteString bs + get = get >>= getLazyByteString + +------------------------------------------------------------------------ +-- Maps and Sets + +instance (Binary a) => Binary (Set.Set a) where + put s = put (Set.size s) >> mapM_ put (Set.toAscList s) + get = liftM Set.fromDistinctAscList get + +instance (Binary k, Binary e) => Binary (Map.Map k e) where + put m = put (Map.size m) >> mapM_ put (Map.toAscList m) + get = liftM Map.fromDistinctAscList get + +instance Binary IntSet.IntSet where + put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s) + get = liftM IntSet.fromDistinctAscList get + +instance (Binary e) => Binary (IntMap.IntMap e) where + put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m) + get = liftM IntMap.fromDistinctAscList get + +------------------------------------------------------------------------ +-- 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 + rep Seq.empty n get + where rep xs 0 _ = return $! xs + rep xs n g = xs `seq` n `seq` do + x <- g + rep (xs Seq.|> x) (n-1) g + +#endif + +------------------------------------------------------------------------ +-- Floating point + +instance Binary Double where + put d = put (decodeFloat d) + get = liftM2 encodeFloat get get + +instance Binary Float where + put f = put (decodeFloat f) + get = liftM2 encodeFloat get get + +------------------------------------------------------------------------ +-- Trees + +instance (Binary e) => Binary (T.Tree e) where + put (T.Node r s) = put r >> put s + get = liftM2 T.Node get get + +------------------------------------------------------------------------ +-- Arrays + +instance (Binary i, Ix i, Binary e) => Binary (Array i e) where + put a = do + put (bounds a) + put (rangeSize $ bounds a) -- write the length + mapM_ put (elems a) -- now the elems. + get = do + bs <- get + n <- get -- read the length + xs <- getMany n -- now the elems. + return (listArray bs xs) + +-- +-- The IArray UArray e constraint is non portable. Requires flexible instances +-- +instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where + put a = do + put (bounds a) + put (rangeSize $ bounds a) -- now write the length + mapM_ put (elems a) + get = do + bs <- get + n <- get + xs <- getMany n + return (listArray bs xs) diff --git a/Distribution/Compat/Binary/Generic.hs b/Distribution/Compat/Binary/Generic.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Binary/Generic.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures, + ScopedTypeVariables, Trustworthy, TypeOperators, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compat.Binary.Generic +-- Copyright : Bryan O'Sullivan +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Bryan O'Sullivan +-- Stability : unstable +-- Portability : Only works with GHC 7.2 and newer +-- +-- Instances for supporting GHC generics. +-- +----------------------------------------------------------------------------- +module Distribution.Compat.Binary.Generic + ( + ) where + +import Control.Applicative +import Distribution.Compat.Binary.Class +import Data.Binary.Get +import Data.Binary.Put +import Data.Bits +import Data.Word +import GHC.Generics + +-- Type without constructors +instance GBinary V1 where + gput _ = return () + gget = return undefined + +-- Constructor without arguments +instance GBinary U1 where + gput U1 = return () + gget = return U1 + +-- Product: constructor with parameters +instance (GBinary a, GBinary b) => GBinary (a :*: b) where + gput (x :*: y) = gput x >> gput y + gget = (:*:) <$> gget <*> gget + +-- Metadata (constructor name, etc) +instance GBinary a => GBinary (M1 i c a) where + gput = gput . unM1 + gget = M1 <$> gget + +-- Constants, additional parameters, and rank-1 recursion +instance Binary a => GBinary (K1 i a) where + gput = put . unK1 + gget = K1 <$> get + +-- Borrowed from the cereal package. + +-- The following GBinary instance for sums has support for serializing +-- types with up to 2^64-1 constructors. It will use the minimal +-- number of bytes needed to encode the constructor. For example when +-- a type has 2^8 constructors or less it will use a single byte to +-- encode the constructor. If it has 2^16 constructors or less it will +-- use two bytes, and so on till 2^64-1. + +#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) +#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) +#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) + +instance ( GSum a, GSum b + , GBinary a, GBinary b + , SumSize a, SumSize b) => GBinary (a :+: b) where + gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64) + | otherwise = sizeError "encode" size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word64) + + gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64) + | otherwise = sizeError "decode" size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word64) + +sizeError :: Show size => String -> size -> error +sizeError s size = + error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors" + +------------------------------------------------------------------------ + +checkGetSum :: (Ord word, Num word, Bits word, GSum f) + => word -> word -> Get (f a) +checkGetSum size code | code < size = getSum code size + | otherwise = fail "Unknown encoding for constructor" +{-# INLINE checkGetSum #-} + +class GSum f where + getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) + putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put + +instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where + getSum !code !size | code < sizeL = L1 <$> getSum code sizeL + | otherwise = R1 <$> getSum (code - sizeL) sizeR + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + + putSum !code !size s = case s of + L1 x -> putSum code sizeL x + R1 x -> putSum (code + sizeL) sizeR x + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + +instance GBinary a => GSum (C1 c a) where + getSum _ _ = gget + + putSum !code _ x = put code *> gput x + +------------------------------------------------------------------------ + +class SumSize f where + sumSize :: Tagged f Word64 + +newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b} + +instance (SumSize a, SumSize b) => SumSize (a :+: b) where + sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + + unTagged (sumSize :: Tagged b Word64) + +instance SumSize (C1 c a) where + sumSize = Tagged 1 diff --git a/Distribution/Compat/CopyFile.hs b/Distribution/Compat/CopyFile.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/CopyFile.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} +module Distribution.Compat.CopyFile ( + copyFile, + copyFileChanged, + filesEqual, + copyOrdinaryFile, + copyExecutableFile, + setFileOrdinary, + setFileExecutable, + setDirOrdinary, + ) where + + +import Control.Monad + ( when, unless ) +import Control.Exception + ( bracket, 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 + , withBinaryFile ) +import Foreign + ( allocaBytes ) + +#ifndef mingw32_HOST_OS +import System.Posix.Internals (withFilePath) +import System.Posix.Types + ( FileMode ) +import System.Posix.Internals + ( c_chmod ) +import Foreign.C + ( throwErrnoPathIfMinus1_ ) +#endif /* mingw32_HOST_OS */ + +copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO () +copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest +copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest + +setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () +#ifndef mingw32_HOST_OS +setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- +setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x + +setFileMode :: FilePath -> FileMode -> IO () +setFileMode name m = + withFilePath name $ \s -> do + throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) +#else +setFileOrdinary _ = return () +setFileExecutable _ = return () +#endif +-- This happens to be true on Unix and currently on Windows too: +setDirOrdinary = setFileExecutable + +-- | Copies a file to a new destination. +-- Often you should use `copyFileChanged` instead. +copyFile :: FilePath -> FilePath -> IO () +copyFile fromFPath toFPath = + copy + `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile")) + where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> + bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> + do allocaBytes bufferSize $ copyContents hFrom hTmp + hClose hTmp + renameFile tmpFPath toFPath + openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp" + cleanTmp (tmpFPath, hTmp) = do + hClose hTmp `catchIO` \_ -> return () + removeFile tmpFPath `catchIO` \_ -> return () + bufferSize = 4096 + + copyContents hFrom hTo buffer = do + count <- hGetBuf hFrom buffer bufferSize + when (count > 0) $ do + hPutBuf hTo buffer count + copyContents hFrom hTo buffer + +-- | Like `copyFile`, but does not touch the target if source and destination +-- are already byte-identical. This is recommended as it is useful for +-- time-stamp based recompilation avoidance. +copyFileChanged :: FilePath -> FilePath -> IO () +copyFileChanged src dest = do + equal <- filesEqual src dest + unless equal $ copyFile src dest + +-- | Checks if two files are byte-identical. +-- Returns False if either of the files do not exist. +filesEqual :: FilePath -> FilePath -> IO Bool +filesEqual f1 f2 = do + ex1 <- doesFileExist f1 + ex2 <- doesFileExist f2 + if not (ex1 && ex2) then return False else do + + withBinaryFile f1 ReadMode $ \h1 -> + withBinaryFile f2 ReadMode $ \h2 -> do + c1 <- BSL.hGetContents h1 + c2 <- BSL.hGetContents h2 + return $! c1 == c2 diff --git a/Distribution/Compat/CreatePipe.hs b/Distribution/Compat/CreatePipe.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/CreatePipe.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +module Distribution.Compat.CreatePipe (createPipe) where + +import System.IO (Handle, hSetEncoding, localeEncoding) + +-- The mingw32_HOST_OS CPP macro is GHC-specific +#if mingw32_HOST_OS +import Control.Exception (onException) +import Foreign.C.Error (throwErrnoIfMinus1_) +import Foreign.C.Types (CInt(..), CUInt(..)) +import Foreign.Ptr (Ptr) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Storable (peek, peekElemOff) +import GHC.IO.FD (mkFD) +import GHC.IO.Device (IODeviceType(Stream)) +import GHC.IO.Handle.FD (mkHandleFromFD) +import System.IO (IOMode(ReadMode, WriteMode)) +#elif ghcjs_HOST_OS +#else +import System.Posix.IO (fdToHandle) +import qualified System.Posix.IO as Posix +#endif + +createPipe :: IO (Handle, Handle) +-- The mingw32_HOST_OS CPP macro is GHC-specific +#if mingw32_HOST_OS +createPipe = do + (readfd, writefd) <- allocaArray 2 $ \ pfds -> do + throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 ({- _O_BINARY -} 32768) + readfd <- peek pfds + writefd <- peekElemOff pfds 1 + return (readfd, writefd) + (do readh <- fdToHandle readfd ReadMode + writeh <- fdToHandle writefd WriteMode + hSetEncoding readh localeEncoding + hSetEncoding writeh localeEncoding + return (readh, writeh)) `onException` (close readfd >> close writefd) + where + fdToHandle :: CInt -> IOMode -> IO Handle + fdToHandle fd mode = do + (fd', deviceType) <- mkFD fd mode (Just (Stream, 0, 0)) False False + mkHandleFromFD fd' deviceType "" mode False Nothing + + close :: CInt -> IO () + close = throwErrnoIfMinus1_ "_close" . c__close + +foreign import ccall "io.h _pipe" c__pipe :: + Ptr CInt -> CUInt -> CInt -> IO CInt + +foreign import ccall "io.h _close" c__close :: + CInt -> IO CInt +#elif ghcjs_HOST_OS +createPipe = error "createPipe" +#else +createPipe = do + (readfd, writefd) <- Posix.createPipe + readh <- fdToHandle readfd + writeh <- fdToHandle writefd + hSetEncoding readh localeEncoding + hSetEncoding writeh localeEncoding + return (readh, writeh) +#endif diff --git a/Distribution/Compat/Environment.hs b/Distribution/Compat/Environment.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Environment.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} + +module Distribution.Compat.Environment (getEnvironment) + where + +import qualified System.Environment as System + +#ifdef mingw32_HOST_OS +import qualified Data.Char as Char (toUpper) +#endif + +getEnvironment :: IO [(String, String)] +#ifdef mingw32_HOST_OS +-- On Windows, the names of environment variables are case-insensitive, but are +-- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise +-- them. +getEnvironment = fmap upcaseVars System.getEnvironment + where + upcaseVars = map upcaseVar + upcaseVar (var, val) = (map Char.toUpper var, val) +#else +getEnvironment = System.getEnvironment +#endif diff --git a/Distribution/Compat/Exception.hs b/Distribution/Compat/Exception.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Exception.hs @@ -0,0 +1,17 @@ +module Distribution.Compat.Exception ( + catchIO, + catchExit, + tryIO, + ) where + +import System.Exit +import qualified Control.Exception as Exception + +tryIO :: IO a -> IO (Either Exception.IOException a) +tryIO = Exception.try + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +catchIO = Exception.catch + +catchExit :: IO a -> (ExitCode -> IO a) -> IO a +catchExit = Exception.catch diff --git a/Distribution/Compat/ReadP.hs b/Distribution/Compat/ReadP.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/ReadP.hs @@ -0,0 +1,398 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compat.ReadP +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This is a library of parser combinators, originally written by Koen Claessen. +-- It parses all alternatives in parallel, so it never keeps hold of +-- the beginning of the input string, a common source of space leaks with +-- other parsers. The '(+++)' choice combinator is genuinely commutative; +-- it makes no difference which branch is \"shorter\". +-- +-- See also Koen's paper /Parallel Parsing Processes/ +-- (). +-- +-- This version of ReadP has been locally hacked to make it H98, by +-- Martin Sjögren +-- +-- The unit tests have been moved to UnitTest.Distribution.Compat.ReadP, by +-- Mark Lentczner +----------------------------------------------------------------------------- + +module Distribution.Compat.ReadP + ( + -- * The 'ReadP' type + ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus + + -- * Primitive operations + get, -- :: ReadP Char + look, -- :: ReadP String + (+++), -- :: ReadP a -> ReadP a -> ReadP a + (<++), -- :: ReadP a -> ReadP a -> ReadP a + gather, -- :: ReadP a -> ReadP (String, a) + + -- * Other operations + pfail, -- :: ReadP a + satisfy, -- :: (Char -> Bool) -> ReadP Char + char, -- :: Char -> ReadP Char + string, -- :: String -> ReadP String + munch, -- :: (Char -> Bool) -> ReadP String + munch1, -- :: (Char -> Bool) -> ReadP String + skipSpaces, -- :: ReadP () + choice, -- :: [ReadP a] -> ReadP a + count, -- :: Int -> ReadP a -> ReadP [a] + between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a + option, -- :: a -> ReadP a -> ReadP a + optional, -- :: ReadP a -> ReadP () + many, -- :: ReadP a -> ReadP [a] + many1, -- :: ReadP a -> ReadP [a] + skipMany, -- :: ReadP a -> ReadP () + skipMany1, -- :: ReadP a -> ReadP () + sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a] + sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] + endBy, -- :: ReadP a -> ReadP sep -> ReadP [a] + endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] + chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a + chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a + chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a + chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a + manyTill, -- :: ReadP a -> ReadP end -> ReadP [a] + + -- * Running a parser + ReadS, -- :: *; = String -> [(a,String)] + readP_to_S, -- :: ReadP a -> ReadS a + readS_to_P -- :: ReadS a -> ReadP a + ) + where + +import Control.Monad( MonadPlus(..), liftM, liftM2, ap ) +import Data.Char (isSpace) +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative (Applicative(..)) +#endif +import Control.Applicative (Alternative(empty, (<|>))) + +infixr 5 +++, <++ + +-- --------------------------------------------------------------------------- +-- The P type +-- is representation type -- should be kept abstract + +data P s a + = Get (s -> P s a) + | Look ([s] -> P s a) + | Fail + | Result a (P s a) + | Final [(a,[s])] -- invariant: list is non-empty! + +-- Monad, MonadPlus + +instance Functor (P s) where + fmap = liftM + +instance Applicative (P s) where + pure = return + (<*>) = ap + +instance Monad (P s) where + return x = Result x Fail + + (Get f) >>= k = Get (\c -> f c >>= k) + (Look f) >>= k = Look (\s -> f s >>= k) + Fail >>= _ = Fail + (Result x p) >>= k = k x `mplus` (p >>= k) + (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s] + + fail _ = Fail + +instance Alternative (P s) where + empty = mzero + (<|>) = mplus + +instance MonadPlus (P s) where + mzero = Fail + + -- most common case: two gets are combined + Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c) + + -- results are delivered as soon as possible + Result x p `mplus` q = Result x (p `mplus` q) + p `mplus` Result x q = Result x (p `mplus` q) + + -- fail disappears + Fail `mplus` p = p + p `mplus` Fail = p + + -- two finals are combined + -- final + look becomes one look and one final (=optimization) + -- final + sthg else becomes one look and one final + Final r `mplus` Final t = Final (r ++ t) + Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s)) + Final r `mplus` p = Look (\s -> Final (r ++ run p s)) + Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r)) + p `mplus` Final r = Look (\s -> Final (run p s ++ r)) + + -- two looks are combined (=optimization) + -- look + sthg else floats upwards + Look f `mplus` Look g = Look (\s -> f s `mplus` g s) + Look f `mplus` p = Look (\s -> f s `mplus` p) + p `mplus` Look f = Look (\s -> p `mplus` f s) + +-- --------------------------------------------------------------------------- +-- The ReadP type + +newtype Parser r s a = R ((a -> P s r) -> P s r) +type ReadP r a = Parser r Char a + +-- Functor, Monad, MonadPlus + +instance Functor (Parser r s) where + fmap h (R f) = R (\k -> f (k . h)) + +instance Applicative (Parser r s) where + pure = return + (<*>) = ap + +instance Monad (Parser r s) where + return x = R (\k -> k x) + fail _ = R (\_ -> Fail) + R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) + +--instance MonadPlus (Parser r s) where +-- mzero = pfail +-- mplus = (+++) + +-- --------------------------------------------------------------------------- +-- Operations over P + +final :: [(a,[s])] -> P s a +-- Maintains invariant for Final constructor +final [] = Fail +final r = Final r + +run :: P c a -> ([c] -> [(a, [c])]) +run (Get f) (c:s) = run (f c) s +run (Look f) s = run (f s) s +run (Result x p) s = (x,s) : run p s +run (Final r) _ = r +run _ _ = [] + +-- --------------------------------------------------------------------------- +-- Operations over ReadP + +get :: ReadP r Char +-- ^ Consumes and returns the next character. +-- Fails if there is no input left. +get = R Get + +look :: ReadP r String +-- ^ Look-ahead: returns the part of the input that is left, without +-- consuming it. +look = R Look + +pfail :: ReadP r a +-- ^ Always fails. +pfail = R (\_ -> Fail) + +(+++) :: ReadP r a -> ReadP r a -> ReadP r a +-- ^ Symmetric choice. +R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k) + +(<++) :: ReadP a a -> ReadP r a -> ReadP r a +-- ^ Local, exclusive, left-biased choice: If left parser +-- locally produces any result at all, then right parser is +-- not used. +R f <++ q = + do s <- look + probe (f return) s 0 + where + probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int) + probe (Look f') s n = probe (f' s) s n + probe p@(Result _ _) _ n = discard n >> R (p >>=) + probe (Final r) _ _ = R (Final r >>=) + probe _ _ _ = q + + discard 0 = return () + discard n = get >> discard (n-1 :: Int) + +gather :: ReadP (String -> P Char r) a -> ReadP r (String, a) +-- ^ Transforms a parser into one that does the same, but +-- in addition returns the exact characters read. +-- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument +-- is built using any occurrences of readS_to_P. +gather (R m) = + R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) + where + gath l (Get f) = Get (\c -> gath (l.(c:)) (f c)) + gath _ Fail = Fail + gath l (Look f) = Look (\s -> gath l (f s)) + gath l (Result k p) = k (l []) `mplus` gath l p + gath _ (Final _) = error "do not use readS_to_P in gather!" + +-- --------------------------------------------------------------------------- +-- Derived operations + +satisfy :: (Char -> Bool) -> ReadP r Char +-- ^ Consumes and returns the next character, if it satisfies the +-- specified predicate. +satisfy p = do c <- get; if p c then return c else pfail + +char :: Char -> ReadP r Char +-- ^ Parses and returns the specified character. +char c = satisfy (c ==) + +string :: String -> ReadP r String +-- ^ Parses and returns the specified string. +string this = do s <- look; scan this s + where + scan [] _ = do return this + scan (x:xs) (y:ys) | x == y = do get >> scan xs ys + scan _ _ = do pfail + +munch :: (Char -> Bool) -> ReadP r String +-- ^ Parses the first zero or more characters satisfying the predicate. +munch p = + do s <- look + scan s + where + scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s) + scan _ = do return "" + +munch1 :: (Char -> Bool) -> ReadP r String +-- ^ Parses the first one or more characters satisfying the predicate. +munch1 p = + do c <- get + if p c then do s <- munch p; return (c:s) + else pfail + +choice :: [ReadP r a] -> ReadP r a +-- ^ Combines all parsers in the specified list. +choice [] = pfail +choice [p] = p +choice (p:ps) = p +++ choice ps + +skipSpaces :: ReadP r () +-- ^ Skips all whitespace. +skipSpaces = + do s <- look + skip s + where + skip (c:s) | isSpace c = do _ <- get; skip s + skip _ = do return () + +count :: Int -> ReadP r a -> ReadP r [a] +-- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of +-- results is returned. +count n p = sequence (replicate n p) + +between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a +-- ^ @ between open close p @ parses @open@, followed by @p@ and finally +-- @close@. Only the value of @p@ is returned. +between open close p = do _ <- open + x <- p + _ <- close + return x + +option :: a -> ReadP r a -> ReadP r a +-- ^ @option x p@ will either parse @p@ or return @x@ without consuming +-- any input. +option x p = p +++ return x + +optional :: ReadP r a -> ReadP r () +-- ^ @optional p@ optionally parses @p@ and always returns @()@. +optional p = (p >> return ()) +++ return () + +many :: ReadP r a -> ReadP r [a] +-- ^ Parses zero or more occurrences of the given parser. +many p = return [] +++ many1 p + +many1 :: ReadP r a -> ReadP r [a] +-- ^ Parses one or more occurrences of the given parser. +many1 p = liftM2 (:) p (many p) + +skipMany :: ReadP r a -> ReadP r () +-- ^ Like 'many', but discards the result. +skipMany p = many p >> return () + +skipMany1 :: ReadP r a -> ReadP r () +-- ^ Like 'many1', but discards the result. +skipMany1 p = p >> skipMany p + +sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@. +-- Returns a list of values returned by @p@. +sepBy p sep = sepBy1 p sep +++ return [] + +sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@. +-- Returns a list of values returned by @p@. +sepBy1 p sep = liftM2 (:) p (many (sep >> p)) + +endBy :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended +-- by @sep@. +endBy p sep = many (do x <- p ; _ <- sep ; return x) + +endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended +-- by @sep@. +endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x) + +chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a +-- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a /right/ associative application of all +-- functions returned by @op@. If there are no occurrences of @p@, @x@ is +-- returned. +chainr p op x = chainr1 p op +++ return x + +chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a +-- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a /left/ associative application of all +-- functions returned by @op@. If there are no occurrences of @p@, @x@ is +-- returned. +chainl p op x = chainl1 p op +++ return x + +chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a +-- ^ Like 'chainr', but parses one or more occurrences of @p@. +chainr1 p op = scan + where scan = p >>= rest + rest x = do f <- op + y <- scan + return (f x y) + +++ return x + +chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a +-- ^ Like 'chainl', but parses one or more occurrences of @p@. +chainl1 p op = p >>= rest + where rest x = do f <- op + y <- p + rest (f x y) + +++ return x + +manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a] +-- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@ +-- succeeds. Returns a list of values returned by @p@. +manyTill p end = scan + where scan = (end >> return []) <++ (liftM2 (:) p scan) + +-- --------------------------------------------------------------------------- +-- Converting between ReadP and Read + +readP_to_S :: ReadP a a -> ReadS a +-- ^ Converts a parser into a Haskell ReadS-style function. +-- This is the main way in which you can \"run\" a 'ReadP' parser: +-- the expanded type is +-- @ readP_to_S :: ReadP a -> String -> [(a,String)] @ +readP_to_S (R f) = run (f return) + +readS_to_P :: ReadS a -> ReadP r a +-- ^ Converts a Haskell ReadS-style function into a parser. +-- Warning: This introduces local backtracking in the resulting +-- parser, and therefore a possible inefficiency. +readS_to_P r = + R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s'])) diff --git a/Distribution/Compat/TempFile.hs b/Distribution/Compat/TempFile.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/TempFile.hs @@ -0,0 +1,128 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Distribution/Compiler.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compiler +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This has an enumeration of the various compilers that Cabal knows about. It +-- also specifies the default compiler. Sadly you'll often see code that does +-- case analysis on this compiler flavour enumeration like: +-- +-- > case compilerFlavor comp of +-- > GHC -> GHC.getInstalledPackages verbosity packageDb progconf +-- > JHC -> JHC.getInstalledPackages verbosity packageDb progconf +-- +-- Obviously it would be better to use the proper 'Compiler' abstraction +-- because that would keep all the compiler-specific code together. +-- Unfortunately we cannot make this change yet without breaking the +-- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the +-- moment we just have to live with this deficiency. If you're interested, see +-- ticket #57. + +module Distribution.Compiler ( + -- * Compiler flavor + CompilerFlavor(..), + buildCompilerId, + buildCompilerFlavor, + defaultCompilerFlavor, + parseCompilerFlavorCompat, + + -- * Compiler id + CompilerId(..), + + -- * Compiler info + CompilerInfo(..), + unknownCompilerInfo, + AbiTag(..), abiTagString + ) where + +import Distribution.Compat.Binary (Binary) +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 +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>)) + +import qualified Data.Char as Char (toLower, isDigit, isAlphaNum) +import Control.Monad (when) + +data CompilerFlavor = GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC + | HaskellSuite String -- string is the id of the actual compiler + | OtherCompiler String + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) + +instance Binary CompilerFlavor + +knownCompilerFlavors :: [CompilerFlavor] +knownCompilerFlavors = [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC] + +instance Text CompilerFlavor where + disp (OtherCompiler name) = Disp.text name + disp (HaskellSuite name) = Disp.text name + disp NHC = Disp.text "nhc98" + disp other = Disp.text (lowercase (show other)) + + parse = do + comp <- Parse.munch1 Char.isAlphaNum + when (all Char.isDigit comp) Parse.pfail + return (classifyCompilerFlavor comp) + +classifyCompilerFlavor :: String -> CompilerFlavor +classifyCompilerFlavor s = + fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap + where + compilerMap = [ (display compiler, compiler) + | compiler <- knownCompilerFlavors ] + + +--TODO: In some future release, remove 'parseCompilerFlavorCompat' and use +-- ordinary 'parse'. Also add ("nhc", NHC) to the above 'compilerMap'. + +-- | Like 'classifyCompilerFlavor' but compatible with the old ReadS parser. +-- +-- It is compatible in the sense that it accepts only the same strings, +-- eg "GHC" but not "ghc". However other strings get mapped to 'OtherCompiler'. +-- The point of this is that we do not allow extra valid values that would +-- upset older Cabal versions that had a stricter parser however we cope with +-- new values more gracefully so that we'll be able to introduce new value in +-- future without breaking things so much. +-- +parseCompilerFlavorCompat :: Parse.ReadP r CompilerFlavor +parseCompilerFlavorCompat = do + comp <- Parse.munch1 Char.isAlphaNum + when (all Char.isDigit comp) Parse.pfail + case lookup comp compilerMap of + Just compiler -> return compiler + Nothing -> return (OtherCompiler comp) + where + compilerMap = [ (show compiler, compiler) + | compiler <- knownCompilerFlavors + , compiler /= YHC ] + +buildCompilerFlavor :: CompilerFlavor +buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName + +buildCompilerVersion :: Version +buildCompilerVersion = System.Info.compilerVersion + +buildCompilerId :: CompilerId +buildCompilerId = CompilerId buildCompilerFlavor buildCompilerVersion + +-- | The default compiler flavour to pick when compiling stuff. This defaults +-- to the compiler used to build the Cabal lib. +-- +-- However if it's not a recognised compiler then it's 'Nothing' and the user +-- will have to specify which compiler they want. +-- +defaultCompilerFlavor :: Maybe CompilerFlavor +defaultCompilerFlavor = case buildCompilerFlavor of + OtherCompiler _ -> Nothing + _ -> Just buildCompilerFlavor + +-- ------------------------------------------------------------ +-- * Compiler Id +-- ------------------------------------------------------------ + +data CompilerId = CompilerId CompilerFlavor Version + deriving (Eq, Generic, Ord, Read, Show) + +instance Binary CompilerId + +instance Text CompilerId where + disp (CompilerId f (Version [] _)) = disp f + disp (CompilerId f v) = disp f <> Disp.char '-' <> disp v + + parse = do + flavour <- parse + version <- (Parse.char '-' >> parse) Parse.<++ return (Version [] []) + return (CompilerId flavour version) + +lowercase :: String -> String +lowercase = map Char.toLower + +-- ------------------------------------------------------------ +-- * Compiler Info +-- ------------------------------------------------------------ + +-- | Compiler information used for resolving configurations. Some fields can be +-- set to Nothing to indicate that the information is unknown. + +data CompilerInfo = CompilerInfo { + compilerInfoId :: CompilerId, + -- ^ Compiler flavour and version. + compilerInfoAbiTag :: AbiTag, + -- ^ Tag for distinguishing incompatible ABI's on the same architecture/os. + compilerInfoCompat :: Maybe [CompilerId], + -- ^ Other implementations that this compiler claims to be compatible with, if known. + compilerInfoLanguages :: Maybe [Language], + -- ^ Supported language standards, if known. + compilerInfoExtensions :: Maybe [Extension] + -- ^ Supported extensions, if known. + } + deriving (Generic, Show, Read) + +instance Binary CompilerInfo + +data AbiTag + = NoAbiTag + | AbiTag String + deriving (Generic, Show, Read) + +instance Binary AbiTag + +instance Text AbiTag where + disp NoAbiTag = Disp.empty + disp (AbiTag tag) = Disp.text tag + + parse = do + tag <- Parse.munch (\c -> Char.isAlphaNum c || c == '_') + if null tag then return NoAbiTag else return (AbiTag tag) + +abiTagString :: AbiTag -> String +abiTagString NoAbiTag = "" +abiTagString (AbiTag tag) = tag + +-- | Make a CompilerInfo of which only the known information is its CompilerId, +-- its AbiTag and that it does not claim to be compatible with other +-- compiler id's. +unknownCompilerInfo :: CompilerId -> AbiTag -> CompilerInfo +unknownCompilerInfo compilerId abiTag = + CompilerInfo compilerId abiTag (Just []) Nothing Nothing diff --git a/Distribution/GetOpt.hs b/Distribution/GetOpt.hs new file mode 100644 --- /dev/null +++ b/Distribution/GetOpt.hs @@ -0,0 +1,335 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.GetOpt +-- Copyright : (c) Sven Panne 2002-2005 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This library provides facilities for parsing the command-line options +-- in a standalone program. It is essentially a Haskell port of the GNU +-- @getopt@ library. +-- +----------------------------------------------------------------------------- + +{- +Sven Panne Oct. 1996 (small +changes Dec. 1997) + +Two rather obscure features are missing: The Bash 2.0 non-option hack +(if you don't already know it, you probably don't want to hear about +it...) and the recognition of long options with a single dash +(e.g. '-help' is recognised as '--help', as long as there is no short +option 'h'). + +Other differences between GNU's getopt and this implementation: + +* To enforce a coherent description of options and arguments, there + are explanation fields in the option/argument descriptor. + +* Error messages are now more informative, but no longer POSIX + compliant... :-( + +And a final Haskell advertisement: The GNU C implementation uses well +over 1100 lines, we need only 195 here, including a 46 line example! +:-) +-} + +{-# OPTIONS_HADDOCK hide #-} +module Distribution.GetOpt ( + -- * GetOpt + getOpt, getOpt', + usageInfo, + ArgOrder(..), + OptDescr(..), + ArgDescr(..), + + -- * Example + + -- $example +) where + +import Data.List ( isPrefixOf, intercalate, find ) +import Data.Maybe ( isJust ) + +-- |What to do with options following non-options +data ArgOrder a + = RequireOrder -- ^ no option processing after first non-option + | Permute -- ^ freely intersperse options and non-options + | ReturnInOrder (String -> a) -- ^ wrap non-options into options + +{-| +Each 'OptDescr' describes a single option. + +The arguments to 'Option' are: + +* list of short option characters + +* list of long option strings (without \"--\") + +* argument descriptor + +* explanation of option for user +-} +data OptDescr a = -- description of a single options: + Option [Char] -- list of short option characters + [String] -- list of long option strings (without "--") + (ArgDescr a) -- argument descriptor + String -- explanation of option for user + +-- |Describes whether an option takes an argument or not, and if so +-- how the argument is injected into a value of type @a@. +data ArgDescr a + = NoArg a -- ^ no argument expected + | ReqArg (String -> a) String -- ^ option requires argument + | OptArg (Maybe String -> a) String -- ^ optional argument + +data OptKind a -- kind of cmd line arg (internal use only): + = Opt a -- an option + | UnreqOpt String -- an un-recognized option + | NonOpt String -- a non-option + | EndOfOpts -- end-of-options marker (i.e. "--") + | OptErr String -- something went wrong... + +-- | Return a string describing the usage of a command, derived from +-- the header (first argument) and the options described by the +-- second argument. +usageInfo :: String -- header + -> [OptDescr a] -- option descriptors + -> String -- nicely formatted decription of options +usageInfo header optDescr = unlines (header:table) + where (ss,ls,ds) = unzip3 [ (intercalate ", " (map (fmtShort ad) sos) + ,concatMap (fmtLong ad) (take 1 los) + ,d) + | Option sos los ad d <- optDescr ] + ssWidth = (maximum . map length) ss + lsWidth = (maximum . map length) ls + dsWidth = 30 `max` (80 - (ssWidth + lsWidth + 3)) + table = [ " " ++ padTo ssWidth so' ++ + " " ++ padTo lsWidth lo' ++ + " " ++ d' + | (so,lo,d) <- zip3 ss ls ds + , (so',lo',d') <- fmtOpt dsWidth so lo d ] + padTo n x = take n (x ++ repeat ' ') + +fmtOpt :: Int -> String -> String -> String -> [(String, String, String)] +fmtOpt descrWidth so lo descr = + case wrapText descrWidth descr of + [] -> [(so,lo,"")] + (d:ds) -> (so,lo,d) : [ ("","",d') | d' <- ds ] + +fmtShort :: ArgDescr a -> Char -> String +fmtShort (NoArg _ ) so = "-" ++ [so] +fmtShort (ReqArg _ _) so = "-" ++ [so] +fmtShort (OptArg _ _) so = "-" ++ [so] + +fmtLong :: ArgDescr a -> String -> String +fmtLong (NoArg _ ) lo = "--" ++ lo +fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad +fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" + +wrapText :: Int -> String -> [String] +wrapText width = map unwords . wrap 0 [] . words + where wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w:ws) + | length w + 1 > width + = wrap (length w) [w] ws + wrap col line (w:ws) + | col + length w + 1 > width + = reverse line : wrap 0 [] (w:ws) + wrap col line (w:ws) + = let col' = col + length w + 1 + in wrap col' (w:line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +{-| +Process the command-line, and return the list of values that matched +(and those that didn\'t). The arguments are: + +* The order requirements (see 'ArgOrder') + +* The option descriptions (see 'OptDescr') + +* The actual command line arguments (presumably got from + 'System.Environment.getArgs'). + +'getOpt' returns a triple consisting of the option arguments, a list +of non-options, and a list of error messages. +-} +getOpt :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a],[String],[String]) -- (options,non-options,error messages) +getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) + where (os,xs,us,es) = getOpt' ordering optDescr args + +{-| +This is almost the same as 'getOpt', but returns a quadruple +consisting of the option arguments, a list of non-options, a list of +unrecognized options, and a list of error messages. +-} +getOpt' :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) +getOpt' _ _ [] = ([],[],[],[]) +getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering + where procNextOpt (Opt o) _ = (o:os,xs,us,es) + procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) + procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) + procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) + procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) + procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) + procNextOpt EndOfOpts Permute = ([],rest,[],[]) + procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) + procNextOpt (OptErr e) _ = (os,xs,us,e:es) + + (opt,rest) = getNext arg args optDescr + (os,xs,us,es) = getOpt' ordering optDescr rest + +-- take a look at the next cmd line arg and decide what to do with it +getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) +getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr +getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr +getNext a rest _ = (NonOpt a,rest) + +-- handle long option +longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +longOpt ls rs optDescr = long ads arg rs + where (opt,arg) = break (=='=') ls + getWith p = [ o | o@(Option _ xs _ _) <- optDescr + , isJust (find (p opt) xs)] + exact = getWith (==) + options = if null exact then getWith isPrefixOf else exact + ads = [ ad | Option _ _ ad _ <- options ] + optStr = "--" ++ opt + + long (_:_:_) _ rest = (errAmbig options optStr,rest) + long [NoArg a ] [] rest = (Opt a,rest) + long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) + long [ReqArg _ d] [] [] = (errReq d optStr,[]) + long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) + long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) + long [OptArg f _] [] rest = (Opt (f Nothing),rest) + long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) + long _ _ rest = (UnreqOpt ("--"++ls),rest) + +-- handle short option +shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +shortOpt y ys rs optDescr = short ads ys rs + where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] + ads = [ ad | Option _ _ ad _ <- options ] + optStr = '-':[y] + + short (_:_:_) _ rest = (errAmbig options optStr,rest) + short (NoArg a :_) [] rest = (Opt a,rest) + short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) + short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) + short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) + short (ReqArg f _:_) xs rest = (Opt (f xs),rest) + short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) + short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) + short [] [] rest = (UnreqOpt optStr,rest) + short [] xs rest = (UnreqOpt (optStr++xs),rest) + +-- miscellaneous error formatting + +errAmbig :: [OptDescr a] -> String -> OptKind a +errAmbig ods optStr = OptErr (usageInfo header ods) + where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" + +errReq :: String -> String -> OptKind a +errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") + +errUnrec :: String -> String +errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" + +errNoArg :: String -> OptKind a +errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") + +{- +----------------------------------------------------------------------------------------- +-- and here a small and hopefully enlightening example: + +data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show + +options :: [OptDescr Flag] +options = + [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", + Option ['V','?'] ["version","release"] (NoArg Version) "show version info", + Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", + Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] + +out :: Maybe String -> Flag +out Nothing = Output "stdout" +out (Just o) = Output o + +test :: ArgOrder Flag -> [String] -> String +test order cmdline = case getOpt order options cmdline of + (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" + (_,_,errs) -> concat errs ++ usageInfo header options + where header = "Usage: foobar [OPTION...] files..." + +-- example runs: +-- putStr (test RequireOrder ["foo","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["foo","-v"]) +-- ==> options=[Verbose] args=["foo"] +-- putStr (test (ReturnInOrder Arg) ["foo","-v"]) +-- ==> options=[Arg "foo", Verbose] args=[] +-- putStr (test Permute ["foo","--","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["-?o","--name","bar","--na=baz"]) +-- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] +-- putStr (test Permute ["--ver","foo"]) +-- ==> option `--ver' is ambiguous; could be one of: +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- Usage: foobar [OPTION...] files... +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- -o[FILE] --output[=FILE] use FILE for dump +-- -n USER --name=USER only dump USER's files +----------------------------------------------------------------------------------------- +-} + +{- $example + +To hopefully illuminate the role of the different data +structures, here\'s the command-line options for a (very simple) +compiler: + +> module Opts where +> +> import Distribution.GetOpt +> import Data.Maybe ( fromMaybe ) +> +> data Flag +> = Verbose | Version +> | Input String | Output String | LibDir String +> deriving Show +> +> options :: [OptDescr Flag] +> options = +> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" +> , Option ['V','?'] ["version"] (NoArg Version) "show version number" +> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE" +> , Option ['c'] [] (OptArg inp "FILE") "input FILE" +> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" +> ] +> +> inp,outp :: Maybe String -> Flag +> outp = Output . fromMaybe "stdout" +> inp = Input . fromMaybe "stdin" +> +> compilerOpts :: [String] -> IO ([Flag], [String]) +> compilerOpts argv = +> case getOpt Permute options argv of +> (o,n,[] ) -> return (o,n) +> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) +> where header = "Usage: ic [OPTION...] files..." + +-} diff --git a/Distribution/InstalledPackageInfo.hs b/Distribution/InstalledPackageInfo.hs new file mode 100644 --- /dev/null +++ b/Distribution/InstalledPackageInfo.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.InstalledPackageInfo +-- Copyright : (c) The University of Glasgow 2004 +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This is the information about an /installed/ package that +-- is communicated to the @ghc-pkg@ program in order to register +-- a package. @ghc-pkg@ now consumes this package format (as of version +-- 6.4). This is specific to GHC at the moment. +-- +-- The @.cabal@ file format is for describing a package that is not yet +-- installed. It has a lot of flexibility, like conditionals and dependency +-- ranges. As such, that format is not at all suitable for describing a package +-- that has already been built and installed. By the time we get to that stage, +-- we have resolved all conditionals and resolved dependency version +-- constraints to exact versions of dependent packages. So, this module defines +-- the 'InstalledPackageInfo' data structure that contains all the info we keep +-- about an installed package. There is a parser and pretty printer. The +-- textual format is rather simpler than the @.cabal@ format: there are no +-- sections, for example. + +-- This module is meant to be local-only to Distribution... + +module Distribution.InstalledPackageInfo ( + InstalledPackageInfo_(..), InstalledPackageInfo, + OriginalModule(..), ExposedModule(..), + ParseResult(..), PError(..), PWarning, + emptyInstalledPackageInfo, + parseInstalledPackageInfo, + showInstalledPackageInfo, + showInstalledPackageInfoField, + showSimpleInstalledPackageInfoField, + fieldsInstalledPackageInfo, + ) 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 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 (Binary) +import Data.Maybe (fromMaybe) +import GHC.Generics (Generic) + +-- ----------------------------------------------------------------------------- +-- The InstalledPackageInfo type + + +data InstalledPackageInfo_ m + = InstalledPackageInfo { + -- these parts are exactly the same as PackageDescription + installedPackageId :: InstalledPackageId, + sourcePackageId :: PackageId, + packageKey :: PackageKey, + license :: License, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + homepage :: String, + pkgUrl :: String, + synopsis :: String, + description :: String, + category :: String, + -- these parts are required by an installed package only: + exposed :: Bool, + exposedModules :: [ExposedModule], + instantiatedWith :: [(m, OriginalModule)], + hiddenModules :: [m], + trusted :: Bool, + importDirs :: [FilePath], + libraryDirs :: [FilePath], + dataDir :: FilePath, + hsLibraries :: [String], + extraLibraries :: [String], + extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi + includeDirs :: [FilePath], + includes :: [String], + depends :: [InstalledPackageId], + ccOptions :: [String], + ldOptions :: [String], + frameworkDirs :: [FilePath], + frameworks :: [String], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath], + pkgRoot :: Maybe FilePath + } + deriving (Generic, Read, Show) + +instance Binary m => Binary (InstalledPackageInfo_ m) + +instance Package.Package (InstalledPackageInfo_ str) where + packageId = sourcePackageId + +instance Package.PackageInstalled (InstalledPackageInfo_ str) where + installedPackageId = installedPackageId + installedDepends = depends + +type InstalledPackageInfo = InstalledPackageInfo_ ModuleName + +emptyInstalledPackageInfo :: InstalledPackageInfo_ m +emptyInstalledPackageInfo + = InstalledPackageInfo { + installedPackageId = InstalledPackageId "", + sourcePackageId = PackageIdentifier (PackageName "") noVersion, + packageKey = OldPackageKey (PackageIdentifier + (PackageName "") noVersion), + license = UnspecifiedLicense, + copyright = "", + maintainer = "", + author = "", + stability = "", + homepage = "", + pkgUrl = "", + synopsis = "", + description = "", + category = "", + exposed = False, + exposedModules = [], + hiddenModules = [], + instantiatedWith = [], + trusted = False, + importDirs = [], + libraryDirs = [], + dataDir = "", + hsLibraries = [], + extraLibraries = [], + extraGHCiLibraries= [], + includeDirs = [], + includes = [], + depends = [], + ccOptions = [], + ldOptions = [], + frameworkDirs = [], + frameworks = [], + haddockInterfaces = [], + haddockHTMLs = [], + pkgRoot = Nothing + } + +noVersion :: Version +noVersion = Version [] [] + +-- ----------------------------------------------------------------------------- +-- Exposed modules + +data OriginalModule + = OriginalModule { + originalPackageId :: InstalledPackageId, + originalModuleName :: ModuleName + } + deriving (Generic, Eq, Read, Show) + +data ExposedModule + = ExposedModule { + exposedName :: ModuleName, + exposedReexport :: Maybe OriginalModule, + exposedSignature :: Maybe OriginalModule -- This field is unused for now. + } + deriving (Generic, Read, Show) + +instance Text OriginalModule where + disp (OriginalModule ipi m) = + disp ipi <> Disp.char ':' <> disp m + parse = do + ipi <- parse + _ <- Parse.char ':' + m <- parse + return (OriginalModule ipi m) + +instance Text ExposedModule where + disp (ExposedModule m reexport signature) = + 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 + Parse.skipSpaces + reexport <- Parse.option Nothing $ do + _ <- 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) + + +instance Binary OriginalModule + +instance Binary ExposedModule + +-- To maintain backwards-compatibility, we accept both comma/non-comma +-- separated variants of this field. You SHOULD use the comma syntax if you +-- use any new functions, although actually it's unambiguous due to a quirk +-- of the fact that modules must start with capital letters. + +showExposedModules :: [ExposedModule] -> Disp.Doc +showExposedModules xs + | all isExposedModule xs = fsep (map disp xs) + | otherwise = fsep (Disp.punctuate comma (map disp xs)) + where isExposedModule (ExposedModule _ Nothing Nothing) = True + isExposedModule _ = False + +parseExposedModules :: Parse.ReadP r [ExposedModule] +parseExposedModules = parseOptCommaList parse + +-- ----------------------------------------------------------------------------- +-- Parsing + +parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo +parseInstalledPackageInfo = + 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 + +showInstalledPackageInfo :: InstalledPackageInfo -> String +showInstalledPackageInfo = showFields fieldsInstalledPackageInfo + +showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) +showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo + +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 + +fieldsInstalledPackageInfo :: [FieldDescr InstalledPackageInfo] +fieldsInstalledPackageInfo = basicFieldDescrs ++ installedFieldDescrs + +basicFieldDescrs :: [FieldDescr InstalledPackageInfo] +basicFieldDescrs = + [ simpleField "name" + disp parsePackageNameQ + packageName (\name pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgName=name}}) + , simpleField "version" + disp parseOptVersion + packageVersion (\ver pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgVersion=ver}}) + , simpleField "id" + disp parse + installedPackageId (\ipid pkg -> pkg{installedPackageId=ipid}) + , simpleField "key" + disp parse + packageKey (\ipid pkg -> pkg{packageKey=ipid}) + , simpleField "license" + disp parseLicenseQ + license (\l pkg -> pkg{license=l}) + , simpleField "copyright" + showFreeText parseFreeText + copyright (\val pkg -> pkg{copyright=val}) + , simpleField "maintainer" + showFreeText parseFreeText + maintainer (\val pkg -> pkg{maintainer=val}) + , simpleField "stability" + showFreeText parseFreeText + stability (\val pkg -> pkg{stability=val}) + , simpleField "homepage" + showFreeText parseFreeText + homepage (\val pkg -> pkg{homepage=val}) + , simpleField "package-url" + showFreeText parseFreeText + pkgUrl (\val pkg -> pkg{pkgUrl=val}) + , simpleField "synopsis" + showFreeText parseFreeText + synopsis (\val pkg -> pkg{synopsis=val}) + , simpleField "description" + showFreeText parseFreeText + description (\val pkg -> pkg{description=val}) + , simpleField "category" + showFreeText parseFreeText + category (\val pkg -> pkg{category=val}) + , simpleField "author" + showFreeText parseFreeText + author (\val pkg -> pkg{author=val}) + ] + +installedFieldDescrs :: [FieldDescr InstalledPackageInfo] +installedFieldDescrs = [ + boolField "exposed" + exposed (\val pkg -> pkg{exposed=val}) + , simpleField "exposed-modules" + showExposedModules parseExposedModules + exposedModules (\xs pkg -> pkg{exposedModules=xs}) + , listField "hidden-modules" + disp parseModuleNameQ + hiddenModules (\xs pkg -> pkg{hiddenModules=xs}) + , listField "instantiated-with" + showInstantiatedWith parseInstantiatedWith + instantiatedWith (\xs pkg -> pkg{instantiatedWith=xs}) + , boolField "trusted" + trusted (\val pkg -> pkg{trusted=val}) + , listField "import-dirs" + showFilePath parseFilePathQ + importDirs (\xs pkg -> pkg{importDirs=xs}) + , listField "library-dirs" + showFilePath parseFilePathQ + libraryDirs (\xs pkg -> pkg{libraryDirs=xs}) + , simpleField "data-dir" + showFilePath (parseFilePathQ Parse.<++ return "") + dataDir (\val pkg -> pkg{dataDir=val}) + , listField "hs-libraries" + showFilePath parseTokenQ + hsLibraries (\xs pkg -> pkg{hsLibraries=xs}) + , listField "extra-libraries" + showToken parseTokenQ + extraLibraries (\xs pkg -> pkg{extraLibraries=xs}) + , listField "extra-ghci-libraries" + showToken parseTokenQ + extraGHCiLibraries (\xs pkg -> pkg{extraGHCiLibraries=xs}) + , listField "include-dirs" + showFilePath parseFilePathQ + includeDirs (\xs pkg -> pkg{includeDirs=xs}) + , listField "includes" + showFilePath parseFilePathQ + includes (\xs pkg -> pkg{includes=xs}) + , listField "depends" + disp parse + depends (\xs pkg -> pkg{depends=xs}) + , listField "cc-options" + showToken parseTokenQ + ccOptions (\path pkg -> pkg{ccOptions=path}) + , listField "ld-options" + showToken parseTokenQ + ldOptions (\path pkg -> pkg{ldOptions=path}) + , listField "framework-dirs" + showFilePath parseFilePathQ + frameworkDirs (\xs pkg -> pkg{frameworkDirs=xs}) + , listField "frameworks" + showToken parseTokenQ + frameworks (\xs pkg -> pkg{frameworks=xs}) + , listField "haddock-interfaces" + showFilePath parseFilePathQ + haddockInterfaces (\xs pkg -> pkg{haddockInterfaces=xs}) + , listField "haddock-html" + showFilePath parseFilePathQ + haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs}) + , simpleField "pkgroot" + (const Disp.empty) parseFilePathQ + (fromMaybe "" . pkgRoot) (\xs pkg -> pkg{pkgRoot=Just xs}) + ] + +deprecatedFieldDescrs :: [FieldDescr InstalledPackageInfo] +deprecatedFieldDescrs = [ + listField "hugs-options" + showToken parseTokenQ + (const []) (const id) + ] diff --git a/Distribution/License.hs b/Distribution/License.hs new file mode 100644 --- /dev/null +++ b/Distribution/License.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.License +-- Description : The License data type. +-- Copyright : Isaac Jones 2003-2005 +-- Duncan Coutts 2008 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Package descriptions contain fields for specifying the name of a software +-- license and the name of the file containing the text of that license. While +-- package authors may choose any license they like, Cabal provides an +-- enumeration of a small set of common free and open source software licenses. +-- This is done so that Hackage can recognise licenses, so that tools can detect +-- , +-- and to deter +-- . +-- +-- It is recommended that all package authors use the @license-file@ or +-- @license-files@ fields in their package descriptions. Further information +-- about these fields can be found in the +-- . +-- +-- = Additional resources +-- +-- The following websites provide information about free and open source +-- software licenses: +-- +-- * +-- +-- * +-- +-- = Disclaimer +-- +-- The descriptions of software licenses provided by this documentation are +-- intended for informational purposes only and in no way constitute legal +-- advice. Please read the text of the licenses and consult a lawyer for any +-- advice regarding software licensing. + +module Distribution.License ( + License(..), + knownLicenses, + ) where + +import Distribution.Version (Version(Version)) + +import Distribution.Text (Text(..), display) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>)) +import Distribution.Compat.Binary (Binary) +import qualified Data.Char as Char (isAlphaNum) +import Data.Data (Data) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) + +-- | Indicates the license under which a package's source code is released. +-- Versions of the licenses not listed here will be rejected by Hackage and +-- cause @cabal check@ to issue a warning. +data License = + -- TODO: * remove BSD4 + + -- | GNU General Public License, + -- or + -- . + GPL (Maybe Version) + + -- | . + | AGPL (Maybe Version) + + -- | GNU Lesser General Public License, + -- or + -- . + | LGPL (Maybe Version) + + -- | . + | BSD2 + + -- | . + | BSD3 + + -- | . + -- This license has not been approved by the OSI and is incompatible with + -- the GNU GPL. It is provided for historical reasons and should be avoided. + | BSD4 + + -- | . + | MIT + + -- | + | ISC + + -- | . + | MPL Version + + -- | . + | Apache (Maybe Version) + + -- | The author of a package disclaims any copyright to its source code and + -- dedicates it to the public domain. This is not a software license. Please + -- note that it is not possible to dedicate works to the public domain in + -- every jurisdiction, nor is a work that is in the public domain in one + -- jurisdiction necessarily in the public domain elsewhere. + | PublicDomain + + -- | Explicitly 'All Rights Reserved', eg for proprietary software. The + -- package may not be legally modified or redistributed by anyone but the + -- rightsholder. + | AllRightsReserved + + -- | No license specified which legally defaults to 'All Rights Reserved'. + -- The package may not be legally modified or redistributed by anyone but + -- the rightsholder. + | UnspecifiedLicense + + -- | Any other software license. + | OtherLicense + + -- | Indicates an erroneous license name. + | UnknownLicense String + deriving (Generic, Read, Show, Eq, Typeable, Data) + +instance Binary License + +-- | The list of all currently recognised licenses. +knownLicenses :: [License] +knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3]) + , LGPL unversioned, LGPL (version [2, 1]), LGPL (version [3]) + , AGPL unversioned, AGPL (version [3]) + , BSD2, BSD3, MIT, ISC + , MPL (Version [2, 0] []) + , Apache unversioned, Apache (version [2, 0]) + , PublicDomain, AllRightsReserved, OtherLicense] + where + unversioned = Nothing + version v = Just (Version v []) + +instance Text License where + disp (GPL version) = Disp.text "GPL" <> dispOptVersion version + disp (LGPL version) = Disp.text "LGPL" <> dispOptVersion version + disp (AGPL version) = Disp.text "AGPL" <> dispOptVersion version + disp (MPL version) = Disp.text "MPL" <> dispVersion version + disp (Apache version) = Disp.text "Apache" <> dispOptVersion version + disp (UnknownLicense other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + name <- Parse.munch1 (\c -> Char.isAlphaNum c && c /= '-') + version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse) + return $! case (name, version :: Maybe Version) of + ("GPL", _ ) -> GPL version + ("LGPL", _ ) -> LGPL version + ("AGPL", _ ) -> AGPL version + ("BSD2", Nothing) -> BSD2 + ("BSD3", Nothing) -> BSD3 + ("BSD4", Nothing) -> BSD4 + ("ISC", Nothing) -> ISC + ("MIT", Nothing) -> MIT + ("MPL", Just version') -> MPL version' + ("Apache", _ ) -> Apache version + ("PublicDomain", Nothing) -> PublicDomain + ("AllRightsReserved", Nothing) -> AllRightsReserved + ("OtherLicense", Nothing) -> OtherLicense + _ -> UnknownLicense $ name ++ + maybe "" (('-':) . display) version + +dispOptVersion :: Maybe Version -> Disp.Doc +dispOptVersion Nothing = Disp.empty +dispOptVersion (Just v) = dispVersion v + +dispVersion :: Version -> Disp.Doc +dispVersion v = Disp.char '-' <> disp v diff --git a/Distribution/Make.hs b/Distribution/Make.hs new file mode 100644 --- /dev/null +++ b/Distribution/Make.hs @@ -0,0 +1,184 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Make +-- Copyright : Martin Sjögren 2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is an alternative build system that delegates everything to the @make@ +-- program. All the commands just end up calling @make@ with appropriate +-- arguments. The intention was to allow preexisting packages that used +-- makefiles to be wrapped into Cabal packages. In practice essentially all +-- such packages were converted over to the \"Simple\" build system instead. +-- Consequently this module is not used much and it certainly only sees cursory +-- maintenance and no testing. Perhaps at some point we should stop pretending +-- that it works. +-- +-- Uses the parsed command-line from "Distribution.Simple.Setup" in order to build +-- Haskell tools using a back-end build system based on make. Obviously we +-- assume that there is a configure script, and that after the ConfigCmd has +-- been run, there is a Makefile. Further assumptions: +-- +-- [ConfigCmd] We assume the configure script accepts +-- @--with-hc@, +-- @--with-hc-pkg@, +-- @--prefix@, +-- @--bindir@, +-- @--libdir@, +-- @--libexecdir@, +-- @--datadir@. +-- +-- [BuildCmd] We assume that the default Makefile target will build everything. +-- +-- [InstallCmd] We assume there is an @install@ target. Note that we assume that +-- this does *not* register the package! +-- +-- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@. +-- The @copy@ target should probably just invoke @make install@ +-- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix) +-- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make +-- install@ directly here is that we don\'t know the value of @$(prefix)@. +-- +-- [SDistCmd] We assume there is a @dist@ target. +-- +-- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@. +-- +-- [UnregisterCmd] We assume there is an @unregister@ target. +-- +-- [HaddockCmd] We assume there is a @docs@ or @doc@ target. + + +-- copy : +-- $(MAKE) install prefix=$(destdir)/$(prefix) \ +-- bindir=$(destdir)/$(bindir) \ + +module Distribution.Make ( + module Distribution.Package, + License(..), Version(..), + defaultMain, defaultMainArgs, defaultMainNoRead + ) where + +-- local +import Distribution.Compat.Exception +import Distribution.Package --must not specify imports, since we're exporting moule. +import Distribution.Simple.Program(defaultProgramConfiguration) +import Distribution.PackageDescription +import Distribution.Simple.Setup +import Distribution.Simple.Command + +import Distribution.Simple.Utils (rawSystemExit, cabalVersion) + +import Distribution.License (License(..)) +import Distribution.Version + ( Version(..) ) +import Distribution.Text + ( display ) + +import System.Environment (getArgs, getProgName) +import Data.List (intercalate) +import System.Exit + +defaultMain :: IO () +defaultMain = getArgs >>= defaultMainArgs + +defaultMainArgs :: [String] -> IO () +defaultMainArgs = defaultMainHelper + +{-# DEPRECATED defaultMainNoRead "it ignores its PackageDescription arg" #-} +defaultMainNoRead :: PackageDescription -> IO () +defaultMainNoRead = const defaultMain + +defaultMainHelper :: [String] -> IO () +defaultMainHelper args = + case commandsRun (globalCommand commands) commands args of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (flags, commandParse) -> + case commandParse of + _ | fromFlag (globalVersion flags) -> printVersion + | fromFlag (globalNumericVersion flags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action + + where + printHelp help = getProgName >>= putStr . help + printOptionsList = putStr . unlines + printErrors errs = do + putStr (intercalate "\n" errs) + exitWith (ExitFailure 1) + printNumericVersion = putStrLn $ display cabalVersion + printVersion = putStrLn $ "Cabal library version " + ++ display cabalVersion + + progs = defaultProgramConfiguration + commands = + [configureCommand progs `commandAddAction` configureAction + ,buildCommand progs `commandAddAction` buildAction + ,installCommand `commandAddAction` installAction + ,copyCommand `commandAddAction` copyAction + ,haddockCommand `commandAddAction` haddockAction + ,cleanCommand `commandAddAction` cleanAction + ,sdistCommand `commandAddAction` sdistAction + ,registerCommand `commandAddAction` registerAction + ,unregisterCommand `commandAddAction` unregisterAction + ] + +configureAction :: ConfigFlags -> [String] -> IO () +configureAction flags args = do + noExtraFlags args + let verbosity = fromFlag (configVerbosity flags) + rawSystemExit verbosity "sh" $ + "configure" + : configureArgs backwardsCompatHack flags + where backwardsCompatHack = True + +copyAction :: CopyFlags -> [String] -> IO () +copyAction flags args = do + noExtraFlags args + let destArgs = case fromFlag $ copyDest flags of + NoCopyDest -> ["install"] + CopyTo path -> ["copy", "destdir=" ++ path] + rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs + +installAction :: InstallFlags -> [String] -> IO () +installAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"] + rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"] + +haddockAction :: HaddockFlags -> [String] -> IO () +haddockAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"] + `catchIO` \_ -> + rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] + +buildAction :: BuildFlags -> [String] -> IO () +buildAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ buildVerbosity flags) "make" [] + +cleanAction :: CleanFlags -> [String] -> IO () +cleanAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"] + +sdistAction :: SDistFlags -> [String] -> IO () +sdistAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"] + +registerAction :: RegisterFlags -> [String] -> IO () +registerAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"] + +unregisterAction :: RegisterFlags -> [String] -> IO () +unregisterAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"] diff --git a/Distribution/ModuleName.hs b/Distribution/ModuleName.hs new file mode 100644 --- /dev/null +++ b/Distribution/ModuleName.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ModuleName +-- Copyright : Duncan Coutts 2008 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Data type for Haskell module names. + +module Distribution.ModuleName ( + ModuleName, + fromString, + components, + toFilePath, + main, + simple, + ) where + +import Distribution.Text + ( Text(..) ) + +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 ) +import GHC.Generics (Generic) +import System.FilePath + ( pathSeparator ) + +-- | A valid Haskell module name. +-- +newtype ModuleName = ModuleName [String] + deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) + +instance Binary ModuleName + +instance Text ModuleName where + disp (ModuleName ms) = + Disp.hcat (intersperse (Disp.char '.') (map Disp.text ms)) + + parse = do + ms <- Parse.sepBy1 component (Parse.char '.') + return (ModuleName ms) + + where + component = do + c <- Parse.satisfy Char.isUpper + cs <- Parse.munch validModuleChar + return (c:cs) + +validModuleChar :: Char -> Bool +validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\'' + +validModuleComponent :: String -> Bool +validModuleComponent [] = False +validModuleComponent (c:cs) = Char.isUpper c + && all validModuleChar cs + +{-# DEPRECATED simple "use ModuleName.fromString instead" #-} +simple :: String -> ModuleName +simple str = ModuleName [str] + +-- | Construct a 'ModuleName' from a valid module name 'String'. +-- +-- This is just a convenience function intended for valid module strings. It is +-- an error if it is used with a string that is not a valid module name. If you +-- are parsing user input then use 'Distribution.Text.simpleParse' instead. +-- +fromString :: String -> ModuleName +fromString string + | all validModuleComponent components' = ModuleName components' + | otherwise = error badName + + where + components' = split string + badName = "ModuleName.fromString: invalid module name " ++ show string + + split cs = case break (=='.') cs of + (chunk,[]) -> chunk : [] + (chunk,_:rest) -> chunk : split rest + +-- | The module name @Main@. +-- +main :: ModuleName +main = ModuleName ["Main"] + +-- | The individual components of a hierarchical module name. For example +-- +-- > components (fromString "A.B.C") = ["A", "B", "C"] +-- +components :: ModuleName -> [String] +components (ModuleName ms) = ms + +-- | Convert a module name to a file path, but without any file extension. +-- For example: +-- +-- > toFilePath (fromString "A.B.C") = "A/B/C" +-- +toFilePath :: ModuleName -> FilePath +toFilePath = intercalate [pathSeparator] . components diff --git a/Distribution/Package.hs b/Distribution/Package.hs new file mode 100644 --- /dev/null +++ b/Distribution/Package.hs @@ -0,0 +1,381 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Package +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Defines a package identifier along with a parser and pretty printer for it. +-- 'PackageIdentifier's consist of a name and an exact version. It also defines +-- a 'Dependency' data type. A dependency is a package name and a version +-- range, like @\"foo >= 1.2 && < 2\"@. + +module Distribution.Package ( + -- * Package ids + PackageName(..), + PackageIdentifier(..), + PackageId, + + -- * Installed package identifiers + InstalledPackageId(..), + + -- * Package keys (used for linker symbols and library name) + PackageKey(..), + mkPackageKey, + packageKeyHash, + packageKeyLibraryName, + + -- * Package source dependencies + Dependency(..), + thisPackageVersion, + notThisPackageVersion, + simplifyDependency, + + -- * Package classes + Package(..), packageName, packageVersion, + PackageFixedDeps(..), + 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 Control.DeepSeq (NFData(..)) +import Data.Ord ( comparing ) +import Distribution.Compat.Binary (Binary) +import qualified Data.Char as Char + ( isDigit, isAlphaNum, isUpper, isLower, ord, chr ) +import Data.Data ( Data ) +import Data.List ( intercalate, foldl', sortBy ) +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 } + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +instance Binary PackageName + +instance Text PackageName where + disp (PackageName n) = Disp.text n + parse = do + ns <- Parse.sepBy1 component (Parse.char '-') + return (PackageName (intercalate "-" ns)) + where + component = do + cs <- Parse.munch1 Char.isAlphaNum + if all Char.isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +instance NFData PackageName where + rnf (PackageName pkg) = rnf pkg + +-- | Type alias so we can use the shorter name PackageId. +type PackageId = PackageIdentifier + +-- | The name and version of a package. +data PackageIdentifier + = PackageIdentifier { + pkgName :: PackageName, -- ^The name of this package, eg. foo + pkgVersion :: Version -- ^the version of this package, eg 1.2 + } + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +instance Binary PackageIdentifier + +instance Text PackageIdentifier where + disp (PackageIdentifier n v) = case v of + Version [] _ -> disp n -- if no version, don't show version. + _ -> disp n <> Disp.char '-' <> disp v + + parse = do + n <- parse + v <- (Parse.char '-' >> parse) <++ return (Version [] []) + return (PackageIdentifier n v) + +instance NFData PackageIdentifier where + rnf (PackageIdentifier name version) = rnf name `seq` rnf version + +-- ------------------------------------------------------------ +-- * Installed Package Ids +-- ------------------------------------------------------------ + +-- | An InstalledPackageId uniquely identifies an instance of an installed +-- package. There can be at most one package with a given 'InstalledPackageId' +-- in a package database, or overlay of databases. +-- +newtype InstalledPackageId = InstalledPackageId String + deriving (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 +-- ------------------------------------------------------------ + +-- | 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. +-- +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 + 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!") + +-- | 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!") + + multiply :: Word64 -> Char -> Word64 + multiply acc c = acc * 62 + (fromIntegral $ value c) + +-- | 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) + +packageKeyHash :: PackageKey -> String +packageKeyHash (PackageKey _ w1 w2) = toBase62 w1 ++ toBase62 w2 +packageKeyHash (OldPackageKey pid) = display pid + +packageKeyLibraryName :: PackageId -> PackageKey -> String +packageKeyLibraryName pid (PackageKey _ w1 w2) = + display pid ++ "-" ++ toBase62 w1 ++ toBase62 w2 +packageKeyLibraryName _ (OldPackageKey pid) = display pid + +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 + + 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) + +instance NFData PackageKey where + rnf (PackageKey prefix _ _) = rnf prefix + rnf (OldPackageKey pid) = rnf pid + +-- ------------------------------------------------------------ +-- * Package source dependencies +-- ------------------------------------------------------------ + +-- | Describes a dependency on a source package (API) +-- +data Dependency = Dependency PackageName VersionRange + deriving (Generic, Read, Show, Eq, Typeable, Data) + +instance Binary Dependency + +instance Text Dependency where + disp (Dependency name ver) = + disp name <+> disp ver + + parse = do name <- parse + Parse.skipSpaces + ver <- parse <++ return anyVersion + Parse.skipSpaces + return (Dependency name ver) + +thisPackageVersion :: PackageIdentifier -> Dependency +thisPackageVersion (PackageIdentifier n v) = + Dependency n (thisVersion v) + +notThisPackageVersion :: PackageIdentifier -> Dependency +notThisPackageVersion (PackageIdentifier n v) = + Dependency n (notThisVersion v) + +-- | Simplify the 'VersionRange' expression in a 'Dependency'. +-- See 'simplifyVersionRange'. +-- +simplifyDependency :: Dependency -> Dependency +simplifyDependency (Dependency name range) = + Dependency name (simplifyVersionRange range) + +-- | Class of things that have a 'PackageIdentifier' +-- +-- Types in this class are all notions of a package. This allows us to have +-- different types for the different phases that packages go though, from +-- simple name\/id, package description, configured or installed packages. +-- +-- Not all kinds of packages can be uniquely identified by a +-- 'PackageIdentifier'. In particular, installed packages cannot, there may be +-- many installed instances of the same source package. +-- +class Package pkg where + packageId :: pkg -> PackageIdentifier + +packageName :: Package pkg => pkg -> PackageName +packageName = pkgName . packageId + +packageVersion :: Package pkg => pkg -> Version +packageVersion = pkgVersion . packageId + +instance Package PackageIdentifier where + packageId = id + +-- | Subclass of packages that have specific versioned dependencies. +-- +-- So for example a not-yet-configured package has dependencies on version +-- ranges, not specific versions. A configured or an already installed package +-- depends on exact versions. Some operations or data structures (like +-- dependency graphs) only make sense on this subclass of package types. +-- +class Package pkg => PackageFixedDeps pkg where + depends :: pkg -> [PackageIdentifier] + +-- | 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] diff --git a/Distribution/PackageDescription.hs b/Distribution/PackageDescription.hs new file mode 100644 --- /dev/null +++ b/Distribution/PackageDescription.hs @@ -0,0 +1,1154 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines the data structure for the @.cabal@ file format. There are +-- several parts to this structure. It has top level info and then 'Library', +-- 'Executable', 'TestSuite', and 'Benchmark' sections each of which have +-- associated 'BuildInfo' data that's used to build the library, exe, test, or +-- benchmark. To further complicate things there is both a 'PackageDescription' +-- and a 'GenericPackageDescription'. This distinction relates to cabal +-- configurations. When we initially read a @.cabal@ file we get a +-- 'GenericPackageDescription' which has all the conditional sections. +-- Before actually building a package we have to decide +-- on each conditional. Once we've done that we get a 'PackageDescription'. +-- It was done this way initially to avoid breaking too much stuff when the +-- feature was introduced. It could probably do with being rationalised at some +-- point to make it simpler. + +module Distribution.PackageDescription ( + -- * Package descriptions + PackageDescription(..), + emptyPackageDescription, + specVersion, + descCabalVersion, + BuildType(..), + knownBuildTypes, + + -- ** Renaming + ModuleRenaming(..), + defaultRenaming, + lookupRenaming, + + -- ** Libraries + Library(..), + ModuleReexport(..), + emptyLibrary, + withLib, + hasLibs, + libModules, + + -- ** Executables + Executable(..), + emptyExecutable, + withExe, + hasExes, + exeModules, + + -- * Tests + TestSuite(..), + TestSuiteInterface(..), + TestType(..), + testType, + knownTestTypes, + emptyTestSuite, + hasTests, + withTest, + testModules, + enabledTests, + + -- * Benchmarks + Benchmark(..), + BenchmarkInterface(..), + BenchmarkType(..), + benchmarkType, + knownBenchmarkTypes, + emptyBenchmark, + hasBenchmarks, + withBenchmark, + benchmarkModules, + enabledBenchmarks, + + -- * Build information + BuildInfo(..), + emptyBuildInfo, + allBuildInfo, + allLanguages, + allExtensions, + usedExtensions, + hcOptions, + hcProfOptions, + hcSharedOptions, + + -- ** Supplementary build information + HookedBuildInfo, + emptyHookedBuildInfo, + updatePackageDescription, + + -- * package configuration + GenericPackageDescription(..), + Flag(..), FlagName(..), FlagAssignment, + CondTree(..), ConfVar(..), Condition(..), + + -- * Source repositories + SourceRepo(..), + RepoKind(..), + RepoType(..), + knownRepoTypes, + ) 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 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.Package + ( PackageName(PackageName), PackageIdentifier(PackageIdentifier) + , Dependency, Package(..), PackageName, packageName ) +import Distribution.ModuleName ( 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.Text + ( Text(..), display ) +import Language.Haskell.Extension + ( Language, Extension ) + +-- ----------------------------------------------------------------------------- +-- The PackageDescription type + +-- | This data type is the internal representation of the file @pkg.cabal@. +-- It contains two kinds of information about the package: information +-- which is needed for all packages, such as the package name and version, and +-- information which is needed for the simple build system only, such as +-- the compiler options and library name. +-- +data PackageDescription + = PackageDescription { + -- the following are required by all packages: + package :: PackageIdentifier, + license :: License, + licenseFiles :: [FilePath], + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + testedWith :: [(CompilerFlavor,VersionRange)], + homepage :: String, + pkgUrl :: String, + bugReports :: String, + sourceRepos :: [SourceRepo], + synopsis :: String, -- ^A one-line summary of this package + description :: String, -- ^A more verbose description of this package + category :: String, + customFieldsPD :: [(String,String)], -- ^Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + -- | 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 + -- either nonsense, or the collected dependencies of *all* the + -- components in this package. buildDepends is initialized by + -- 'finalizePackageDescription' and 'flattenPackageDescription'; + -- prior to that, dependency info is stored in the 'CondTree' + -- built around a 'GenericPackageDescription'. When this + -- resolution is done, dependency info is written to the inner + -- 'BuildInfo' and this field. This is all horrible, and #2066 + -- tracks progress to get rid of this field. + buildDepends :: [Dependency], + -- | The version of the Cabal spec that this package description uses. + -- For historical reasons this is specified with a version range but + -- only ranges of the form @>= v@ make sense. We are in the process of + -- transitioning to specifying just a single version, not a range. + specVersionRaw :: Either Version VersionRange, + buildType :: Maybe BuildType, + -- components + library :: Maybe Library, + executables :: [Executable], + testSuites :: [TestSuite], + benchmarks :: [Benchmark], + dataFiles :: [FilePath], + dataDir :: FilePath, + extraSrcFiles :: [FilePath], + extraTmpFiles :: [FilePath], + extraDocFiles :: [FilePath] + } + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary PackageDescription + +instance Package PackageDescription where + packageId = package + +-- | The version of the Cabal spec that this package should be interpreted +-- against. +-- +-- Historically we used a version range but we are switching to using a single +-- version. Currently we accept either. This function converts into a single +-- version by ignoring upper bounds in the version range. +-- +specVersion :: PackageDescription -> Version +specVersion pkg = case specVersionRaw pkg of + Left version -> version + Right versionRange -> case asVersionIntervals versionRange of + [] -> Version [0] [] + ((LowerBound version _, _):_) -> version + +-- | The range of versions of the Cabal tools that this package is intended to +-- work with. +-- +-- This function is deprecated and should not be used for new purposes, only to +-- support old packages that rely on the old interpretation. +-- +descCabalVersion :: PackageDescription -> VersionRange +descCabalVersion pkg = case specVersionRaw pkg of + Left version -> orLaterVersion version + Right versionRange -> versionRange +{-# DEPRECATED descCabalVersion "Use specVersion instead" #-} + +emptyPackageDescription :: PackageDescription +emptyPackageDescription + = PackageDescription { + package = PackageIdentifier (PackageName "") + (Version [] []), + license = UnspecifiedLicense, + licenseFiles = [], + specVersionRaw = Right anyVersion, + buildType = Nothing, + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + buildDepends = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = "", + description = "", + category = "", + customFieldsPD = [], + library = Nothing, + executables = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = "", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = [] + } + +-- | The type of build system used by this package. +data BuildType + = Simple -- ^ calls @Distribution.Simple.defaultMain@ + | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, + -- which invokes @configure@ to generate additional build + -- information used by later phases. + | Make -- ^ calls @Distribution.Make.defaultMain@ + | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) + | UnknownBuildType String + -- ^ a package that uses an unknown build type cannot actually + -- be built. Doing it this way rather than just giving a + -- parse error means we get better error messages and allows + -- you to inspect the rest of the package description. + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary BuildType + +knownBuildTypes :: [BuildType] +knownBuildTypes = [Simple, Configure, Make, Custom] + +instance Text BuildType where + disp (UnknownBuildType other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + name <- Parse.munch1 Char.isAlphaNum + return $ case name of + "Simple" -> Simple + "Configure" -> Configure + "Custom" -> Custom + "Make" -> Make + _ -> UnknownBuildType name + +-- --------------------------------------------------------------------------- +-- Module renaming + +-- | Renaming applied to the modules provided by a package. +-- The boolean indicates whether or not to also include all of the +-- original names of modules. Thus, @ModuleRenaming False []@ is +-- "don't expose any modules, and @ModuleRenaming True [("Data.Bool", "Bool")]@ +-- is, "expose all modules, but also expose @Data.Bool@ as @Bool@". +-- +data ModuleRenaming = ModuleRenaming Bool [(ModuleName, ModuleName)] + deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) + +defaultRenaming :: ModuleRenaming +defaultRenaming = ModuleRenaming True [] + +lookupRenaming :: Package pkg => pkg -> Map PackageName ModuleRenaming -> ModuleRenaming +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 [] + +-- NB: parentheses are mandatory, because later we may extend this syntax +-- to allow "hiding (A, B)" or other modifier words. +instance Text ModuleRenaming where + disp (ModuleRenaming True []) = Disp.empty + disp (ModuleRenaming b vs) = (if b then text "with" else Disp.empty) <+> dispRns + where dispRns = Disp.parens + (Disp.hsep + (Disp.punctuate Disp.comma (map dispEntry vs))) + dispEntry (orig, new) + | orig == new = disp orig + | otherwise = disp orig <+> text "as" <+> disp new + + parse = do Parse.string "with" >> Parse.skipSpaces + fmap (ModuleRenaming True) parseRns + <++ fmap (ModuleRenaming False) parseRns + <++ return (ModuleRenaming True []) + where parseRns = do + rns <- Parse.between (Parse.char '(') (Parse.char ')') parseList + Parse.skipSpaces + return rns + parseList = + Parse.sepBy parseEntry (Parse.char ',' >> Parse.skipSpaces) + parseEntry :: Parse.ReadP r (ModuleName, ModuleName) + parseEntry = do + orig <- parse + Parse.skipSpaces + (do _ <- Parse.string "as" + Parse.skipSpaces + new <- parse + Parse.skipSpaces + return (orig, new) + <++ + return (orig, orig)) + +-- --------------------------------------------------------------------------- +-- The Library type + +data Library = Library { + exposedModules :: [ModuleName], + reexportedModules :: [ModuleReexport], + requiredSignatures:: [ModuleName], -- ^ What sigs need implementations? + exposedSignatures:: [ModuleName], -- ^ What sigs are visible to users? + libExposed :: Bool, -- ^ Is the lib to be exposed by default? + libBuildInfo :: BuildInfo + } + deriving (Generic, Show, Eq, Read, Typeable, Data) + +instance Binary Library + +instance Monoid Library where + mempty = Library { + exposedModules = mempty, + reexportedModules = mempty, + requiredSignatures = mempty, + exposedSignatures = mempty, + libExposed = True, + libBuildInfo = mempty + } + mappend a b = Library { + exposedModules = combine exposedModules, + reexportedModules = combine reexportedModules, + requiredSignatures = combine requiredSignatures, + exposedSignatures = combine exposedSignatures, + libExposed = libExposed a && libExposed b, -- so False propagates + libBuildInfo = combine libBuildInfo + } + where combine field = field a `mappend` field b + +emptyLibrary :: Library +emptyLibrary = mempty + +-- |does this package have any libraries? +hasLibs :: PackageDescription -> Bool +hasLibs p = maybe False (buildable . libBuildInfo) (library p) + +-- |'Maybe' version of 'hasLibs' +maybeHasLibs :: PackageDescription -> Maybe Library +maybeHasLibs p = + library p >>= \lib -> if buildable (libBuildInfo lib) + then Just lib + else Nothing + +-- |If the package description has a library section, call the given +-- function with the library build info as argument. +withLib :: PackageDescription -> (Library -> IO ()) -> IO () +withLib pkg_descr f = + maybe (return ()) f (maybeHasLibs pkg_descr) + +-- | Get all the module names from the library (exposed and internal modules) +-- which need to be compiled. (This does not include reexports, which +-- do not need to be compiled.) +libModules :: Library -> [ModuleName] +libModules lib = exposedModules lib + ++ otherModules (libBuildInfo lib) + ++ exposedSignatures lib + ++ requiredSignatures lib + +-- ----------------------------------------------------------------------------- +-- Module re-exports + +data ModuleReexport = ModuleReexport { + moduleReexportOriginalPackage :: Maybe PackageName, + moduleReexportOriginalName :: ModuleName, + moduleReexportName :: ModuleName + } + deriving (Eq, Generic, Read, Show, Typeable, Data) + +instance Binary ModuleReexport + +instance Text ModuleReexport where + disp (ModuleReexport mpkgname origname newname) = + maybe Disp.empty (\pkgname -> disp pkgname <> Disp.char ':') mpkgname + <> disp origname + <+> if newname == origname + then Disp.empty + else Disp.text "as" <+> disp newname + + parse = do + mpkgname <- Parse.option Nothing $ do + pkgname <- parse + _ <- Parse.char ':' + return (Just pkgname) + origname <- parse + newname <- Parse.option origname $ do + Parse.skipSpaces + _ <- Parse.string "as" + Parse.skipSpaces + parse + return (ModuleReexport mpkgname origname newname) + +-- --------------------------------------------------------------------------- +-- The Executable type + +data Executable = Executable { + exeName :: String, + modulePath :: FilePath, + buildInfo :: BuildInfo + } + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary Executable + +instance Monoid Executable where + mempty = Executable { + exeName = mempty, + modulePath = mempty, + buildInfo = mempty + } + mappend a b = Executable{ + exeName = combine' exeName, + modulePath = combine modulePath, + buildInfo = combine buildInfo + } + where combine field = field a `mappend` field b + combine' field = case (field a, field b) of + ("","") -> "" + ("", x) -> x + (x, "") -> x + (x, y) -> error $ "Ambiguous values for executable field: '" + ++ x ++ "' and '" ++ y ++ "'" + +emptyExecutable :: Executable +emptyExecutable = mempty + +-- |does this package have any executables? +hasExes :: PackageDescription -> Bool +hasExes p = any (buildable . buildInfo) (executables p) + +-- | Perform the action on each buildable 'Executable' in the package +-- description. +withExe :: PackageDescription -> (Executable -> IO ()) -> IO () +withExe pkg_descr f = + sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)] + +-- | Get all the module names from an exe +exeModules :: Executable -> [ModuleName] +exeModules exe = otherModules (buildInfo exe) + +-- --------------------------------------------------------------------------- +-- The TestSuite type + +-- | A \"test-suite\" stanza in a cabal file. +-- +data TestSuite = TestSuite { + testName :: String, + testInterface :: TestSuiteInterface, + testBuildInfo :: BuildInfo, + testEnabled :: Bool + -- TODO: By having a 'testEnabled' field in the PackageDescription, we + -- are mixing build status information (i.e., arguments to 'configure') + -- with static package description information. This is undesirable, but + -- a better solution is waiting on the next overhaul to the + -- GenericPackageDescription -> PackageDescription resolution process. + } + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary TestSuite + +-- | The test suite interfaces that are currently defined. Each test suite must +-- specify which interface it supports. +-- +-- More interfaces may be defined in future, either new revisions or totally +-- new interfaces. +-- +data TestSuiteInterface = + + -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form + -- of an executable. It returns a zero exit code for success, non-zero for + -- failure. The stdout and stderr channels may be logged. It takes no + -- command line parameters and nothing on stdin. + -- + TestSuiteExeV10 Version FilePath + + -- | Test interface \"detailed-0.9\". The test-suite takes the form of a + -- library containing a designated module that exports \"tests :: [Test]\". + -- + | TestSuiteLibV09 Version ModuleName + + -- | A test suite that does not conform to one of the above interfaces for + -- the given reason (e.g. unknown test type). + -- + | TestSuiteUnsupported TestType + deriving (Eq, Generic, Read, Show, Typeable, Data) + +instance Binary TestSuiteInterface + +instance Monoid TestSuite where + mempty = TestSuite { + testName = mempty, + testInterface = mempty, + testBuildInfo = mempty, + testEnabled = False + } + + mappend a b = TestSuite { + testName = combine' testName, + testInterface = combine testInterface, + testBuildInfo = combine testBuildInfo, + testEnabled = testEnabled a || testEnabled b + } + where combine field = field a `mappend` field b + combine' f = case (f a, f b) of + ("", x) -> x + (x, "") -> x + (x, y) -> error "Ambiguous values for test field: '" + ++ x ++ "' and '" ++ y ++ "'" + +instance Monoid TestSuiteInterface where + mempty = TestSuiteUnsupported (TestTypeUnknown mempty (Version [] [])) + mappend a (TestSuiteUnsupported _) = a + mappend _ b = b + +emptyTestSuite :: TestSuite +emptyTestSuite = mempty + +-- | Does this package have any test suites? +hasTests :: PackageDescription -> Bool +hasTests = any (buildable . testBuildInfo) . testSuites + +-- | Get all the enabled test suites from a package. +enabledTests :: PackageDescription -> [TestSuite] +enabledTests = filter testEnabled . testSuites + +-- | Perform an action on each buildable 'TestSuite' in a package. +withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO () +withTest pkg_descr f = + mapM_ f $ filter (buildable . testBuildInfo) $ enabledTests pkg_descr + +-- | Get all the module names from a test suite. +testModules :: TestSuite -> [ModuleName] +testModules test = (case testInterface test of + TestSuiteLibV09 _ m -> [m] + _ -> []) + ++ otherModules (testBuildInfo test) + +-- | The \"test-type\" field in the test suite stanza. +-- +data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\" + | TestTypeLib Version -- ^ \"type: detailed-x.y\" + | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\" + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary TestType + +knownTestTypes :: [TestType] +knownTestTypes = [ TestTypeExe (Version [1,0] []) + , TestTypeLib (Version [0,9] []) ] + +stdParse :: Text ver => (ver -> String -> res) -> Parse.ReadP r res +stdParse f = do + cs <- Parse.sepBy1 component (Parse.char '-') + _ <- Parse.char '-' + ver <- parse + let name = intercalate "-" cs + return $! f ver (lowercase name) + where + component = do + cs <- Parse.munch1 Char.isAlphaNum + if all Char.isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +instance Text TestType where + disp (TestTypeExe ver) = text "exitcode-stdio-" <> disp ver + disp (TestTypeLib ver) = text "detailed-" <> disp ver + disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver + + parse = stdParse $ \ver name -> case name of + "exitcode-stdio" -> TestTypeExe ver + "detailed" -> TestTypeLib ver + _ -> TestTypeUnknown name ver + + +testType :: TestSuite -> TestType +testType test = case testInterface test of + TestSuiteExeV10 ver _ -> TestTypeExe ver + TestSuiteLibV09 ver _ -> TestTypeLib ver + TestSuiteUnsupported testtype -> testtype + +-- --------------------------------------------------------------------------- +-- The Benchmark type + +-- | A \"benchmark\" stanza in a cabal file. +-- +data Benchmark = Benchmark { + benchmarkName :: String, + benchmarkInterface :: BenchmarkInterface, + benchmarkBuildInfo :: BuildInfo, + benchmarkEnabled :: Bool + -- TODO: See TODO for 'testEnabled'. + } + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary Benchmark + +-- | The benchmark interfaces that are currently defined. Each +-- benchmark must specify which interface it supports. +-- +-- More interfaces may be defined in future, either new revisions or +-- totally new interfaces. +-- +data BenchmarkInterface = + + -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark + -- takes the form of an executable. It returns a zero exit code + -- for success, non-zero for failure. The stdout and stderr + -- channels may be logged. It takes no command line parameters + -- and nothing on stdin. + -- + BenchmarkExeV10 Version FilePath + + -- | A benchmark that does not conform to one of the above + -- interfaces for the given reason (e.g. unknown benchmark type). + -- + | BenchmarkUnsupported BenchmarkType + deriving (Eq, Generic, Read, Show, Typeable, Data) + +instance Binary BenchmarkInterface + +instance Monoid Benchmark where + mempty = Benchmark { + benchmarkName = mempty, + benchmarkInterface = mempty, + benchmarkBuildInfo = mempty, + benchmarkEnabled = False + } + + mappend a b = Benchmark { + benchmarkName = combine' benchmarkName, + benchmarkInterface = combine benchmarkInterface, + benchmarkBuildInfo = combine benchmarkBuildInfo, + benchmarkEnabled = benchmarkEnabled a || benchmarkEnabled b + } + where combine field = field a `mappend` field b + combine' f = case (f a, f b) of + ("", x) -> x + (x, "") -> x + (x, y) -> error "Ambiguous values for benchmark field: '" + ++ x ++ "' and '" ++ y ++ "'" + +instance Monoid BenchmarkInterface where + mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty (Version [] [])) + mappend a (BenchmarkUnsupported _) = a + mappend _ b = b + +emptyBenchmark :: Benchmark +emptyBenchmark = mempty + +-- | Does this package have any benchmarks? +hasBenchmarks :: PackageDescription -> Bool +hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks + +-- | Get all the enabled benchmarks from a package. +enabledBenchmarks :: PackageDescription -> [Benchmark] +enabledBenchmarks = filter benchmarkEnabled . benchmarks + +-- | Perform an action on each buildable 'Benchmark' in a package. +withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO () +withBenchmark pkg_descr f = + mapM_ f $ filter (buildable . benchmarkBuildInfo) $ enabledBenchmarks pkg_descr + +-- | Get all the module names from a benchmark. +benchmarkModules :: Benchmark -> [ModuleName] +benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark) + +-- | The \"benchmark-type\" field in the benchmark stanza. +-- +data BenchmarkType = BenchmarkTypeExe Version + -- ^ \"type: exitcode-stdio-x.y\" + | BenchmarkTypeUnknown String Version + -- ^ Some unknown benchmark type e.g. \"type: foo\" + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary BenchmarkType + +knownBenchmarkTypes :: [BenchmarkType] +knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ] + +instance Text BenchmarkType where + disp (BenchmarkTypeExe ver) = text "exitcode-stdio-" <> disp ver + disp (BenchmarkTypeUnknown name ver) = text name <> char '-' <> disp ver + + parse = stdParse $ \ver name -> case name of + "exitcode-stdio" -> BenchmarkTypeExe ver + _ -> BenchmarkTypeUnknown name ver + + +benchmarkType :: Benchmark -> BenchmarkType +benchmarkType benchmark = case benchmarkInterface benchmark of + BenchmarkExeV10 ver _ -> BenchmarkTypeExe ver + BenchmarkUnsupported benchmarktype -> benchmarktype + +-- --------------------------------------------------------------------------- +-- The BuildInfo type + +-- Consider refactoring into executable and library versions. +data BuildInfo = BuildInfo { + buildable :: Bool, -- ^ component is buildable here + buildTools :: [Dependency], -- ^ tools needed to build this bit + cppOptions :: [String], -- ^ options for pre-processing Haskell code + ccOptions :: [String], -- ^ options for C compiler + ldOptions :: [String], -- ^ options for linker + pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used + frameworks :: [String], -- ^support frameworks for Mac OS X + cSources :: [FilePath], + jsSources :: [FilePath], + hsSourceDirs :: [FilePath], -- ^ where to look for the Haskell module hierarchy + otherModules :: [ModuleName], -- ^ non-exposed or non-main modules + + defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified + otherLanguages :: [Language], -- ^ other languages used within the package + defaultExtensions :: [Extension], -- ^ language extensions used by all modules + otherExtensions :: [Extension], -- ^ other language extensions used within the package + oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions' + + extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package + extraGHCiLibs :: [String], -- ^ if present, overrides extraLibs when package is loaded with GHCi. + extraLibDirs :: [String], + includeDirs :: [FilePath], -- ^directories to find .h files + includes :: [FilePath], -- ^ The .h files to be found in includeDirs + installIncludes :: [FilePath], -- ^ .h files to install with the package + options :: [(CompilerFlavor,[String])], + profOptions :: [(CompilerFlavor,[String])], + sharedOptions :: [(CompilerFlavor,[String])], + customFieldsBI :: [(String,String)], -- ^Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + targetBuildDepends :: [Dependency], -- ^ Dependencies specific to a library or executable target + targetBuildRenaming :: Map PackageName ModuleRenaming + } + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary BuildInfo + +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 = [], + 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, + targetBuildRenaming = combineMap targetBuildRenaming + } + where + combine field = field a `mappend` field b + combineNub field = nub (combine field) + combineMby field = field b `mplus` field a + combineMap field = Map.unionWith mappend (field a) (field b) + +emptyBuildInfo :: BuildInfo +emptyBuildInfo = mempty + +-- | The 'BuildInfo' for the library (if there is one and it's buildable), and +-- all buildable executables, test suites and benchmarks. Useful for gathering +-- dependencies. +allBuildInfo :: PackageDescription -> [BuildInfo] +allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr] + , let bi = libBuildInfo lib + , buildable bi ] + ++ [ bi | exe <- executables pkg_descr + , let bi = buildInfo exe + , buildable bi ] + ++ [ bi | tst <- testSuites pkg_descr + , let bi = testBuildInfo tst + , buildable bi + , testEnabled tst ] + ++ [ bi | tst <- benchmarks pkg_descr + , let bi = benchmarkBuildInfo tst + , buildable bi + , benchmarkEnabled tst ] + --FIXME: many of the places where this is used, we actually want to look at + -- unbuildable bits too, probably need separate functions + +-- | The 'Language's used by this component +-- +allLanguages :: BuildInfo -> [Language] +allLanguages bi = maybeToList (defaultLanguage bi) + ++ otherLanguages bi + +-- | The 'Extension's that are used somewhere by this component +-- +allExtensions :: BuildInfo -> [Extension] +allExtensions bi = usedExtensions bi + ++ otherExtensions bi + +-- | The 'Extensions' that are used by all modules in this component +-- +usedExtensions :: BuildInfo -> [Extension] +usedExtensions bi = oldExtensions bi + ++ defaultExtensions bi + +type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)]) + +emptyHookedBuildInfo :: HookedBuildInfo +emptyHookedBuildInfo = (Nothing, []) + +-- |Select options for a particular Haskell compiler. +hcOptions :: CompilerFlavor -> BuildInfo -> [String] +hcOptions = lookupHcOptions options + +hcProfOptions :: CompilerFlavor -> BuildInfo -> [String] +hcProfOptions = lookupHcOptions profOptions + +hcSharedOptions :: CompilerFlavor -> BuildInfo -> [String] +hcSharedOptions = lookupHcOptions sharedOptions + +lookupHcOptions :: (BuildInfo -> [(CompilerFlavor,[String])]) + -> CompilerFlavor -> BuildInfo -> [String] +lookupHcOptions f hc bi = [ opt | (hc',opts) <- f bi + , hc' == hc + , opt <- opts ] + +-- ------------------------------------------------------------ +-- * Source repos +-- ------------------------------------------------------------ + +-- | Information about the source revision control system for a package. +-- +-- When specifying a repo it is useful to know the meaning or intention of the +-- information as doing so enables automation. There are two obvious common +-- purposes: one is to find the repo for the latest development version, the +-- other is to find the repo for this specific release. The 'ReopKind' +-- specifies which one we mean (or another custom one). +-- +-- A package can specify one or the other kind or both. Most will specify just +-- a head repo but some may want to specify a repo to reconstruct the sources +-- for this package release. +-- +-- The required information is the 'RepoType' which tells us if it's using +-- 'Darcs', 'Git' for example. The 'repoLocation' and other details are +-- interpreted according to the repo type. +-- +data SourceRepo = SourceRepo { + -- | The kind of repo. This field is required. + repoKind :: RepoKind, + + -- | The type of the source repository system for this repo, eg 'Darcs' or + -- 'Git'. This field is required. + repoType :: Maybe RepoType, + + -- | The location of the repository. For most 'RepoType's this is a URL. + -- This field is required. + repoLocation :: Maybe String, + + -- | 'CVS' can put multiple \"modules\" on one server and requires a + -- module name in addition to the location to identify a particular repo. + -- Logically this is part of the location but unfortunately has to be + -- specified separately. This field is required for the 'CVS' 'RepoType' and + -- should not be given otherwise. + repoModule :: Maybe String, + + -- | The name or identifier of the branch, if any. Many source control + -- systems have the notion of multiple branches in a repo that exist in the + -- same location. For example 'Git' and 'CVS' use this while systems like + -- 'Darcs' use different locations for different branches. This field is + -- optional but should be used if necessary to identify the sources, + -- especially for the 'RepoThis' repo kind. + repoBranch :: Maybe String, + + -- | The tag identify a particular state of the repository. This should be + -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind. + -- + repoTag :: Maybe String, + + -- | Some repositories contain multiple projects in different subdirectories + -- This field specifies the subdirectory where this packages sources can be + -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted + -- relative to the root of the repository. This field is optional. If not + -- given the default is \".\" ie no subdirectory. + repoSubdir :: Maybe FilePath +} + deriving (Eq, Generic, Read, Show, Typeable, Data) + +instance Binary SourceRepo + +-- | What this repo info is for, what it represents. +-- +data RepoKind = + -- | The repository for the \"head\" or development version of the project. + -- This repo is where we should track the latest development activity or + -- the usual repo people should get to contribute patches. + RepoHead + + -- | The repository containing the sources for this exact package version + -- or release. For this kind of repo a tag should be given to give enough + -- information to re-create the exact sources. + | RepoThis + + | RepoKindUnknown String + deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) + +instance Binary RepoKind + +-- | An enumeration of common source control systems. The fields used in the +-- 'SourceRepo' depend on the type of repo. The tools and methods used to +-- obtain and track the repo depend on the repo type. +-- +data RepoType = Darcs | Git | SVN | CVS + | Mercurial | GnuArch | Bazaar | Monotone + | OtherRepoType String + deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) + +instance Binary RepoType + +knownRepoTypes :: [RepoType] +knownRepoTypes = [Darcs, Git, SVN, CVS + ,Mercurial, GnuArch, Bazaar, Monotone] + +repoTypeAliases :: RepoType -> [String] +repoTypeAliases Bazaar = ["bzr"] +repoTypeAliases Mercurial = ["hg"] +repoTypeAliases GnuArch = ["arch"] +repoTypeAliases _ = [] + +instance Text RepoKind where + disp RepoHead = Disp.text "head" + disp RepoThis = Disp.text "this" + disp (RepoKindUnknown other) = Disp.text other + + parse = do + name <- ident + return $ case lowercase name of + "head" -> RepoHead + "this" -> RepoThis + _ -> RepoKindUnknown name + +instance Text RepoType where + disp (OtherRepoType other) = Disp.text other + disp other = Disp.text (lowercase (show other)) + parse = fmap classifyRepoType ident + +classifyRepoType :: String -> RepoType +classifyRepoType s = + fromMaybe (OtherRepoType s) $ lookup (lowercase s) repoTypeMap + where + repoTypeMap = [ (name, repoType') + | repoType' <- knownRepoTypes + , name <- display repoType' : repoTypeAliases repoType' ] + +ident :: Parse.ReadP r String +ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') + +lowercase :: String -> String +lowercase = map Char.toLower + +-- ------------------------------------------------------------ +-- * Utils +-- ------------------------------------------------------------ + +updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription +updatePackageDescription (mb_lib_bi, exe_bi) p + = p{ executables = updateExecutables exe_bi (executables p) + , library = updateLibrary mb_lib_bi (library p) + } + where + updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library + updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib}) + updateLibrary Nothing mb_lib = mb_lib + updateLibrary (Just _) Nothing = Nothing + + updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)] + -> [Executable] -- ^list of executables to update + -> [Executable] -- ^list with exeNames updated + updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' + + updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo) + -> [Executable] -- ^list of executables to update + -> [Executable] -- ^list with exeName updated + updateExecutable _ [] = [] + updateExecutable exe_bi'@(name,bi) (exe:exes) + | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes + | otherwise = exe : updateExecutable exe_bi' exes + +-- --------------------------------------------------------------------------- +-- The GenericPackageDescription type + +data GenericPackageDescription = + GenericPackageDescription { + packageDescription :: PackageDescription, + genPackageFlags :: [Flag], + condLibrary :: Maybe (CondTree ConfVar [Dependency] Library), + condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)], + condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)], + condBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] + } + deriving (Show, Eq, Typeable, Data) + +instance Package GenericPackageDescription where + packageId = packageId . packageDescription + +--TODO: make PackageDescription an instance of Text. + +-- | A flag can represent a feature to be included, or a way of linking +-- a target against its dependencies, or in fact whatever you can think of. +data Flag = MkFlag + { flagName :: FlagName + , flagDescription :: String + , flagDefault :: Bool + , flagManual :: Bool + } + deriving (Show, Eq, Typeable, Data) + +-- | A 'FlagName' is the name of a user-defined configuration flag +newtype FlagName = FlagName String + deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) + +instance Binary FlagName + +-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to +-- 'Bool' flag values. It represents the flags chosen by the user or +-- discovered during configuration. For example @--flags=foo --flags=-bar@ +-- becomes @[("foo", True), ("bar", False)]@ +-- +type FlagAssignment = [(FlagName, Bool)] + +-- | A @ConfVar@ represents the variable type used. +data ConfVar = OS OS + | Arch Arch + | Flag FlagName + | Impl CompilerFlavor VersionRange + deriving (Eq, Show, Typeable, Data) + +-- | 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) + +data CondTree v c a = CondNode + { condTreeData :: a + , condTreeConstraints :: c + , condTreeComponents :: [( Condition v + , CondTree v c a + , Maybe (CondTree v c a))] + } + deriving (Show, Eq, Typeable, Data) diff --git a/Distribution/PackageDescription/Check.hs b/Distribution/PackageDescription/Check.hs new file mode 100644 --- /dev/null +++ b/Distribution/PackageDescription/Check.hs @@ -0,0 +1,1589 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Check +-- Copyright : Lennart Kolmodin 2008 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This has code for checking for various problems in packages. There is one +-- set of checks that just looks at a 'PackageDescription' in isolation and +-- another set of checks that also looks at files in the package. Some of the +-- checks are basic sanity checks, others are portability standards that we'd +-- like to encourage. There is a 'PackageCheck' type that distinguishes the +-- different kinds of check so we can see which ones are appropriate to report +-- in different situations. This code gets uses when configuring a package when +-- we consider only basic problems. The higher standard is uses when when +-- preparing a source tarball and by Hackage when uploading new packages. The +-- reason for this is that we want to hold packages that are expected to be +-- distributed to a higher standard than packages that are only ever expected +-- to be used on the author's own environment. + +module Distribution.PackageDescription.Check ( + -- * Package Checking + PackageCheck(..), + checkPackage, + checkConfiguredPackage, + + -- ** Checking package contents + checkPackageFiles, + checkPackageContent, + CheckPackageContentOps(..), + checkPackageFileNames, + ) where + +import Data.Maybe + ( isNothing, isJust, catMaybes, maybeToList, fromMaybe ) +import Data.List (sort, group, isPrefixOf, nub, find) +import Control.Monad + ( filterM, liftM ) +import qualified System.Directory as System + ( doesFileExist, doesDirectoryExist ) +import 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.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 qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>), (<+>)) + +import qualified Language.Haskell.Extension as Extension (deprecatedExtensions) +import Language.Haskell.Extension + ( Language(UnknownLanguage), knownLanguages + , Extension(..), KnownExtension(..) ) +import System.FilePath + ( (), takeExtension, isRelative, isAbsolute + , splitDirectories, splitPath ) +import System.FilePath.Windows as FilePath.Windows + ( isValid ) + +-- | Results of some kind of failed package check. +-- +-- There are a range of severities, from merely dubious to totally insane. +-- All of them come with a human readable explanation. In future we may augment +-- them with more machine readable explanations, for example to help an IDE +-- suggest automatic corrections. +-- +data PackageCheck = + + -- | This package description is no good. There's no way it's going to + -- build sensibly. This should give an error at configure time. + PackageBuildImpossible { explanation :: String } + + -- | A problem that is likely to affect building the package, or an + -- issue that we'd like every package author to be aware of, even if + -- the package is never distributed. + | PackageBuildWarning { explanation :: String } + + -- | An issue that might not be a problem for the package author but + -- might be annoying or detrimental when the package is distributed to + -- users. We should encourage distributed packages to be free from these + -- issues, but occasionally there are justifiable reasons so we cannot + -- ban them entirely. + | PackageDistSuspicious { explanation :: String } + + -- | Like PackageDistSuspicious but will only display warnings + -- rather than causing abnormal exit. + | 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 + -- problems. + | PackageDistInexcusable { explanation :: String } + deriving (Eq) + +instance Show PackageCheck where + show notice = explanation notice + +check :: Bool -> PackageCheck -> Maybe PackageCheck +check False _ = Nothing +check True pc = Just pc + +checkSpecVersion :: PackageDescription -> [Int] -> Bool -> PackageCheck + -> Maybe PackageCheck +checkSpecVersion pkg specver cond pc + | specVersion pkg >= Version specver [] = Nothing + | otherwise = check cond pc + + +-- ------------------------------------------------------------ +-- * Standard checks +-- ------------------------------------------------------------ + +-- | Check for common mistakes and problems in package descriptions. +-- +-- This is the standard collection of checks covering all aspects except +-- for checks that require looking at files within the package. For those +-- see 'checkPackageFiles'. +-- +-- It requires the 'GenericPackageDescription' and optionally a particular +-- configuration of that package. If you pass 'Nothing' then we just check +-- a version of the generic description using 'flattenPackageDescription'. +-- +checkPackage :: GenericPackageDescription + -> Maybe PackageDescription + -> [PackageCheck] +checkPackage gpkg mpkg = + checkConfiguredPackage pkg + ++ checkConditionals gpkg + ++ checkPackageVersions gpkg + where + pkg = fromMaybe (flattenPackageDescription gpkg) mpkg + +--TODO: make this variant go away +-- we should always know the GenericPackageDescription +checkConfiguredPackage :: PackageDescription -> [PackageCheck] +checkConfiguredPackage pkg = + checkSanity pkg + ++ checkFields pkg + ++ checkLicense pkg + ++ checkSourceRepos pkg + ++ checkGhcOptions pkg + ++ checkCCOptions pkg + ++ checkCPPOptions pkg + ++ checkPaths pkg + ++ checkCabalVersion pkg + + +-- ------------------------------------------------------------ +-- * Basic sanity checks +-- ------------------------------------------------------------ + +-- | Check that this package description is sane. +-- +checkSanity :: PackageDescription -> [PackageCheck] +checkSanity pkg = + catMaybes [ + + check (null . (\(PackageName n) -> n) . packageName $ pkg) $ + PackageBuildImpossible "No 'name' field." + + , check (null . versionBranch . packageVersion $ pkg) $ + PackageBuildImpossible "No 'version' field." + + , check (null (executables pkg) && isNothing (library pkg)) $ + PackageBuildImpossible + "No executables and no library found. Nothing to do." + + , check (not (null duplicateNames)) $ + PackageBuildImpossible $ "Duplicate sections: " ++ commaSep duplicateNames + ++ ". The name of every executable, test suite, and benchmark section in" + ++ " the package must be unique." + ] + --TODO: check for name clashes case insensitively: windows file systems cannot + --cope. + + ++ maybe [] (checkLibrary pkg) (library pkg) + ++ concatMap (checkExecutable pkg) (executables pkg) + ++ concatMap (checkTestSuite pkg) (testSuites pkg) + ++ concatMap (checkBenchmark pkg) (benchmarks pkg) + + ++ catMaybes [ + + check (specVersion pkg > cabalVersion) $ + PackageBuildImpossible $ + "This package description follows version " + ++ display (specVersion pkg) ++ " of the Cabal specification. This " + ++ "tool only supports up to version " ++ display cabalVersion ++ "." + ] + where + exeNames = map exeName $ executables pkg + testNames = map testName $ testSuites pkg + bmNames = map benchmarkName $ benchmarks pkg + duplicateNames = dups $ exeNames ++ testNames ++ bmNames + +checkLibrary :: PackageDescription -> Library -> [PackageCheck] +checkLibrary pkg lib = + catMaybes [ + + check (not (null moduleDuplicates)) $ + PackageBuildImpossible $ + "Duplicate modules in library: " + ++ commaSep (map display moduleDuplicates) + + -- check use of required-signatures/exposed-signatures sections + , checkVersion [1,21] (not (null (requiredSignatures lib))) $ + PackageDistInexcusable $ + "To use the 'required-signatures' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.21'." + + , checkVersion [1,21] (not (null (exposedSignatures lib))) $ + PackageDistInexcusable $ + "To use the 'exposed-signatures' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.21'." + ] + + where + checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck + checkVersion ver cond pc + | specVersion pkg >= Version ver [] = Nothing + | otherwise = check cond pc + + moduleDuplicates = dups (libModules lib ++ + map moduleReexportName (reexportedModules lib)) + +checkExecutable :: PackageDescription -> Executable -> [PackageCheck] +checkExecutable pkg exe = + catMaybes [ + + check (null (modulePath exe)) $ + PackageBuildImpossible $ + "No 'main-is' field found for executable " ++ exeName exe + + , check (not (null (modulePath exe)) + && (not $ fileExtensionSupportedLanguage $ modulePath exe)) $ + PackageBuildImpossible $ + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor), " + ++ "or it may specify a C/C++/obj-C source file." + + , checkSpecVersion pkg [1,17] + (fileExtensionSupportedLanguage (modulePath exe) + && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $ + PackageDistInexcusable $ + "The package uses a C/C++/obj-C source file for the 'main-is' field. " + ++ "To use this feature you must specify 'cabal-version: >= 1.18'." + + , check (not (null moduleDuplicates)) $ + PackageBuildImpossible $ + "Duplicate modules in executable '" ++ exeName exe ++ "': " + ++ commaSep (map display moduleDuplicates) + ] + where + moduleDuplicates = dups (exeModules exe) + +checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck] +checkTestSuite pkg test = + catMaybes [ + + case testInterface test of + TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a known type of test suite. " + ++ "The known test suite types are: " + ++ commaSep (map display knownTestTypes) + + TestSuiteUnsupported tt -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a supported test suite version. " + ++ "The known test suite types are: " + ++ commaSep (map display knownTestTypes) + _ -> Nothing + + , check (not $ null moduleDuplicates) $ + PackageBuildImpossible $ + "Duplicate modules in test suite '" ++ testName test ++ "': " + ++ commaSep (map display moduleDuplicates) + + , check mainIsWrongExt $ + PackageBuildImpossible $ + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor), " + ++ "or it may specify a C/C++/obj-C source file." + + , checkSpecVersion pkg [1,17] (mainIsNotHsExt && not mainIsWrongExt) $ + PackageDistInexcusable $ + "The package uses a C/C++/obj-C source file for the 'main-is' field. " + ++ "To use this feature you must specify 'cabal-version: >= 1.18'." + + -- Test suites might be built as (internal) libraries named after + -- the test suite and thus their names must not clash with the + -- name of the package. + , check libNameClash $ + PackageBuildImpossible $ + "The test suite " ++ testName test + ++ " has the same name as the package." + ] + where + moduleDuplicates = dups $ testModules test + + mainIsWrongExt = case testInterface test of + TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f + _ -> False + + mainIsNotHsExt = case testInterface test of + TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False + + libNameClash = testName test `elem` [ libName + | _lib <- maybeToList (library pkg) + , let PackageName libName = + pkgName (package pkg) ] + +checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck] +checkBenchmark pkg bm = + catMaybes [ + + case benchmarkInterface bm of + BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a known type of benchmark. " + ++ "The known benchmark types are: " + ++ commaSep (map display knownBenchmarkTypes) + + BenchmarkUnsupported tt -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a supported benchmark version. " + ++ "The known benchmark types are: " + ++ commaSep (map display knownBenchmarkTypes) + _ -> Nothing + + , check (not $ null moduleDuplicates) $ + PackageBuildImpossible $ + "Duplicate modules in benchmark '" ++ benchmarkName bm ++ "': " + ++ commaSep (map display moduleDuplicates) + + , check mainIsWrongExt $ + PackageBuildImpossible $ + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor)." + + -- See comment for similar check on test suites. + , check libNameClash $ + PackageBuildImpossible $ + "The benchmark " ++ benchmarkName bm + ++ " has the same name as the package." + ] + where + moduleDuplicates = dups $ benchmarkModules bm + + mainIsWrongExt = case benchmarkInterface bm of + BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False + + libNameClash = benchmarkName bm `elem` [ libName + | _lib <- maybeToList (library pkg) + , let PackageName libName = + pkgName (package pkg) ] + +-- ------------------------------------------------------------ +-- * Additional pure checks +-- ------------------------------------------------------------ + +checkFields :: PackageDescription -> [PackageCheck] +checkFields pkg = + catMaybes [ + + check (not . FilePath.Windows.isValid . display . packageName $ pkg) $ + PackageDistInexcusable $ + "Unfortunately, the package name '" ++ display (packageName pkg) + ++ "' is one of the reserved system file names on Windows. Many tools " + ++ "need to convert package names to file names so using this name " + ++ "would cause problems." + + , check (isNothing (buildType pkg)) $ + PackageBuildWarning $ + "No 'build-type' specified. If you do not need a custom Setup.hs or " + ++ "./configure script then use 'build-type: Simple'." + + , case buildType pkg of + Just (UnknownBuildType unknown) -> Just $ + PackageBuildWarning $ + quote unknown ++ " is not a known 'build-type'. " + ++ "The known build types are: " + ++ commaSep (map display knownBuildTypes) + _ -> Nothing + + , check (not (null unknownCompilers)) $ + PackageBuildWarning $ + "Unknown compiler " ++ commaSep (map quote unknownCompilers) + ++ " in 'tested-with' field." + + , check (not (null unknownLanguages)) $ + PackageBuildWarning $ + "Unknown languages: " ++ commaSep unknownLanguages + + , check (not (null unknownExtensions)) $ + PackageBuildWarning $ + "Unknown extensions: " ++ commaSep unknownExtensions + + , check (not (null languagesUsedAsExtensions)) $ + PackageBuildWarning $ + "Languages listed as extensions: " + ++ commaSep languagesUsedAsExtensions + ++ ". Languages must be specified in either the 'default-language' " + ++ " or the 'other-languages' field." + + , check (not (null deprecatedExtensions)) $ + PackageDistSuspicious $ + "Deprecated extensions: " + ++ commaSep (map (quote . display . fst) deprecatedExtensions) + ++ ". " ++ unwords + [ "Instead of '" ++ display ext + ++ "' use '" ++ display replacement ++ "'." + | (ext, Just replacement) <- deprecatedExtensions ] + + , check (null (category pkg)) $ + PackageDistSuspicious "No 'category' field." + + , check (null (maintainer pkg)) $ + PackageDistSuspicious "No 'maintainer' field." + + , check (null (synopsis pkg) && null (description pkg)) $ + PackageDistInexcusable "No 'synopsis' or 'description' field." + + , check (null (description pkg) && not (null (synopsis pkg))) $ + PackageDistSuspicious "No 'description' field." + + , check (null (synopsis pkg) && not (null (description pkg))) $ + PackageDistSuspicious "No 'synopsis' field." + + --TODO: recommend the bug reports URL, author and homepage fields + --TODO: recommend not using the stability field + --TODO: recommend specifying a source repo + + , check (length (synopsis pkg) >= 80) $ + PackageDistSuspicious + "The 'synopsis' field is rather long (max 80 chars is recommended)." + + -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12" + , check (not (null testedWithImpossibleRanges)) $ + PackageDistInexcusable $ + "Invalid 'tested-with' version range: " + ++ commaSep (map display testedWithImpossibleRanges) + ++ ". To indicate that you have tested a package with multiple " + ++ "different versions of the same compiler use multiple entries, " + ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " + ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." + ] + where + unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] + unknownLanguages = [ name | bi <- allBuildInfo pkg + , UnknownLanguage name <- allLanguages bi ] + unknownExtensions = [ name | bi <- allBuildInfo pkg + , UnknownExtension name <- allExtensions bi + , name `notElem` map display knownLanguages ] + deprecatedExtensions = nub $ catMaybes + [ find ((==ext) . fst) Extension.deprecatedExtensions + | bi <- allBuildInfo pkg + , ext <- allExtensions bi ] + languagesUsedAsExtensions = + [ name | bi <- allBuildInfo pkg + , UnknownExtension name <- allExtensions bi + , name `elem` map display knownLanguages ] + + testedWithImpossibleRanges = + [ Dependency (PackageName (display compiler)) vr + | (compiler, vr) <- testedWith pkg + , isNoVersion vr ] + + +checkLicense :: PackageDescription -> [PackageCheck] +checkLicense pkg = + catMaybes [ + + check (license pkg == UnspecifiedLicense) $ + PackageDistInexcusable + "The 'license' field is missing." + + , check (license pkg == AllRightsReserved) $ + PackageDistSuspicious + "The 'license' is AllRightsReserved. Is that really what you want?" + , case license pkg of + UnknownLicense l -> Just $ + PackageBuildWarning $ + quote ("license: " ++ l) ++ " is not a recognised license. The " + ++ "known licenses are: " + ++ commaSep (map display knownLicenses) + _ -> Nothing + + , check (license pkg == BSD4) $ + PackageDistSuspicious $ + "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " + ++ "refers to the old 4-clause BSD license with the advertising " + ++ "clause. 'BSD3' refers the new 3-clause BSD license." + + , case unknownLicenseVersion (license pkg) of + Just knownVersions -> Just $ + PackageDistSuspicious $ + "'license: " ++ display (license pkg) ++ "' is not a known " + ++ "version of that license. The known versions are " + ++ commaSep (map display knownVersions) + ++ ". If this is not a mistake and you think it should be a known " + ++ "version then please file a ticket." + _ -> Nothing + + , check (license pkg `notElem` [ AllRightsReserved + , UnspecifiedLicense, PublicDomain] + -- AllRightsReserved and PublicDomain are not strictly + -- licenses so don't need license files. + && null (licenseFiles pkg)) $ + PackageDistSuspicious "A 'license-file' is not specified." + ] + where + unknownLicenseVersion (GPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where knownVersions = [ v' | GPL (Just v') <- knownLicenses ] + unknownLicenseVersion (LGPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ] + unknownLicenseVersion (AGPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where knownVersions = [ v' | AGPL (Just v') <- knownLicenses ] + unknownLicenseVersion (Apache (Just v)) + | v `notElem` knownVersions = Just knownVersions + where knownVersions = [ v' | Apache (Just v') <- knownLicenses ] + unknownLicenseVersion _ = Nothing + +checkSourceRepos :: PackageDescription -> [PackageCheck] +checkSourceRepos pkg = + catMaybes $ concat [[ + + case repoKind repo of + RepoKindUnknown kind -> Just $ PackageDistInexcusable $ + quote kind ++ " is not a recognised kind of source-repository. " + ++ "The repo kind is usually 'head' or 'this'" + _ -> Nothing + + , check (isNothing (repoType repo)) $ + PackageDistInexcusable + "The source-repository 'type' is a required field." + + , check (isNothing (repoLocation repo)) $ + PackageDistInexcusable + "The source-repository 'location' is a required field." + + , check (repoType repo == Just CVS && isNothing (repoModule repo)) $ + PackageDistInexcusable + "For a CVS source-repository, the 'module' is a required field." + + , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $ + PackageDistInexcusable $ + "For the 'this' kind of source-repository, the 'tag' is a required " + ++ "field. It should specify the tag corresponding to this version " + ++ "or release of the package." + + , check (maybe False System.FilePath.isAbsolute (repoSubdir repo)) $ + PackageDistInexcusable + "The 'subdir' field of a source-repository must be a relative path." + ] + | repo <- sourceRepos pkg ] + +--TODO: check location looks like a URL for some repo types. + +checkGhcOptions :: PackageDescription -> [PackageCheck] +checkGhcOptions pkg = + catMaybes [ + + check has_WerrorWall $ + PackageDistInexcusable $ + "'ghc-options: -Wall -Werror' makes the package very easy to " + ++ "break with future GHC versions because new GHC versions often " + ++ "add new warnings. Use just 'ghc-options: -Wall' instead." + + , check (not has_WerrorWall && has_Werror) $ + PackageDistSuspicious $ + "'ghc-options: -Werror' makes the package easy to " + ++ "break with future GHC versions because new GHC versions often " + ++ "add new warnings." + + , checkFlags ["-fasm"] $ + PackageDistInexcusable $ + "'ghc-options: -fasm' is unnecessary and will not work on CPU " + ++ "architectures other than x86, x86-64, ppc or sparc." + + , checkFlags ["-fvia-C"] $ + PackageDistSuspicious $ + "'ghc-options: -fvia-C' is usually unnecessary. If your package " + ++ "needs -via-C for correctness rather than performance then it " + ++ "is using the FFI incorrectly and will probably not work with GHC " + ++ "6.10 or later." + + , checkFlags ["-fdefer-type-errors"] $ + PackageDistInexcusable $ + "'ghc-options: -fdefer-type-errors' is fine during development but " + ++ "is not appropriate for a distributed package." + + , checkFlags ["-fhpc"] $ + PackageDistInexcusable $ + "'ghc-options: -fhpc' is not appropriate for a distributed package." + + -- -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." + + , checkFlags ["-prof"] $ + PackageBuildWarning $ + "'ghc-options: -prof' is not necessary and will lead to problems " + ++ "when used on a library. Use the configure flag " + ++ "--enable-library-profiling and/or --enable-executable-profiling." + + , checkFlags ["-o"] $ + PackageBuildWarning $ + "'ghc-options: -o' is not needed. " + ++ "The output files are named automatically." + + , checkFlags ["-hide-package"] $ + PackageBuildWarning $ + "'ghc-options: -hide-package' is never needed. " + ++ "Cabal hides all packages." + + , checkFlags ["--make"] $ + PackageBuildWarning $ + "'ghc-options: --make' is never needed. Cabal uses this automatically." + + , checkFlags ["-main-is"] $ + PackageDistSuspicious $ + "'ghc-options: -main-is' is not portable." + + , checkFlags ["-O0", "-Onot"] $ + PackageDistSuspicious $ + "'ghc-options: -O0' is not needed. " + ++ "Use the --disable-optimization configure flag." + + , checkFlags [ "-O", "-O1"] $ + PackageDistInexcusable $ + "'ghc-options: -O' is not needed. " + ++ "Cabal automatically adds the '-O' flag. " + ++ "Setting it yourself interferes with the --disable-optimization flag." + + , checkFlags ["-O2"] $ + 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." + + , checkFlags ["-split-objs"] $ + PackageBuildWarning $ + "'ghc-options: -split-objs' is not needed. " + ++ "Use the --enable-split-objs configure flag." + + , checkFlags ["-optl-Wl,-s", "-optl-s"] $ + PackageDistInexcusable $ + "'ghc-options: -optl-Wl,-s' is not needed and is not portable to all" + ++ " operating systems. Cabal 1.4 and later automatically strip" + ++ " executables. Cabal also has a flag --disable-executable-stripping" + ++ " which is necessary when building packages for some Linux" + ++ " distributions and using '-optl-Wl,-s' prevents that from working." + + , checkFlags ["-fglasgow-exts"] $ + PackageDistSuspicious $ + "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use " + ++ "the 'extensions' field." + + , checkProfFlags ["-auto-all"] $ + PackageDistSuspicious $ + "'ghc-prof-options: -auto-all' is fine during development, but " + ++ "not recommended in a distributed package. " + + , check ("-threaded" `elem` lib_ghc_options) $ + PackageDistSuspicious $ + "'ghc-options: -threaded' has no effect for libraries. It should " + ++ "only be used for executables." + + , checkAlternatives "ghc-options" "extensions" + [ (flag, display extension) | flag <- all_ghc_options + , Just extension <- [ghcExtension flag] ] + + , checkAlternatives "ghc-options" "extensions" + [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "cpp-options" $ + [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ] + ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "include-dirs" + [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "extra-libraries" + [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "extra-lib-dirs" + [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ] + ] + + where + has_WerrorWall = flip any ghc_options $ \opts -> + "-Werror" `elem` opts + && ("-Wall" `elem` opts || "-W" `elem` opts) + has_Werror = any (\opts -> "-Werror" `elem` opts) ghc_options + + (ghc_options, 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) + + checkFlags,checkProfFlags :: [String] -> PackageCheck -> Maybe PackageCheck + checkFlags flags = doCheckFlags flags all_ghc_options + checkProfFlags flags = doCheckFlags flags all_ghc_prof_options + + doCheckFlags flags opts = check (any (`elem` flags) opts) + + ghcExtension ('-':'f':name) = case name of + "allow-overlapping-instances" -> enable OverlappingInstances + "no-allow-overlapping-instances" -> disable OverlappingInstances + "th" -> enable TemplateHaskell + "no-th" -> disable TemplateHaskell + "ffi" -> enable ForeignFunctionInterface + "no-ffi" -> disable ForeignFunctionInterface + "fi" -> enable ForeignFunctionInterface + "no-fi" -> disable ForeignFunctionInterface + "monomorphism-restriction" -> enable MonomorphismRestriction + "no-monomorphism-restriction" -> disable MonomorphismRestriction + "mono-pat-binds" -> enable MonoPatBinds + "no-mono-pat-binds" -> disable MonoPatBinds + "allow-undecidable-instances" -> enable UndecidableInstances + "no-allow-undecidable-instances" -> disable UndecidableInstances + "allow-incoherent-instances" -> enable IncoherentInstances + "no-allow-incoherent-instances" -> disable IncoherentInstances + "arrows" -> enable Arrows + "no-arrows" -> disable Arrows + "generics" -> enable Generics + "no-generics" -> disable Generics + "implicit-prelude" -> enable ImplicitPrelude + "no-implicit-prelude" -> disable ImplicitPrelude + "implicit-params" -> enable ImplicitParams + "no-implicit-params" -> disable ImplicitParams + "bang-patterns" -> enable BangPatterns + "no-bang-patterns" -> disable BangPatterns + "scoped-type-variables" -> enable ScopedTypeVariables + "no-scoped-type-variables" -> disable ScopedTypeVariables + "extended-default-rules" -> enable ExtendedDefaultRules + "no-extended-default-rules" -> disable ExtendedDefaultRules + _ -> Nothing + ghcExtension "-cpp" = enable CPP + ghcExtension _ = Nothing + + enable e = Just (EnableExtension e) + disable e = Just (DisableExtension e) + +checkCCOptions :: PackageDescription -> [PackageCheck] +checkCCOptions pkg = + catMaybes [ + + checkAlternatives "cc-options" "include-dirs" + [ (flag, dir) | flag@('-':'I':dir) <- all_ccOptions ] + + , checkAlternatives "cc-options" "extra-libraries" + [ (flag, lib) | flag@('-':'l':lib) <- all_ccOptions ] + + , checkAlternatives "cc-options" "extra-lib-dirs" + [ (flag, dir) | flag@('-':'L':dir) <- all_ccOptions ] + + , checkAlternatives "ld-options" "extra-libraries" + [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ] + + , checkAlternatives "ld-options" "extra-lib-dirs" + [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ] + + , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $ + PackageDistSuspicious $ + "'cc-options: -O[n]' is generally not needed. When building with " + ++ " optimisations Cabal automatically adds '-O2' for C code. " + ++ "Setting it yourself interferes with the --disable-optimization " + ++ "flag." + ] + + where all_ccOptions = [ opts | bi <- allBuildInfo pkg + , opts <- ccOptions bi ] + all_ldOptions = [ opts | bi <- allBuildInfo pkg + , opts <- ldOptions bi ] + + checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck + checkCCFlags flags = check (any (`elem` flags) all_ccOptions) + +checkCPPOptions :: PackageDescription -> [PackageCheck] +checkCPPOptions pkg = + catMaybes [ + checkAlternatives "cpp-options" "include-dirs" + [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions] + ] + where all_cppOptions = [ opts | bi <- allBuildInfo pkg + , opts <- cppOptions bi ] + +checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck +checkAlternatives badField goodField flags = + check (not (null badFlags)) $ + PackageBuildWarning $ + "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags) + ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags) + + where (badFlags, goodFlags) = unzip flags + +checkPaths :: PackageDescription -> [PackageCheck] +checkPaths pkg = + [ PackageBuildWarning $ + quote (kind ++ ": " ++ path) + ++ " is a relative path outside of the source tree. " + ++ "This will not work when generating a tarball with 'sdist'." + | (path, kind) <- relPaths ++ absPaths + , isOutsideTree path ] + ++ + [ PackageDistInexcusable $ + quote (kind ++ ": " ++ path) ++ " is an absolute directory." + | (path, kind) <- relPaths + , isAbsolute path ] + ++ + [ PackageDistInexcusable $ + quote (kind ++ ": " ++ path) ++ " points inside the 'dist' " + ++ "directory. This is not reliable because the location of this " + ++ "directory is configurable by the user (or package manager). In " + ++ "addition the layout of the 'dist' directory is subject to change " + ++ "in future versions of Cabal." + | (path, kind) <- relPaths ++ absPaths + , isInsideDist path ] + ++ + [ PackageDistInexcusable $ + "The 'ghc-options' contains the path '" ++ path ++ "' which points " + ++ "inside the 'dist' directory. This is not reliable because the " + ++ "location of this directory is configurable by the user (or package " + ++ "manager). In addition the layout of the 'dist' directory is subject " + ++ "to change in future versions of Cabal." + | bi <- allBuildInfo pkg + , (GHC, flags) <- options bi + , path <- flags + , isInsideDist path ] + where + isOutsideTree path = case splitDirectories path of + "..":_ -> True + ".":"..":_ -> True + _ -> False + isInsideDist path = case map lowercase (splitDirectories path) of + "dist" :_ -> True + ".":"dist":_ -> True + _ -> False + -- paths that must be relative + relPaths = + [ (path, "extra-src-files") | path <- extraSrcFiles pkg ] + ++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ] + ++ [ (path, "extra-doc-files") | path <- extraDocFiles pkg ] + ++ [ (path, "data-files") | path <- dataFiles pkg ] + ++ [ (path, "data-dir") | path <- [dataDir pkg]] + ++ concat + [ [ (path, "c-sources") | path <- cSources bi ] + ++ [ (path, "js-sources") | path <- jsSources bi ] + ++ [ (path, "install-includes") | path <- installIncludes bi ] + ++ [ (path, "hs-source-dirs") | path <- hsSourceDirs bi ] + | bi <- allBuildInfo pkg ] + -- paths that are allowed to be absolute + absPaths = concat + [ [ (path, "includes") | path <- includes bi ] + ++ [ (path, "include-dirs") | path <- includeDirs bi ] + ++ [ (path, "extra-lib-dirs") | path <- extraLibDirs bi ] + | bi <- allBuildInfo pkg ] + +--TODO: check sets of paths that would be interpreted differently between Unix +-- and windows, ie case-sensitive or insensitive. Things that might clash, or +-- conversely be distinguished. + +--TODO: use the tar path checks on all the above paths + +-- | Check that the package declares the version in the @\"cabal-version\"@ +-- field correctly. +-- +checkCabalVersion :: PackageDescription -> [PackageCheck] +checkCabalVersion pkg = + catMaybes [ + + -- check syntax of cabal-version field + check (specVersion pkg >= Version [1,10] [] + && not simpleSpecVersionRangeSyntax) $ + PackageBuildWarning $ + "Packages relying on Cabal 1.10 or later must only specify a " + ++ "version range of the form 'cabal-version: >= x.y'. Use " + ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'." + + -- check syntax of cabal-version field + , check (specVersion pkg < Version [1,9] [] + && not simpleSpecVersionRangeSyntax) $ + PackageDistSuspicious $ + "It is recommended that the 'cabal-version' field only specify a " + ++ "version range of the form '>= x.y'. Use " + ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'. " + ++ "Tools based on Cabal 1.10 and later will ignore upper bounds." + + -- check syntax of cabal-version field + , checkVersion [1,12] simpleSpecVersionSyntax $ + PackageBuildWarning $ + "With Cabal 1.10 or earlier, the 'cabal-version' field must use " + ++ "range syntax rather than a simple version number. Use " + ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'." + + -- check use of test suite sections + , checkVersion [1,8] (not (null $ testSuites pkg)) $ + PackageDistInexcusable $ + "The 'test-suite' section is new in Cabal 1.10. " + ++ "Unfortunately it messes up the parser in older Cabal versions " + ++ "so you must specify at least 'cabal-version: >= 1.8', but note " + ++ "that only Cabal 1.10 and later can actually run such test suites." + + -- check use of default-language field + -- note that we do not need to do an equivalent check for the + -- other-language field since that one does not change behaviour + , checkVersion [1,10] (any isJust (buildInfoField defaultLanguage)) $ + PackageBuildWarning $ + "To use the 'default-language' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." + + , check (specVersion pkg >= Version [1,10] [] + && (any isNothing (buildInfoField defaultLanguage))) $ + PackageBuildWarning $ + "Packages using 'cabal-version: >= 1.10' must specify the " + ++ "'default-language' field for each component (e.g. Haskell98 or " + ++ "Haskell2010). If a component uses different languages in " + ++ "different modules then list the other ones in the " + ++ "'other-languages' field." + + -- check use of reexported-modules sections + , checkVersion [1,21] + (maybe False (not.null.reexportedModules) (library pkg)) $ + PackageDistInexcusable $ + "To use the 'reexported-module' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.21'." + + -- check use of thinning and renaming + , checkVersion [1,21] (not (null depsUsingThinningRenamingSyntax)) $ + PackageDistInexcusable $ + "The package uses " + ++ "thinning and renaming in the 'build-depends' field: " + ++ commaSep (map display depsUsingThinningRenamingSyntax) + ++ ". To use this new syntax, the package needs to specify at least" + ++ "'cabal-version: >= 1.21'." + + -- check use of default-extensions field + -- don't need to do the equivalent check for other-extensions + , checkVersion [1,10] (any (not . null) (buildInfoField defaultExtensions)) $ + PackageBuildWarning $ + "To use the 'default-extensions' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." + + -- check use of extensions field + , check (specVersion pkg >= Version [1,10] [] + && (any (not . null) (buildInfoField oldExtensions))) $ + PackageBuildWarning $ + "For packages using 'cabal-version: >= 1.10' the 'extensions' " + ++ "field is deprecated. The new 'default-extensions' field lists " + ++ "extensions that are used in all modules in the component, while " + ++ "the 'other-extensions' field lists extensions that are used in " + ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." + + -- check use of "foo (>= 1.0 && < 1.4) || >=1.8 " version-range syntax + , checkVersion [1,8] (not (null versionRangeExpressions)) $ + PackageDistInexcusable $ + "The package uses full version-range expressions " + ++ "in a 'build-depends' field: " + ++ commaSep (map displayRawDependency versionRangeExpressions) + ++ ". To use this new syntax the package needs to specify at least " + ++ "'cabal-version: >= 1.8'. Alternatively, if broader compatibility " + ++ "is important, then convert to conjunctive normal form, and use " + ++ "multiple 'build-depends:' lines, one conjunct per line." + + -- check use of "build-depends: foo == 1.*" syntax + , checkVersion [1,6] (not (null depsUsingWildcardSyntax)) $ + PackageDistInexcusable $ + "The package uses wildcard syntax in the 'build-depends' field: " + ++ commaSep (map display depsUsingWildcardSyntax) + ++ ". To use this new syntax the package need to specify at least " + ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatibility " + ++ "is important then use: " ++ commaSep + [ display (Dependency name (eliminateWildcardSyntax versionRange)) + | Dependency name versionRange <- depsUsingWildcardSyntax ] + + -- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax + , checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $ + PackageDistInexcusable $ + "The package uses full version-range expressions " + ++ "in a 'tested-with' field: " + ++ commaSep (map displayRawDependency testedWithVersionRangeExpressions) + ++ ". To use this new syntax the package needs to specify at least " + ++ "'cabal-version: >= 1.8'." + + -- check use of "tested-with: GHC == 6.12.*" syntax + , checkVersion [1,6] (not (null testedWithUsingWildcardSyntax)) $ + PackageDistInexcusable $ + "The package uses wildcard syntax in the 'tested-with' field: " + ++ commaSep (map display testedWithUsingWildcardSyntax) + ++ ". To use this new syntax the package need to specify at least " + ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatibility " + ++ "is important then use: " ++ commaSep + [ display (Dependency name (eliminateWildcardSyntax versionRange)) + | Dependency name versionRange <- testedWithUsingWildcardSyntax ] + + -- check use of "data-files: data/*.txt" syntax + , checkVersion [1,6] (not (null dataFilesUsingGlobSyntax)) $ + PackageDistInexcusable $ + "Using wildcards like " + ++ commaSep (map quote $ take 3 dataFilesUsingGlobSyntax) + ++ " in the 'data-files' field requires 'cabal-version: >= 1.6'. " + ++ "Alternatively if you require compatibility with earlier Cabal " + ++ "versions then list all the files explicitly." + + -- check use of "extra-source-files: mk/*.in" syntax + , checkVersion [1,6] (not (null extraSrcFilesUsingGlobSyntax)) $ + PackageDistInexcusable $ + "Using wildcards like " + ++ commaSep (map quote $ take 3 extraSrcFilesUsingGlobSyntax) + ++ " in the 'extra-source-files' field requires " + ++ "'cabal-version: >= 1.6'. Alternatively if you require " + ++ "compatibility with earlier Cabal versions then list all the files " + ++ "explicitly." + + -- check use of "source-repository" section + , checkVersion [1,6] (not (null (sourceRepos pkg))) $ + PackageDistInexcusable $ + "The 'source-repository' section is new in Cabal 1.6. " + ++ "Unfortunately it messes up the parser in earlier Cabal versions " + ++ "so you need to specify 'cabal-version: >= 1.6'." + + -- check for new licenses + , checkVersion [1,4] (license pkg `notElem` compatLicenses) $ + PackageDistInexcusable $ + "Unfortunately the license " ++ quote (display (license pkg)) + ++ " messes up the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " + ++ "compatibility with earlier Cabal versions then use 'OtherLicense'." + + -- check for new language extensions + , checkVersion [1,2,3] (not (null mentionedExtensionsThatNeedCabal12)) $ + PackageDistInexcusable $ + "Unfortunately the language extensions " + ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal12) + ++ " break the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= 1.2.3'. Alternatively if you require " + ++ "compatibility with earlier Cabal versions then you may be able to " + ++ "use an equivalent compiler-specific flag." + + , checkVersion [1,4] (not (null mentionedExtensionsThatNeedCabal14)) $ + PackageDistInexcusable $ + "Unfortunately the language extensions " + ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal14) + ++ " break the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " + ++ "compatibility with earlier Cabal versions then you may be able to " + ++ "use an equivalent compiler-specific flag." + ] + where + -- Perform a check on packages that use a version of the spec less than + -- the version given. This is for cases where a new Cabal version adds + -- a new feature and we want to check that it is not used prior to that + -- version. + checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck + checkVersion ver cond pc + | specVersion pkg >= Version ver [] = Nothing + | otherwise = check cond pc + + buildInfoField field = map field (allBuildInfo pkg) + dataFilesUsingGlobSyntax = filter usesGlobSyntax (dataFiles pkg) + extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg) + usesGlobSyntax str = case parseFileGlob str of + Just (FileGlob _ _) -> True + _ -> False + + versionRangeExpressions = + [ dep | dep@(Dependency _ vr) <- buildDepends pkg + , usesNewVersionRangeSyntax vr ] + + testedWithVersionRangeExpressions = + [ Dependency (PackageName (display compiler)) vr + | (compiler, vr) <- testedWith pkg + , usesNewVersionRangeSyntax vr ] + + simpleSpecVersionRangeSyntax = + either (const True) + (foldVersionRange' + True + (\_ -> False) + (\_ -> False) (\_ -> False) + (\_ -> True) -- >= + (\_ -> False) + (\_ _ -> False) + (\_ _ -> False) (\_ _ -> False) + id) + (specVersionRaw pkg) + + -- is the cabal-version field a simple version number, rather than a range + simpleSpecVersionSyntax = + either (const True) (const False) (specVersionRaw pkg) + + usesNewVersionRangeSyntax :: VersionRange -> Bool + usesNewVersionRangeSyntax = + (> 2) -- uses the new syntax if depth is more than 2 + . foldVersionRange' + (1 :: Int) + (const 1) + (const 1) (const 1) + (const 1) (const 1) + (const (const 1)) + (+) (+) + (const 3) -- uses new ()'s syntax + + depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg + , usesWildcardSyntax vr ] + + -- XXX: 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 [] ] + + testedWithUsingWildcardSyntax = + [ Dependency (PackageName (display compiler)) vr + | (compiler, vr) <- testedWith pkg + , usesWildcardSyntax vr ] + + usesWildcardSyntax :: VersionRange -> Bool + usesWildcardSyntax = + foldVersionRange' + False (const False) + (const False) (const False) + (const False) (const False) + (\_ _ -> True) -- the wildcard case + (||) (||) id + + eliminateWildcardSyntax = + foldVersionRange' + anyVersion thisVersion + laterVersion earlierVersion + orLaterVersion orEarlierVersion + (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v')) + intersectVersionRanges unionVersionRanges id + + compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4 + , PublicDomain, AllRightsReserved + , UnspecifiedLicense, OtherLicense ] + + mentionedExtensions = [ ext | bi <- allBuildInfo pkg + , ext <- allExtensions bi ] + mentionedExtensionsThatNeedCabal12 = + nub (filter (`elem` compatExtensionsExtra) mentionedExtensions) + + -- As of Cabal-1.4 we can add new extensions without worrying about + -- breaking old versions of cabal. + mentionedExtensionsThatNeedCabal14 = + nub (filter (`notElem` compatExtensions) mentionedExtensions) + + -- The known extensions in Cabal-1.2.3 + compatExtensions = + map EnableExtension + [ OverlappingInstances, UndecidableInstances, IncoherentInstances + , RecursiveDo, ParallelListComp, MultiParamTypeClasses + , FunctionalDependencies, Rank2Types + , RankNTypes, PolymorphicComponents, ExistentialQuantification + , ScopedTypeVariables, ImplicitParams, FlexibleContexts + , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns + , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface + , Arrows, Generics, NamedFieldPuns, PatternGuards + , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms + , HereDocuments] ++ + map DisableExtension + [MonomorphismRestriction, ImplicitPrelude] ++ + compatExtensionsExtra + + -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6 + -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8) + compatExtensionsExtra = + map EnableExtension + [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving + , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms + , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields + , OverloadedStrings, GADTs, RelaxedPolyRec + , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable + , ConstrainedClassMethods + ] ++ + map DisableExtension + [MonoPatBinds] + +-- | A variation on the normal 'Text' instance, shows any ()'s in the original +-- textual syntax. We need to show these otherwise it's confusing to users when +-- we complain of their presence but do not pretty print them! +-- +displayRawVersionRange :: VersionRange -> String +displayRawVersionRange = + Disp.render + . fst + . foldVersionRange' -- precedence: + -- All the same as the usual pretty printer, except for the parens + ( Disp.text "-any" , 0 :: Int) + (\v -> (Disp.text "==" <> disp v , 0)) + (\v -> (Disp.char '>' <> disp v , 0)) + (\v -> (Disp.char '<' <> disp v , 0)) + (\v -> (Disp.text ">=" <> disp v , 0)) + (\v -> (Disp.text "<=" <> disp v , 0)) + (\v _ -> (Disp.text "==" <> dispWild v , 0)) + (\(r1, p1) (r2, p2) -> + (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) + (\(r1, p1) (r2, p2) -> + (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) + (\(r, _ ) -> (Disp.parens r, 0)) -- parens + + where + dispWild (Version b _) = + Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) + <> Disp.text ".*" + punct p p' | p < p' = Disp.parens + | otherwise = id + +displayRawDependency :: Dependency -> String +displayRawDependency (Dependency pkg vr) = + display pkg ++ " " ++ displayRawVersionRange vr + + +-- ------------------------------------------------------------ +-- * Checks on the GenericPackageDescription +-- ------------------------------------------------------------ + +-- | Check the build-depends fields for any weirdness or bad practise. +-- +checkPackageVersions :: GenericPackageDescription -> [PackageCheck] +checkPackageVersions pkg = + catMaybes [ + + -- Check that the version of base is bounded above. + -- For example this bans "build-depends: base >= 3". + -- It should probably be "build-depends: base >= 3 && < 4" + -- which is the same as "build-depends: base == 3.*" + check (not (boundedAbove baseDependency)) $ + PackageDistInexcusable $ + "The dependency 'build-depends: base' does not specify an upper " + ++ "bound on the version number. Each major release of the 'base' " + ++ "package changes the API in various ways and most packages will " + ++ "need some changes to compile with it. The recommended practise " + ++ "is to specify an upper bound on the version of the 'base' " + ++ "package. This ensures your package will continue to build when a " + ++ "new major version of the 'base' package is released. If you are " + ++ "not sure what upper bound to use then use the next major " + ++ "version. For example if you have tested your package with 'base' " + ++ "version 2 and 3 then use 'build-depends: base >= 2 && < 4'." + + ] + where + -- TODO: What we really want to do is test if there exists any + -- configuration in which the base version is unbounded above. + -- However that's a bit tricky because there are many possible + -- configurations. As a cheap easy and safe approximation we will + -- pick a single "typical" configuration and check if that has an + -- open upper bound. To get a typical configuration we finalise + -- using no package index and the current platform. + finalised = finalizePackageDescription + [] (const True) buildPlatform + (unknownCompilerInfo + (CompilerId buildCompilerFlavor (Version [] [])) NoAbiTag) + [] pkg + baseDependency = case finalised of + Right (pkg', _) | not (null baseDeps) -> + foldr intersectVersionRanges anyVersion baseDeps + where + baseDeps = + [ vr | Dependency (PackageName "base") vr <- buildDepends pkg' ] + + -- Just in case finalizePackageDescription fails for any reason, + -- or if the package doesn't depend on the base package at all, + -- then we will just skip the check, since boundedAbove noVersion = True + _ -> noVersion + + boundedAbove :: VersionRange -> Bool + boundedAbove vr = case asVersionIntervals vr of + [] -> True -- this is the inconsistent version range. + intervals -> case last intervals of + (_, UpperBound _ _) -> True + (_, NoUpperBound ) -> False + + +checkConditionals :: GenericPackageDescription -> [PackageCheck] +checkConditionals pkg = + catMaybes [ + + check (not $ null unknownOSs) $ + PackageDistInexcusable $ + "Unknown operating system name " + ++ commaSep (map quote unknownOSs) + + , check (not $ null unknownArches) $ + PackageDistInexcusable $ + "Unknown architecture name " + ++ commaSep (map quote unknownArches) + + , check (not $ null unknownImpls) $ + PackageDistInexcusable $ + "Unknown compiler name " + ++ commaSep (map quote unknownImpls) + ] + where + unknownOSs = [ os | OS (OtherOS os) <- conditions ] + unknownArches = [ arch | Arch (OtherArch arch) <- conditions ] + unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ] + conditions = maybe [] freeVars (condLibrary pkg) + ++ concatMap (freeVars . snd) (condExecutables pkg) + freeVars (CondNode _ _ ifs) = concatMap compfv ifs + compfv (c, ct, mct) = condfv c ++ freeVars ct ++ maybe [] freeVars mct + condfv c = case c of + Var v -> [v] + Lit _ -> [] + CNot c1 -> condfv c1 + COr c1 c2 -> condfv c1 ++ condfv c2 + CAnd c1 c2 -> condfv c1 ++ condfv c2 + +-- ------------------------------------------------------------ +-- * Checks involving files in the package +-- ------------------------------------------------------------ + +-- | Sanity check things that requires IO. It looks at the files in the +-- package and expects to find the package unpacked in at the given file path. +-- +checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck] +checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg + where + checkFilesIO = CheckPackageContentOps { + doesFileExist = System.doesFileExist . relative, + doesDirectoryExist = System.doesDirectoryExist . relative + } + relative path = root path + +-- | A record of operations needed to check the contents of packages. +-- Used by 'checkPackageContent'. +-- +data CheckPackageContentOps m = CheckPackageContentOps { + doesFileExist :: FilePath -> m Bool, + doesDirectoryExist :: FilePath -> m Bool + } + +-- | Sanity check things that requires looking at files in the package. +-- This is a generalised version of 'checkPackageFiles' that can work in any +-- monad for which you can provide 'CheckPackageContentOps' operations. +-- +-- The point of this extra generality is to allow doing checks in some virtual +-- file system, for example a tarball in memory. +-- +checkPackageContent :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkPackageContent ops pkg = do + licenseErrors <- checkLicensesExist ops pkg + setupError <- checkSetupExists ops pkg + configureError <- checkConfigureExists ops pkg + localPathErrors <- checkLocalPathsExist ops pkg + vcsLocation <- checkMissingVcsInfo ops pkg + + return $ licenseErrors + ++ catMaybes [setupError, configureError] + ++ localPathErrors + ++ vcsLocation + +checkLicensesExist :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkLicensesExist ops pkg = do + exists <- mapM (doesFileExist ops) (licenseFiles pkg) + return + [ PackageBuildWarning $ + "The '" ++ fieldname ++ "' field refers to the file " + ++ quote file ++ " which does not exist." + | (file, False) <- zip (licenseFiles pkg) exists ] + where + fieldname | length (licenseFiles pkg) == 1 = "license-file" + | otherwise = "license-files" + +checkSetupExists :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkSetupExists ops _ = do + hsexists <- doesFileExist ops "Setup.hs" + lhsexists <- doesFileExist ops "Setup.lhs" + return $ check (not hsexists && not lhsexists) $ + PackageDistInexcusable $ + "The package is missing a Setup.hs or Setup.lhs script." + +checkConfigureExists :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkConfigureExists ops PackageDescription { buildType = Just Configure } = do + exists <- doesFileExist ops "configure" + return $ check (not exists) $ + PackageBuildWarning $ + "The 'build-type' is 'Configure' but there is no 'configure' script. " + ++ "You probably need to run 'autoreconf -i' to generate it." +checkConfigureExists _ _ = return Nothing + +checkLocalPathsExist :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkLocalPathsExist ops pkg = do + let dirs = [ (dir, kind) + | bi <- allBuildInfo pkg + , (dir, kind) <- + [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ] + ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] + ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ] + , isRelative dir ] + missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs + return [ PackageBuildWarning { + explanation = quote (kind ++ ": " ++ dir) + ++ " directory does not exist." + } + | (dir, kind) <- missing ] + +checkMissingVcsInfo :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do + vcsInUse <- liftM or $ mapM (doesDirectoryExist ops) repoDirnames + if vcsInUse + then return [ PackageDistSuspicious message ] + else return [] + where + repoDirnames = [ dirname | repo <- knownRepoTypes + , dirname <- repoTypeDirname repo ] + message = "When distributing packages it is encouraged to specify source " + ++ "control information in the .cabal file using one or more " + ++ "'source-repository' sections. See the Cabal user guide for " + ++ "details." + +checkMissingVcsInfo _ _ = return [] + +repoTypeDirname :: RepoType -> [FilePath] +repoTypeDirname Darcs = ["_darcs"] +repoTypeDirname Git = [".git"] +repoTypeDirname SVN = [".svn"] +repoTypeDirname CVS = ["CVS"] +repoTypeDirname Mercurial = [".hg"] +repoTypeDirname GnuArch = [".arch-params"] +repoTypeDirname Bazaar = [".bzr"] +repoTypeDirname Monotone = ["_MTN"] +repoTypeDirname _ = [] + +-- ------------------------------------------------------------ +-- * Checks involving files in the package +-- ------------------------------------------------------------ + +-- | Check the names of all files in a package for portability problems. This +-- should be done for example when creating or validating a package tarball. +-- +checkPackageFileNames :: [FilePath] -> [PackageCheck] +checkPackageFileNames files = + (take 1 . catMaybes . map checkWindowsPath $ files) + ++ (take 1 . catMaybes . map checkTarPath $ files) + -- If we get any of these checks triggering then we're likely to get + -- many, and that's probably not helpful, so return at most one. + +checkWindowsPath :: FilePath -> Maybe PackageCheck +checkWindowsPath path = + check (not $ FilePath.Windows.isValid path') $ + PackageDistInexcusable $ + "Unfortunately, the file " ++ quote path ++ " is not a valid file " + ++ "name on Windows which would cause portability problems for this " + ++ "package. Windows file names cannot contain any of the characters " + ++ "\":*?<>|\" and there are a few reserved names including \"aux\", " + ++ "\"nul\", \"con\", \"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." + where + path' = ".\\" ++ path + -- force a relative name to catch invalid file names like "f:oo" which + -- otherwise parse as file "oo" in the current directory on the 'f' drive. + +-- | Check a file name is valid for the portable POSIX tar format. +-- +-- The POSIX tar format has a restriction on the length of file names. It is +-- unfortunately not a simple restriction like a maximum length. The exact +-- restriction is that either the whole path be 100 characters or less, or it +-- be possible to split the path on a directory separator such that the first +-- part is 155 characters or less and the second part 100 characters or less. +-- +checkTarPath :: FilePath -> Maybe PackageCheck +checkTarPath path + | length path > 255 = Just longPath + | otherwise = case pack nameMax (reverse (splitPath path)) of + Left err -> Just err + Right [] -> Nothing + Right (first:rest) -> case pack prefixMax remainder of + Left err -> Just err + Right [] -> Nothing + Right (_:_) -> Just noSplit + where + -- drop the '/' between the name and prefix: + remainder = init first : rest + + where + nameMax, prefixMax :: Int + nameMax = 100 + prefixMax = 155 + + pack _ [] = Left emptyName + pack maxLen (c:cs) + | n > maxLen = Left longName + | otherwise = Right (pack' maxLen n cs) + where n = length c + + pack' maxLen n (c:cs) + | n' <= maxLen = pack' maxLen n' cs + where n' = n + length c + pack' _ _ cs = cs + + longPath = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length is 255 ASCII characters.\n" + ++ "The file in question is:\n " ++ path + longName = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length for the name part (including " + ++ "extension) is 100 ASCII characters. The maximum length for any " + ++ "individual directory component is 155.\n" + ++ "The file in question is:\n " ++ path + noSplit = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. While the total length is less than 255 ASCII " + ++ "characters, there are unfortunately further restrictions. It has to " + ++ "be possible to split the file path on a directory separator into " + ++ "two parts such that the first part fits in 155 characters or less " + ++ "and the second part fits in 100 characters or less. Basically you " + ++ "have to make the file name or directory names shorter, or you could " + ++ "split a long directory name into nested subdirectories with shorter " + ++ "names.\nThe file in question is:\n " ++ path + emptyName = PackageDistInexcusable $ + "Encountered a file with an empty name, something is very wrong! " + ++ "Files with an empty name cannot be stored in a tar archive or in " + ++ "standard file systems." + +-- ------------------------------------------------------------ +-- * Utils +-- ------------------------------------------------------------ + +quote :: String -> String +quote s = "'" ++ s ++ "'" + +commaSep :: [String] -> String +commaSep = intercalate ", " + +dups :: Ord a => [a] -> [a] +dups xs = [ x | (x:_:_) <- group (sort xs) ] + +fileExtensionSupportedLanguage :: FilePath -> Bool +fileExtensionSupportedLanguage path = + isHaskell || isC + where + extension = takeExtension path + isHaskell = extension `elem` [".hs", ".lhs"] + isC = isJust (filenameCDialect extension) diff --git a/Distribution/PackageDescription/Configuration.hs b/Distribution/PackageDescription/Configuration.hs new file mode 100644 --- /dev/null +++ b/Distribution/PackageDescription/Configuration.hs @@ -0,0 +1,609 @@ +{-# LANGUAGE CPP #-} +-- -fno-warn-deprecations for use of Map.foldWithKey +{-# OPTIONS_GHC -fno-warn-deprecations #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Configuration +-- Copyright : Thomas Schilling, 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is about the cabal configurations feature. It exports +-- 'finalizePackageDescription' and 'flattenPackageDescription' which are +-- functions for converting 'GenericPackageDescription's down to +-- 'PackageDescription's. It has code for working with the tree of conditions +-- and resolving or flattening conditions. + +module Distribution.PackageDescription.Configuration ( + finalizePackageDescription, + flattenPackageDescription, + + -- Utils + parseCondition, + freeVars, + mapCondTree, + mapTreeData, + mapTreeConds, + mapTreeConstrs, + ) where + +import Distribution.Package + ( PackageName, Dependency(..) ) +import Distribution.PackageDescription + ( GenericPackageDescription(..), PackageDescription(..) + , Library(..), Executable(..), BuildInfo(..) + , Flag(..), FlagName(..), FlagAssignment + , Benchmark(..), CondTree(..), ConfVar(..), Condition(..) + , TestSuite(..) ) +import Distribution.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 Data.Char ( isAlphaNum ) +import Data.Maybe ( catMaybes, maybeToList ) +import Data.Map ( Map, fromListWith, toList ) +import qualified Data.Map as Map +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid +#endif + +------------------------------------------------------------------------------ + +-- | Simplify the condition and return its free variables. +simplifyCondition :: Condition c + -> (c -> Either d Bool) -- ^ (partial) variable assignment + -> (Condition d, [d]) +simplifyCondition cond i = fv . walk $ cond + where + walk cnd = case cnd of + Var v -> either Var Lit (i v) + Lit b -> Lit b + CNot c -> case walk c of + Lit True -> Lit False + Lit False -> Lit True + c' -> CNot c' + COr c d -> case (walk c, walk d) of + (Lit False, d') -> d' + (Lit True, _) -> Lit True + (c', Lit False) -> c' + (_, Lit True) -> Lit True + (c',d') -> COr c' d' + CAnd c d -> case (walk c, walk d) of + (Lit False, _) -> Lit False + (Lit True, d') -> d' + (_, Lit False) -> Lit False + (c', Lit True) -> c' + (c',d') -> CAnd c' d' + -- gather free vars + fv c = (c, fv' c) + fv' c = case c of + Var v -> [v] + Lit _ -> [] + CNot c' -> fv' c' + COr c1 c2 -> fv' c1 ++ fv' c2 + CAnd c1 c2 -> fv' c1 ++ fv' c2 + +-- | Simplify a configuration condition using the OS and arch names. Returns +-- the names of all the flags occurring in the condition. +simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar + -> (Condition FlagName, [FlagName]) +simplifyWithSysParams os arch cinfo cond = (cond', flags) + where + (cond', flags) = simplifyCondition cond interp + interp (OS os') = Right $ os' == os + interp (Arch arch') = Right $ arch' == arch + interp (Impl comp vr) + | matchImpl (compilerInfoId cinfo) = Right True + | otherwise = case compilerInfoCompat cinfo of + -- fixme: treat Nothing as unknown, rather than empty list once we + -- support partial resolution of system parameters + Nothing -> Right False + Just compat -> Right (any matchImpl compat) + where + matchImpl (CompilerId c v) = comp == c && v `withinRange` vr + interp (Flag f) = Left f + +-- TODO: Add instances and check +-- +-- prop_sC_idempotent cond a o = cond' == cond'' +-- where +-- cond' = simplifyCondition cond a o +-- cond'' = simplifyCondition cond' a o +-- +-- prop_sC_noLits cond a o = isLit res || not (hasLits res) +-- where +-- res = simplifyCondition cond a o +-- hasLits (Lit _) = True +-- hasLits (CNot c) = hasLits c +-- hasLits (COr l r) = hasLits l || hasLits r +-- hasLits (CAnd l r) = hasLits l || hasLits r +-- hasLits _ = False +-- + +-- | Parse a configuration condition from a string. +parseCondition :: ReadP r (Condition ConfVar) +parseCondition = condOr + where + condOr = sepBy1 condAnd (oper "||") >>= return . foldl1 COr + condAnd = sepBy1 cond (oper "&&")>>= return . foldl1 CAnd + cond = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond + +++ archCond +++ flagCond +++ implCond ) + inparens = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp) + notCond = ReadP.char '!' >> sp >> cond >>= return . CNot + osCond = string "os" >> sp >> inparens osIdent >>= return . Var + archCond = string "arch" >> sp >> inparens archIdent >>= return . Var + flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var + implCond = string "impl" >> sp >> inparens implIdent >>= return . Var + boolLiteral = fmap Lit parse + archIdent = fmap Arch parse + osIdent = fmap OS parse + flagIdent = fmap (Flag . FlagName . lowercase) (munch1 isIdentChar) + isIdentChar c = isAlphaNum c || c == '_' || c == '-' + oper s = sp >> string s >> sp + sp = skipSpaces + implIdent = do i <- parse + vr <- sp >> option anyVersion parse + return $ Impl i vr + +------------------------------------------------------------------------------ + +mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) + -> CondTree v c a -> CondTree w d b +mapCondTree fa fc fcnd (CondNode a c ifs) = + CondNode (fa a) (fc c) (map g ifs) + where + g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t, + fmap (mapCondTree fa fc fcnd) me) + +mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a +mapTreeConstrs f = mapCondTree id f id + +mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a +mapTreeConds f = mapCondTree id id f + +mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b +mapTreeData f = mapCondTree f id id + +-- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for +-- clarity. +data DepTestRslt d = DepOk | MissingDeps d + +instance Monoid d => Monoid (DepTestRslt d) where + mempty = DepOk + mappend DepOk x = x + mappend x DepOk = x + mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d') + + +data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree + + +-- | Try to find a flag assignment that satisfies the constraints of all trees. +-- +-- Returns either the missing dependencies, or a tuple containing the +-- resulting data, the associated dependencies, and the chosen flag +-- assignments. +-- +-- In case of failure, the _smallest_ number of of missing dependencies is +-- returned. [TODO: Could also be specified with a function argument.] +-- +-- TODO: The current algorithm is rather naive. A better approach would be to: +-- +-- * Rule out possible paths, by taking a look at the associated dependencies. +-- +-- * Infer the required values for the conditions of these paths, and +-- calculate the required domains for the variables used in these +-- conditions. Then picking a flag assignment would be linear (I guess). +-- +-- This would require some sort of SAT solving, though, thus it's not +-- implemented unless we really need it. +-- +resolveWithFlags :: + [(FlagName,[Bool])] + -- ^ Domain for each flag name, will be tested in order. + -> OS -- ^ OS as returned by Distribution.System.buildOS + -> Arch -- ^ Arch as returned by Distribution.System.buildArch + -> CompilerInfo -- ^ Compiler information + -> [Dependency] -- ^ Additional constraints + -> [CondTree ConfVar [Dependency] PDTagged] + -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function. + -> Either [Dependency] (TargetSet PDTagged, FlagAssignment) + -- ^ Either the missing dependencies (error case), or a pair of + -- (set of build targets with dependencies, chosen flag assignments) +resolveWithFlags dom os arch impl constrs trees checkDeps = + case try dom [] of + Right r -> Right r + Left dbt -> Left $ findShortest dbt + where + extraConstrs = toDepMap constrs + + -- simplify trees by (partially) evaluating all conditions and converting + -- dependencies to dependency maps. + simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps + . mapTreeConds (fst . simplifyWithSysParams os arch impl)) + trees + + -- @try@ recursively tries all possible flag assignments in the domain and + -- either succeeds or returns a binary tree with the missing dependencies + -- encountered in each run. Since the tree is constructed lazily, we + -- avoid some computation overhead in the successful case. + try [] flags = + let targetSet = TargetSet $ flip map simplifiedTrees $ + -- apply additional constraints to all dependencies + first (`constrainBy` extraConstrs) . + simplifyCondTree (env flags) + deps = overallDependencies targetSet + in case checkDeps (fromDepMap deps) of + DepOk -> Right (targetSet, flags) + MissingDeps mds -> Left (BTN mds) + + try ((n, vals):rest) flags = + tryAll $ map (\v -> try rest ((n, v):flags)) vals + + tryAll = foldr mp mz + + -- special version of `mplus' for our local purposes + mp (Left xs) (Left ys) = (Left (BTB xs ys)) + mp (Left _) m@(Right _) = m + mp m@(Right _) _ = m + + -- `mzero' + mz = Left (BTN []) + + env flags flag = (maybe (Left flag) Right . lookup flag) flags + + -- for the error case we inspect our lazy tree of missing dependencies and + -- pick the shortest list of missing dependencies + findShortest (BTN x) = x + findShortest (BTB lt rt) = + let l = findShortest lt + r = findShortest rt + in case (l,r) of + ([], xs) -> xs -- [] is too short + (xs, []) -> xs + ([x], _) -> [x] -- single elem is optimum + (_, [x]) -> [x] + (xs, ys) -> if lazyLengthCmp xs ys + then xs else ys + -- lazy variant of @\xs ys -> length xs <= length ys@ + lazyLengthCmp [] _ = True + lazyLengthCmp _ [] = False + lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys + +-- | A map of dependencies. Newtyped since the default monoid instance is not +-- appropriate. The monoid instance uses 'intersectVersionRanges'. +newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName VersionRange } + deriving (Show, Read) + +instance Monoid DependencyMap where + mempty = DependencyMap Map.empty + (DependencyMap a) `mappend` (DependencyMap b) = + DependencyMap (Map.unionWith intersectVersionRanges a b) + +toDepMap :: [Dependency] -> DependencyMap +toDepMap ds = + DependencyMap $ fromListWith intersectVersionRanges [ (p,vr) | Dependency p vr <- ds ] + +fromDepMap :: DependencyMap -> [Dependency] +fromDepMap m = [ Dependency p vr | (p,vr) <- toList (unDependencyMap m) ] + +simplifyCondTree :: (Monoid a, Monoid d) => + (v -> Either v Bool) + -> CondTree v d a + -> (d, a) +simplifyCondTree env (CondNode a d ifs) = + mconcat $ (d, a) : catMaybes (map simplifyIf ifs) + where + simplifyIf (cnd, t, me) = + case simplifyCondition cnd env of + (Lit True, _) -> Just $ simplifyCondTree env t + (Lit False, _) -> fmap (simplifyCondTree env) me + _ -> error $ "Environment not defined for all free vars" + +-- | Flatten a CondTree. This will resolve the CondTree by taking all +-- possible paths into account. Note that since branches represent exclusive +-- choices this may not result in a \"sane\" result. +ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c) +ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs) + where f (_, t, me) = ignoreConditions t + : maybeToList (fmap ignoreConditions me) + +freeVars :: CondTree ConfVar c a -> [FlagName] +freeVars t = [ f | Flag f <- freeVars' t ] + where + freeVars' (CondNode _ _ ifs) = concatMap compfv ifs + compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct + condfv c = case c of + Var v -> [v] + Lit _ -> [] + CNot c' -> condfv c' + COr c1 c2 -> condfv c1 ++ condfv c2 + CAnd c1 c2 -> condfv c1 ++ condfv c2 + + +------------------------------------------------------------------------------ + +-- | A set of targets with their package dependencies +newtype TargetSet a = TargetSet [(DependencyMap, a)] + +-- | Combine the target-specific dependencies in a TargetSet to give the +-- dependencies for the package as a whole. +overallDependencies :: TargetSet PDTagged -> DependencyMap +overallDependencies (TargetSet targets) = mconcat depss + where + (depss, _) = unzip $ filter (removeDisabledSections . snd) targets + removeDisabledSections :: PDTagged -> Bool + removeDisabledSections (Lib _) = True + removeDisabledSections (Exe _ _) = True + removeDisabledSections (Test _ t) = testEnabled t + removeDisabledSections (Bench _ b) = benchmarkEnabled b + removeDisabledSections PDNull = True + +-- Apply extra constraints to a dependency map. +-- Combines dependencies where the result will only contain keys from the left +-- (first) map. If a key also exists in the right map, both constraints will +-- be intersected. +constrainBy :: DependencyMap -- ^ Input map + -> DependencyMap -- ^ Extra constraints + -> DependencyMap +constrainBy left extra = + DependencyMap $ + Map.foldWithKey tightenConstraint (unDependencyMap left) + (unDependencyMap extra) + where tightenConstraint n c l = + case Map.lookup n l of + Nothing -> l + Just vr -> Map.insert n (intersectVersionRanges vr c) l + +-- | Collect up the targets in a TargetSet of tagged targets, storing the +-- dependencies as we go. +flattenTaggedTargets :: TargetSet PDTagged -> + (Maybe Library, [(String, Executable)], [(String, TestSuite)] + , [(String, Benchmark)]) +flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], []) targets + where + untag (_, Lib _) (Just _, _, _, _) = userBug "Only one library expected" + untag (deps, Lib l) (Nothing, exes, tests, bms) = + (Just l', exes, tests, bms) + where + l' = l { + libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps } + } + untag (deps, Exe n e) (mlib, exes, tests, bms) + | any ((== n) . fst) exes = + userBug $ "There exist several exes with the same name: '" ++ n ++ "'" + | any ((== n) . fst) tests = + userBug $ "There exists a test with the same name as an exe: '" ++ n ++ "'" + | any ((== n) . fst) bms = + userBug $ "There exists a benchmark with the same name as an exe: '" ++ n ++ "'" + | otherwise = (mlib, (n, e'):exes, tests, bms) + where + e' = e { + buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps } + } + untag (deps, Test n t) (mlib, exes, tests, bms) + | any ((== n) . fst) tests = + userBug $ "There exist several tests with the same name: '" ++ n ++ "'" + | any ((== n) . fst) exes = + userBug $ "There exists an exe with the same name as the test: '" ++ n ++ "'" + | any ((== n) . fst) bms = + userBug $ "There exists a benchmark with the same name as the test: '" ++ n ++ "'" + | otherwise = (mlib, exes, (n, t'):tests, bms) + where + t' = t { + testBuildInfo = (testBuildInfo t) + { targetBuildDepends = fromDepMap deps } + } + untag (deps, Bench n b) (mlib, exes, tests, bms) + | any ((== n) . fst) bms = + userBug $ "There exist several benchmarks with the same name: '" ++ n ++ "'" + | any ((== n) . fst) exes = + userBug $ "There exists an exe with the same name as the benchmark: '" ++ n ++ "'" + | any ((== n) . fst) tests = + userBug $ "There exists a test with the same name as the benchmark: '" ++ n ++ "'" + | otherwise = (mlib, exes, tests, (n, b'):bms) + where + b' = b { + benchmarkBuildInfo = (benchmarkBuildInfo b) + { targetBuildDepends = fromDepMap deps } + } + untag (_, PDNull) x = x -- actually this should not happen, but let's be liberal + + +------------------------------------------------------------------------------ +-- Convert GenericPackageDescription to PackageDescription +-- + +data PDTagged = Lib Library + | Exe String Executable + | Test String TestSuite + | Bench String Benchmark + | PDNull + deriving Show + +instance Monoid PDTagged where + mempty = PDNull + PDNull `mappend` x = x + x `mappend` PDNull = x + Lib l `mappend` Lib l' = Lib (l `mappend` l') + Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e') + Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t') + Bench n b `mappend` Bench n' b' | n == n' = Bench n (b `mappend` b') + _ `mappend` _ = cabalBug "Cannot combine incompatible tags" + +-- | Create a package description with all configurations resolved. +-- +-- This function takes a `GenericPackageDescription` and several environment +-- parameters and tries to generate `PackageDescription` by finding a flag +-- assignment that result in satisfiable dependencies. +-- +-- It takes as inputs a not necessarily complete specifications of flags +-- assignments, an optional package index as well as platform parameters. If +-- some flags are not assigned explicitly, this function will try to pick an +-- assignment that causes this function to succeed. The package index is +-- optional since on some platforms we cannot determine which packages have +-- been installed before. When no package index is supplied, every dependency +-- is assumed to be satisfiable, therefore all not explicitly assigned flags +-- will get their default values. +-- +-- This function will fail if it cannot find a flag assignment that leads to +-- satisfiable dependencies. (It will not try alternative assignments for +-- explicitly specified flags.) In case of failure it will return a /minimum/ +-- number of dependencies that could not be satisfied. On success, it will +-- return the package description and the full flag assignment chosen. +-- +finalizePackageDescription :: + FlagAssignment -- ^ Explicitly specified flag assignments + -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of + -- available packages? If this is unknown then use + -- True. + -> Platform -- ^ The 'Arch' and 'OS' + -> CompilerInfo -- ^ Compiler information + -> [Dependency] -- ^ Additional constraints + -> GenericPackageDescription + -> Either [Dependency] + (PackageDescription, FlagAssignment) + -- ^ Either missing dependencies or the resolved package + -- description along with the flag assignments chosen. +finalizePackageDescription userflags satisfyDep + (Platform arch os) impl constraints + (GenericPackageDescription pkg flags mlib0 exes0 tests0 bms0) = + case resolveFlags of + Right ((mlib, exes', tests', bms'), targetSet, flagVals) -> + Right ( pkg { library = mlib + , executables = exes' + , testSuites = tests' + , benchmarks = bms' + , buildDepends = fromDepMap (overallDependencies targetSet) + --TODO: we need to find a way to avoid pulling in deps + -- for non-buildable components. However cannot simply + -- filter at this stage, since if the package were not + -- available we would have failed already. + } + , flagVals ) + + Left missing -> Left missing + where + -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data + condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 ) + ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0 + ++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0 + ++ map (\(name,tree) -> mapTreeData (Bench name) tree) bms0 + + resolveFlags = + case resolveWithFlags flagChoices os arch impl constraints condTrees check of + Right (targetSet, fs) -> + let (mlib, exes, tests, bms) = flattenTaggedTargets targetSet in + Right ( (fmap libFillInDefaults mlib, + map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes, + map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests, + map (\(n,b) -> (benchFillInDefaults b) { benchmarkName = n }) bms), + targetSet, fs) + Left missing -> Left missing + + flagChoices = map (\(MkFlag n _ d manual) -> (n, d2c manual n d)) flags + d2c manual n b = case lookup n userflags of + Just val -> [val] + Nothing + | manual -> [b] + | otherwise -> [b, not b] + --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices + check ds = let missingDeps = filter (not . satisfyDep) ds + in if null missingDeps + then DepOk + else MissingDeps missingDeps + +{- +let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] []) +let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] []) + +let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])] +let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index +let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds +resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks ===> Right ... +resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks ===> Left ... +-} + +-- | Flatten a generic package description by ignoring all conditions and just +-- join the field descriptors into on package description. Note, however, +-- that this may lead to inconsistent field values, since all values are +-- joined into one field, which may not be possible in the original package +-- description, due to the use of exclusive choices (if ... else ...). +-- +-- TODO: One particularly tricky case is defaulting. In the original package +-- description, e.g., the source directory might either be the default or a +-- certain, explicitly set path. Since defaults are filled in only after the +-- package has been resolved and when no explicit value has been set, the +-- default path will be missing from the package description returned by this +-- function. +flattenPackageDescription :: GenericPackageDescription -> PackageDescription +flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0 bms0) = + pkg { library = mlib + , executables = reverse exes + , testSuites = reverse tests + , benchmarks = reverse bms + , buildDepends = ldeps ++ reverse edeps ++ reverse tdeps ++ reverse bdeps + } + where + (mlib, ldeps) = case mlib0 of + Just lib -> let (l,ds) = ignoreConditions lib in + (Just (libFillInDefaults l), ds) + Nothing -> (Nothing, []) + (exes, edeps) = foldr flattenExe ([],[]) exes0 + (tests, tdeps) = foldr flattenTst ([],[]) tests0 + (bms, bdeps) = foldr flattenBm ([],[]) bms0 + flattenExe (n, t) (es, ds) = + let (e, ds') = ignoreConditions t in + ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds ) + flattenTst (n, t) (es, ds) = + let (e, ds') = ignoreConditions t in + ( (testFillInDefaults $ e { testName = n }) : es, ds' ++ ds ) + flattenBm (n, t) (es, ds) = + let (e, ds') = ignoreConditions t in + ( (benchFillInDefaults $ e { benchmarkName = n }) : es, ds' ++ ds ) + +-- This is in fact rather a hack. The original version just overrode the +-- default values, however, when adding conditions we had to switch to a +-- modifier-based approach. There, nothing is ever overwritten, but only +-- joined together. +-- +-- This is the cleanest way i could think of, that doesn't require +-- changing all field parsing functions to return modifiers instead. +libFillInDefaults :: Library -> Library +libFillInDefaults lib@(Library { libBuildInfo = bi }) = + lib { libBuildInfo = biFillInDefaults bi } + +exeFillInDefaults :: Executable -> Executable +exeFillInDefaults exe@(Executable { buildInfo = bi }) = + exe { buildInfo = biFillInDefaults bi } + +testFillInDefaults :: TestSuite -> TestSuite +testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) = + tst { testBuildInfo = biFillInDefaults bi } + +benchFillInDefaults :: Benchmark -> Benchmark +benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) = + bm { benchmarkBuildInfo = biFillInDefaults bi } + +biFillInDefaults :: BuildInfo -> BuildInfo +biFillInDefaults bi = + if null (hsSourceDirs bi) + then bi { hsSourceDirs = [currentDir] } + else bi diff --git a/Distribution/PackageDescription/Parse.hs b/Distribution/PackageDescription/Parse.hs new file mode 100644 --- /dev/null +++ b/Distribution/PackageDescription/Parse.hs @@ -0,0 +1,1282 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Parse +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defined parsers and partial pretty printers for the @.cabal@ format. +-- Some of the complexity in this module is due to the fact that we have to be +-- backwards compatible with old @.cabal@ files, so there's code to translate +-- into the newer structure. + +module Distribution.PackageDescription.Parse ( + -- * Package descriptions + readPackageDescription, + writePackageDescription, + parsePackageDescription, + showPackageDescription, + + -- ** Parsing + ParseResult(..), + FieldDescr(..), + LineNo, + + -- ** Supplementary build information + readHookedBuildInfo, + parseHookedBuildInfo, + writeHookedBuildInfo, + showHookedBuildInfo, + + pkgDescrFieldDescrs, + libFieldDescrs, + executableFieldDescrs, + binfoFieldDescrs, + sourceRepoFieldDescrs, + testSuiteFieldDescrs, + flagFieldDescrs + ) where + +import Data.Char (isSpace) +import Data.Maybe (listToMaybe, isJust) +import Data.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 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 + +pkgDescrFieldDescrs :: [FieldDescr PackageDescription] +pkgDescrFieldDescrs = + [ simpleField "name" + disp parse + packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}}) + , simpleField "version" + disp parse + packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) + , simpleField "cabal-version" + (either disp disp) (liftM Left parse +++ liftM Right parse) + specVersionRaw (\v pkg -> pkg{specVersionRaw=v}) + , simpleField "build-type" + (maybe empty disp) (fmap Just parse) + buildType (\t pkg -> pkg{buildType=t}) + , simpleField "license" + disp parseLicenseQ + license (\l pkg -> pkg{license=l}) + -- We have both 'license-file' and 'license-files' fields. + -- Rather than declaring license-file to be deprecated, we will continue + -- to allow both. The 'license-file' will continue to only allow single + -- tokens, while 'license-files' allows multiple. On pretty-printing, we + -- will use 'license-file' if there's just one, and use 'license-files' + -- otherwise. + , simpleField "license-file" + showFilePath parseFilePathQ + (\pkg -> case licenseFiles pkg of + [x] -> x + _ -> "") + (\l pkg -> pkg{licenseFiles=licenseFiles pkg ++ [l]}) + , listField "license-files" + showFilePath parseFilePathQ + (\pkg -> case licenseFiles pkg of + [_] -> [] + xs -> xs) + (\ls pkg -> pkg{licenseFiles=ls}) + , simpleField "copyright" + showFreeText parseFreeText + copyright (\val pkg -> pkg{copyright=val}) + , simpleField "maintainer" + showFreeText parseFreeText + maintainer (\val pkg -> pkg{maintainer=val}) + , simpleField "stability" + showFreeText parseFreeText + stability (\val pkg -> pkg{stability=val}) + , simpleField "homepage" + showFreeText parseFreeText + homepage (\val pkg -> pkg{homepage=val}) + , simpleField "package-url" + showFreeText parseFreeText + pkgUrl (\val pkg -> pkg{pkgUrl=val}) + , simpleField "bug-reports" + showFreeText parseFreeText + bugReports (\val pkg -> pkg{bugReports=val}) + , simpleField "synopsis" + showFreeText parseFreeText + synopsis (\val pkg -> pkg{synopsis=val}) + , simpleField "description" + showFreeText parseFreeText + description (\val pkg -> pkg{description=val}) + , simpleField "category" + showFreeText parseFreeText + category (\val pkg -> pkg{category=val}) + , simpleField "author" + showFreeText parseFreeText + author (\val pkg -> pkg{author=val}) + , listField "tested-with" + showTestedWith parseTestedWithQ + testedWith (\val pkg -> pkg{testedWith=val}) + , listFieldWithSep vcat "data-files" + showFilePath parseFilePathQ + dataFiles (\val pkg -> pkg{dataFiles=val}) + , simpleField "data-dir" + showFilePath parseFilePathQ + dataDir (\val pkg -> pkg{dataDir=val}) + , listFieldWithSep vcat "extra-source-files" + showFilePath parseFilePathQ + extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val}) + , listFieldWithSep vcat "extra-tmp-files" + showFilePath parseFilePathQ + extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val}) + , listFieldWithSep vcat "extra-doc-files" + showFilePath parseFilePathQ + extraDocFiles (\val pkg -> pkg{extraDocFiles=val}) + ] + +-- | Store any fields beginning with "x-" in the customFields field of +-- a PackageDescription. All other fields will generate a warning. +storeXFieldsPD :: UnrecFieldParser PackageDescription +storeXFieldsPD (f@('x':'-':_),val) pkg = + Just pkg{ customFieldsPD = + customFieldsPD pkg ++ [(f,val)]} +storeXFieldsPD _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The Library type + +libFieldDescrs :: [FieldDescr Library] +libFieldDescrs = + [ listFieldWithSep vcat "exposed-modules" disp parseModuleNameQ + exposedModules (\mods lib -> lib{exposedModules=mods}) + + , commaListFieldWithSep vcat "reexported-modules" disp parse + reexportedModules (\mods lib -> lib{reexportedModules=mods}) + + , listFieldWithSep vcat "required-signatures" disp parseModuleNameQ + requiredSignatures (\mods lib -> lib{requiredSignatures=mods}) + + , listFieldWithSep vcat "exposed-signatures" disp parseModuleNameQ + exposedSignatures (\mods lib -> lib{exposedSignatures=mods}) + + , boolField "exposed" + libExposed (\val lib -> lib{libExposed=val}) + ] ++ map biToLib binfoFieldDescrs + where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi}) + +storeXFieldsLib :: UnrecFieldParser Library +storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) = + Just $ l {libBuildInfo = + bi{ customFieldsBI = customFieldsBI bi ++ [(f,val)]}} +storeXFieldsLib _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The Executable type + + +executableFieldDescrs :: [FieldDescr Executable] +executableFieldDescrs = + [ -- note ordering: configuration must come first, for + -- showPackageDescription. + simpleField "executable" + showToken parseTokenQ + exeName (\xs exe -> exe{exeName=xs}) + , simpleField "main-is" + showFilePath parseFilePathQ + modulePath (\xs exe -> exe{modulePath=xs}) + ] + ++ map biToExe binfoFieldDescrs + where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi}) + +storeXFieldsExe :: UnrecFieldParser Executable +storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) = + Just $ e {buildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}} +storeXFieldsExe _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The TestSuite type + +-- | An intermediate type just used for parsing the test-suite stanza. +-- After validation it is converted into the proper 'TestSuite' type. +data TestSuiteStanza = TestSuiteStanza { + testStanzaTestType :: Maybe TestType, + testStanzaMainIs :: Maybe FilePath, + testStanzaTestModule :: Maybe ModuleName, + testStanzaBuildInfo :: BuildInfo + } + +emptyTestStanza :: TestSuiteStanza +emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty + +testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza] +testSuiteFieldDescrs = + [ simpleField "type" + (maybe empty disp) (fmap Just parse) + testStanzaTestType (\x suite -> suite { testStanzaTestType = x }) + , simpleField "main-is" + (maybe empty showFilePath) (fmap Just parseFilePathQ) + testStanzaMainIs (\x suite -> suite { testStanzaMainIs = x }) + , simpleField "test-module" + (maybe empty disp) (fmap Just parseModuleNameQ) + testStanzaTestModule (\x suite -> suite { testStanzaTestModule = x }) + ] + ++ map biToTest binfoFieldDescrs + where + biToTest = liftField testStanzaBuildInfo + (\bi suite -> suite { testStanzaBuildInfo = bi }) + +storeXFieldsTest :: UnrecFieldParser TestSuiteStanza +storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) = + Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}} +storeXFieldsTest _ _ = Nothing + +validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite +validateTestSuite line stanza = + case testStanzaTestType stanza of + Nothing -> return $ + emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza } + + Just tt@(TestTypeUnknown _ _) -> + return emptyTestSuite { + testInterface = TestSuiteUnsupported tt, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt | tt `notElem` knownTestTypes -> + return emptyTestSuite { + testInterface = TestSuiteUnsupported tt, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt@(TestTypeExe ver) -> + case testStanzaMainIs stanza of + Nothing -> syntaxError line (missingField "main-is" tt) + Just file -> do + when (isJust (testStanzaTestModule stanza)) $ + warning (extraField "test-module" tt) + return emptyTestSuite { + testInterface = TestSuiteExeV10 ver file, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt@(TestTypeLib ver) -> + case testStanzaTestModule stanza of + Nothing -> syntaxError line (missingField "test-module" tt) + Just module_ -> do + when (isJust (testStanzaMainIs stanza)) $ + warning (extraField "main-is" tt) + return emptyTestSuite { + testInterface = TestSuiteLibV09 ver module_, + testBuildInfo = testStanzaBuildInfo stanza + } + + where + missingField name tt = "The '" ++ name ++ "' field is required for the " + ++ display tt ++ " test suite type." + + extraField name tt = "The '" ++ name ++ "' field is not used for the '" + ++ display tt ++ "' test suite type." + + +-- --------------------------------------------------------------------------- +-- The Benchmark type + +-- | An intermediate type just used for parsing the benchmark stanza. +-- After validation it is converted into the proper 'Benchmark' type. +data BenchmarkStanza = BenchmarkStanza { + benchmarkStanzaBenchmarkType :: Maybe BenchmarkType, + benchmarkStanzaMainIs :: Maybe FilePath, + benchmarkStanzaBenchmarkModule :: Maybe ModuleName, + benchmarkStanzaBuildInfo :: BuildInfo + } + +emptyBenchmarkStanza :: BenchmarkStanza +emptyBenchmarkStanza = BenchmarkStanza Nothing Nothing Nothing mempty + +benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza] +benchmarkFieldDescrs = + [ simpleField "type" + (maybe empty disp) (fmap Just parse) + benchmarkStanzaBenchmarkType + (\x suite -> suite { benchmarkStanzaBenchmarkType = x }) + , simpleField "main-is" + (maybe empty showFilePath) (fmap Just parseFilePathQ) + benchmarkStanzaMainIs + (\x suite -> suite { benchmarkStanzaMainIs = x }) + ] + ++ map biToBenchmark binfoFieldDescrs + where + biToBenchmark = liftField benchmarkStanzaBuildInfo + (\bi suite -> suite { benchmarkStanzaBuildInfo = bi }) + +storeXFieldsBenchmark :: UnrecFieldParser BenchmarkStanza +storeXFieldsBenchmark (f@('x':'-':_), val) + t@(BenchmarkStanza { benchmarkStanzaBuildInfo = bi }) = + Just $ t {benchmarkStanzaBuildInfo = + bi{ customFieldsBI = (f,val):customFieldsBI bi}} +storeXFieldsBenchmark _ _ = Nothing + +validateBenchmark :: LineNo -> BenchmarkStanza -> ParseResult Benchmark +validateBenchmark line stanza = + case benchmarkStanzaBenchmarkType stanza of + Nothing -> return $ + emptyBenchmark { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza } + + Just tt@(BenchmarkTypeUnknown _ _) -> + return emptyBenchmark { + benchmarkInterface = BenchmarkUnsupported tt, + benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza + } + + Just tt | tt `notElem` knownBenchmarkTypes -> + return emptyBenchmark { + benchmarkInterface = BenchmarkUnsupported tt, + benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza + } + + Just tt@(BenchmarkTypeExe ver) -> + case benchmarkStanzaMainIs stanza of + Nothing -> syntaxError line (missingField "main-is" tt) + Just file -> do + when (isJust (benchmarkStanzaBenchmarkModule stanza)) $ + warning (extraField "benchmark-module" tt) + return emptyBenchmark { + benchmarkInterface = BenchmarkExeV10 ver file, + benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza + } + + where + missingField name tt = "The '" ++ name ++ "' field is required for the " + ++ display tt ++ " benchmark type." + + extraField name tt = "The '" ++ name ++ "' field is not used for the '" + ++ display tt ++ "' benchmark type." + +-- --------------------------------------------------------------------------- +-- The BuildInfo type + + +binfoFieldDescrs :: [FieldDescr BuildInfo] +binfoFieldDescrs = + [ boolField "buildable" + buildable (\val binfo -> binfo{buildable=val}) + , commaListField "build-tools" + disp parseBuildTool + buildTools (\xs binfo -> binfo{buildTools=xs}) + , commaListFieldWithSep vcat "build-depends" + disp parse + buildDependsWithRenaming + setBuildDependsWithRenaming + , spaceListField "cpp-options" + showToken parseTokenQ' + cppOptions (\val binfo -> binfo{cppOptions=val}) + , spaceListField "cc-options" + showToken parseTokenQ' + ccOptions (\val binfo -> binfo{ccOptions=val}) + , spaceListField "ld-options" + showToken parseTokenQ' + ldOptions (\val binfo -> binfo{ldOptions=val}) + , commaListField "pkgconfig-depends" + disp parsePkgconfigDependency + pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs}) + , listField "frameworks" + showToken parseTokenQ + frameworks (\val binfo -> binfo{frameworks=val}) + , listFieldWithSep vcat "c-sources" + showFilePath parseFilePathQ + cSources (\paths binfo -> binfo{cSources=paths}) + , listFieldWithSep vcat "js-sources" + showFilePath parseFilePathQ + jsSources (\paths binfo -> binfo{jsSources=paths}) + , simpleField "default-language" + (maybe empty disp) (option Nothing (fmap Just parseLanguageQ)) + defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang}) + , listField "other-languages" + disp parseLanguageQ + otherLanguages (\langs binfo -> binfo{otherLanguages=langs}) + , listField "default-extensions" + disp parseExtensionQ + defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts}) + , listField "other-extensions" + disp parseExtensionQ + otherExtensions (\exts binfo -> binfo{otherExtensions=exts}) + , listField "extensions" + disp parseExtensionQ + oldExtensions (\exts binfo -> binfo{oldExtensions=exts}) + + , listFieldWithSep vcat "extra-libraries" + showToken parseTokenQ + extraLibs (\xs binfo -> binfo{extraLibs=xs}) + , listFieldWithSep vcat "extra-ghci-libraries" + showToken parseTokenQ + extraGHCiLibs (\xs binfo -> binfo{extraGHCiLibs=xs}) + , listField "extra-lib-dirs" + showFilePath parseFilePathQ + extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs}) + , listFieldWithSep vcat "includes" + showFilePath parseFilePathQ + includes (\paths binfo -> binfo{includes=paths}) + , listFieldWithSep vcat "install-includes" + showFilePath parseFilePathQ + installIncludes (\paths binfo -> binfo{installIncludes=paths}) + , listField "include-dirs" + showFilePath parseFilePathQ + includeDirs (\paths binfo -> binfo{includeDirs=paths}) + , listField "hs-source-dirs" + showFilePath parseFilePathQ + hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths}) + , listFieldWithSep vcat "other-modules" + disp parseModuleNameQ + otherModules (\val binfo -> binfo{otherModules=val}) + , optsField "ghc-prof-options" GHC + profOptions (\val binfo -> binfo{profOptions=val}) + , optsField "ghcjs-prof-options" GHCJS + profOptions (\val binfo -> binfo{profOptions=val}) + , optsField "ghc-shared-options" GHC + sharedOptions (\val binfo -> binfo{sharedOptions=val}) + , optsField "ghcjs-shared-options" GHCJS + sharedOptions (\val binfo -> binfo{sharedOptions=val}) + , optsField "ghc-options" GHC + options (\path binfo -> binfo{options=path}) + , optsField "ghcjs-options" GHCJS + options (\path binfo -> binfo{options=path}) + , optsField "jhc-options" JHC + options (\path binfo -> binfo{options=path}) + + -- NOTE: Hugs and NHC are not supported anymore, but these fields are kept + -- around for backwards compatibility. + , optsField "hugs-options" Hugs + options (const id) + , optsField "nhc98-options" NHC + options (const id) + ] + +storeXFieldsBI :: UnrecFieldParser BuildInfo +storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):customFieldsBI bi } +storeXFieldsBI _ _ = Nothing + +------------------------------------------------------------------------------ + +flagFieldDescrs :: [FieldDescr Flag] +flagFieldDescrs = + [ simpleField "description" + showFreeText parseFreeText + flagDescription (\val fl -> fl{ flagDescription = val }) + , boolField "default" + flagDefault (\val fl -> fl{ flagDefault = val }) + , boolField "manual" + flagManual (\val fl -> fl{ flagManual = val }) + ] + +------------------------------------------------------------------------------ + +sourceRepoFieldDescrs :: [FieldDescr SourceRepo] +sourceRepoFieldDescrs = + [ simpleField "type" + (maybe empty disp) (fmap Just parse) + repoType (\val repo -> repo { repoType = val }) + , simpleField "location" + (maybe empty showFreeText) (fmap Just parseFreeText) + repoLocation (\val repo -> repo { repoLocation = val }) + , simpleField "module" + (maybe empty showToken) (fmap Just parseTokenQ) + repoModule (\val repo -> repo { repoModule = val }) + , simpleField "branch" + (maybe empty showToken) (fmap Just parseTokenQ) + repoBranch (\val repo -> repo { repoBranch = val }) + , simpleField "tag" + (maybe empty showToken) (fmap Just parseTokenQ) + repoTag (\val repo -> repo { repoTag = val }) + , simpleField "subdir" + (maybe empty showFilePath) (fmap Just parseFilePathQ) + repoSubdir (\val repo -> repo { repoSubdir = val }) + ] + +-- --------------------------------------------------------------- +-- Parsing + +-- | Given a parser and a filename, return the parse of the file, +-- after checking if the file exists. +readAndParseFile :: (FilePath -> (String -> IO a) -> IO a) + -> (String -> ParseResult a) + -> Verbosity + -> FilePath -> IO a +readAndParseFile withFileContents' parser verbosity fpath = do + exists <- doesFileExist fpath + unless exists + (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.") + withFileContents' fpath $ \str -> case parser str of + ParseFailed e -> do + let (line, message) = locatedErrorMsg e + dieWithLocation fpath line message + ParseOk warnings x -> do + mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings + return x + +readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo +readHookedBuildInfo = + readAndParseFile withFileContents parseHookedBuildInfo + +-- |Parse the given package file. +readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription +readPackageDescription = + readAndParseFile withUTF8FileContents parsePackageDescription + +stanzas :: [Field] -> [[Field]] +stanzas [] = [] +stanzas (f:fields) = (f:this) : stanzas rest + where + (this, rest) = break isStanzaHeader fields + +isStanzaHeader :: Field -> Bool +isStanzaHeader (F _ f _) = f == "executable" +isStanzaHeader _ = False + +------------------------------------------------------------------------------ + + +mapSimpleFields :: (Field -> ParseResult Field) -> [Field] + -> ParseResult [Field] +mapSimpleFields f = mapM walk + where + walk fld@F{} = f fld + walk (IfBlock l c fs1 fs2) = do + fs1' <- mapM walk fs1 + fs2' <- mapM walk fs2 + return (IfBlock l c fs1' fs2') + walk (Section ln n l fs1) = do + fs1' <- mapM walk fs1 + return (Section ln n l fs1') + +-- prop_isMapM fs = mapSimpleFields return fs == return fs + + +-- names of fields that represents dependencies, thus consrca +constraintFieldNames :: [String] +constraintFieldNames = ["build-depends"] + +-- Possible refactoring would be to have modifiers be explicit about what +-- they add and define an accessor that specifies what the dependencies +-- are. This way we would completely reuse the parsing knowledge from the +-- field descriptor. +parseConstraint :: Field -> ParseResult [DependencyWithRenaming] +parseConstraint (F l n v) + | n == "build-depends" = runP l n (parseCommaList parse) v +parseConstraint f = userBug $ "Constraint was expected (got: " ++ show f ++ ")" + +{- +headerFieldNames :: [String] +headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames)) + . map fieldName $ pkgDescrFieldDescrs +-} + +libFieldNames :: [String] +libFieldNames = map fieldName libFieldDescrs + ++ buildInfoNames ++ constraintFieldNames + +-- exeFieldNames :: [String] +-- exeFieldNames = map fieldName executableFieldDescrs +-- ++ buildInfoNames + +buildInfoNames :: [String] +buildInfoNames = map fieldName binfoFieldDescrs + ++ map fst deprecatedFieldsBuildInfo + +-- A minimal implementation of the StateT monad transformer to avoid depending +-- on the 'mtl' package. +newtype StT s m a = StT { runStT :: s -> m (a,s) } + +instance 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 +#endif + pure = return + (<*>) = ap + + +instance Monad m => Monad (StT s m) where + return a = StT (\s -> return (a,s)) + StT f >>= g = StT $ \s -> do + (a,s') <- f s + runStT (g a) s' + +get :: Monad m => StT s m s +get = StT $ \s -> return (s, s) + +modify :: Monad m => (s -> s) -> StT s m () +modify f = StT $ \s -> return ((),f s) + +lift :: Monad m => m a -> StT s m a +lift m = StT $ \s -> m >>= \a -> return (a,s) + +evalStT :: Monad m => StT s m a -> s -> m a +evalStT st s = liftM fst $ runStT st s + +-- Our monad for parsing a list/tree of fields. +-- +-- The state represents the remaining fields to be processed. +type PM a = StT [Field] ParseResult a + + + +-- return look-ahead field or nothing if we're at the end of the file +peekField :: PM (Maybe Field) +peekField = liftM listToMaybe get + +-- Unconditionally discard the first field in our state. Will error when it +-- reaches end of file. (Yes, that's evil.) +skipField :: PM () +skipField = modify tail + +--FIXME: this should take a ByteString, not a String. We have to be able to +-- decode UTF8 and handle the BOM. + +-- | Parses the given file into a 'GenericPackageDescription'. +-- +-- In Cabal 1.2 the syntax for package descriptions was changed to a format +-- with sections and possibly indented property descriptions. +parsePackageDescription :: String -> ParseResult GenericPackageDescription +parsePackageDescription file = do + + -- This function is quite complex because it needs to be able to parse + -- both pre-Cabal-1.2 and post-Cabal-1.2 files. Additionally, it contains + -- a lot of parser-related noise since we do not want to depend on Parsec. + -- + -- If we detect an pre-1.2 file we implicitly convert it to post-1.2 + -- style. See 'sectionizeFields' below for details about the conversion. + + fields0 <- readFields file `catchParseError` \err -> + let tabs = findIndentTabs file in + case err of + -- In case of a TabsError report them all at once. + TabsError tabLineNo -> reportTabsError + -- but only report the ones including and following + -- the one that caused the actual error + [ t | t@(lineNo',_) <- tabs + , lineNo' >= tabLineNo ] + _ -> parseFail err + + let cabalVersionNeeded = + head $ [ minVersionBound versionRange + | Just versionRange <- [ simpleParse v + | F _ "cabal-version" v <- fields0 ] ] + ++ [Version [0] []] + minVersionBound versionRange = + case asVersionIntervals versionRange of + [] -> Version [0] [] + ((LowerBound version _, _):_) -> version + + handleFutureVersionParseFailure cabalVersionNeeded $ do + + let sf = sectionizeFields fields0 -- ensure 1.2 format + + -- figure out and warn about deprecated stuff (warnings are collected + -- inside our parsing monad) + fields <- mapSimpleFields deprecField sf + + -- Our parsing monad takes the not-yet-parsed fields as its state. + -- After each successful parse we remove the field from the state + -- ('skipField') and move on to the next one. + -- + -- Things are complicated a bit, because fields take a tree-like + -- structure -- they can be sections or "if"/"else" conditionals. + + flip evalStT fields $ do + + -- The header consists of all simple fields up to the first section + -- (flag, library, executable). + header_fields <- getHeader [] + + -- Parses just the header fields and stores them in a + -- 'PackageDescription'. Note that our final result is a + -- 'GenericPackageDescription'; for pragmatic reasons we just store + -- the partially filled-out 'PackageDescription' inside the + -- 'GenericPackageDescription'. + pkg <- lift $ parseFields pkgDescrFieldDescrs + storeXFieldsPD + emptyPackageDescription + header_fields + + -- 'getBody' assumes that the remaining fields only consist of + -- flags, lib and exe sections. + (repos, flags, mlib, exes, tests, bms) <- getBody + warnIfRest -- warn if getBody did not parse up to the last field. + -- warn about using old/new syntax with wrong cabal-version: + maybeWarnCabalVersion (not $ oldSyntax fields0) pkg + checkForUndefinedFlags flags mlib exes tests + return $ GenericPackageDescription + pkg { sourceRepos = repos } + flags mlib exes tests bms + + where + oldSyntax = all isSimpleField + reportTabsError tabs = + syntaxError (fst (head tabs)) $ + "Do not use tabs for indentation (use spaces instead)\n" + ++ " Tabs were used at (line,column): " ++ show tabs + + maybeWarnCabalVersion newsyntax pkg + | newsyntax && specVersion pkg < Version [1,2] [] + = lift $ warning $ + "A package using section syntax must specify at least\n" + ++ "'cabal-version: >= 1.2'." + + maybeWarnCabalVersion newsyntax pkg + | not newsyntax && specVersion pkg >= Version [1,2] [] + = lift $ warning $ + "A package using 'cabal-version: " + ++ displaySpecVersion (specVersionRaw pkg) + ++ "' must use section syntax. See the Cabal user guide for details." + where + displaySpecVersion (Left version) = display version + displaySpecVersion (Right versionRange) = + case asVersionIntervals versionRange of + [] {- impossible -} -> display versionRange + ((LowerBound version _, _):_) -> display (orLaterVersion version) + + maybeWarnCabalVersion _ _ = return () + + + handleFutureVersionParseFailure cabalVersionNeeded parseBody = + (unless versionOk (warning message) >> parseBody) + `catchParseError` \parseError -> case parseError of + TabsError _ -> parseFail parseError + _ | versionOk -> parseFail parseError + | otherwise -> fail message + where versionOk = cabalVersionNeeded <= cabalVersion + message = "This package requires at least Cabal version " + ++ display cabalVersionNeeded + + -- "Sectionize" an old-style Cabal file. A sectionized file has: + -- + -- * all global fields at the beginning, followed by + -- + -- * all flag declarations, followed by + -- + -- * an optional library section, and an arbitrary number of executable + -- sections (in any order). + -- + -- The current implementation just gathers all library-specific fields + -- in a library section and wraps all executable stanzas in an executable + -- section. + sectionizeFields :: [Field] -> [Field] + sectionizeFields fs + | oldSyntax fs = + let + -- "build-depends" is a local field now. To be backwards + -- compatible, we still allow it as a global field in old-style + -- package description files and translate it to a local field by + -- adding it to every non-empty section + (hdr0, exes0) = break ((=="executable") . fName) fs + (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0 + + (deps, libfs) = partition ((== "build-depends") . fName) + libfs0 + + exes = unfoldr toExe exes0 + toExe [] = Nothing + toExe (F l e n : r) + | e == "executable" = + let (efs, r') = break ((=="executable") . fName) r + in Just (Section l "executable" n (deps ++ efs), r') + toExe _ = cabalBug "unexpected input to 'toExe'" + in + hdr ++ + (if null libfs then [] + else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)]) + ++ exes + | otherwise = fs + + isSimpleField F{} = True + isSimpleField _ = False + + -- warn if there's something at the end of the file + warnIfRest :: PM () + warnIfRest = do + s <- get + case s of + [] -> return () + _ -> lift $ warning "Ignoring trailing declarations." -- add line no. + + -- all simple fields at the beginning of the file are (considered) header + -- fields + getHeader :: [Field] -> PM [Field] + getHeader acc = peekField >>= \mf -> case mf of + Just f@F{} -> skipField >> getHeader (f:acc) + _ -> return (reverse acc) + + -- + -- body ::= { repo | flag | library | executable | test }+ -- at most one lib + -- + -- The body consists of an optional sequence of declarations of flags and + -- an arbitrary number of executables and at most one library. + getBody :: PM ([SourceRepo], [Flag] + ,Maybe (CondTree ConfVar [Dependency] Library) + ,[(String, CondTree ConfVar [Dependency] Executable)] + ,[(String, CondTree ConfVar [Dependency] TestSuite)] + ,[(String, CondTree ConfVar [Dependency] Benchmark)]) + getBody = peekField >>= \mf -> case mf of + Just (Section line_no sec_type sec_label sec_fields) + | sec_type == "executable" -> do + when (null sec_label) $ lift $ syntaxError line_no + "'executable' needs one argument (the executable's name)" + exename <- lift $ runP line_no "executable" parseTokenQ sec_label + flds <- collectFields parseExeFields sec_fields + skipField + (repos, flags, lib, exes, tests, bms) <- getBody + return (repos, flags, lib, (exename, flds): exes, tests, bms) + + | sec_type == "test-suite" -> do + when (null sec_label) $ lift $ syntaxError line_no + "'test-suite' needs one argument (the test suite's name)" + testname <- lift $ runP line_no "test" parseTokenQ sec_label + flds <- collectFields (parseTestFields line_no) sec_fields + + -- Check that a valid test suite type has been chosen. A type + -- field may be given inside a conditional block, so we must + -- check for that before complaining that a type field has not + -- been given. The test suite must always have a valid type, so + -- we need to check both the 'then' and 'else' blocks, though + -- the blocks need not have the same type. + let checkTestType ts ct = + let ts' = mappend ts $ condTreeData ct + -- If a conditional has only a 'then' block and no + -- 'else' block, then it cannot have a valid type + -- in every branch, unless the type is specified at + -- a higher level in the tree. + checkComponent (_, _, Nothing) = False + -- If a conditional has a 'then' block and an 'else' + -- block, both must specify a test type, unless the + -- type is specified higher in the tree. + checkComponent (_, t, Just e) = + checkTestType ts' t && checkTestType ts' e + -- Does the current node specify a test type? + hasTestType = testInterface ts' + /= testInterface emptyTestSuite + components = condTreeComponents ct + -- If the current level of the tree specifies a type, + -- then we are done. If not, then one of the conditional + -- branches below the current node must specify a type. + -- Each node may have multiple immediate children; we + -- only one need one to specify a type because the + -- configure step uses 'mappend' to join together the + -- results of flag resolution. + in hasTestType || any checkComponent components + if checkTestType emptyTestSuite flds + then do + skipField + (repos, flags, lib, exes, tests, bms) <- getBody + return (repos, flags, lib, exes, (testname, flds) : tests, bms) + else lift $ syntaxError line_no $ + "Test suite \"" ++ testname + ++ "\" is missing required field \"type\" or the field " + ++ "is not present in all conditional branches. The " + ++ "available test types are: " + ++ intercalate ", " (map display knownTestTypes) + + | sec_type == "benchmark" -> do + when (null sec_label) $ lift $ syntaxError line_no + "'benchmark' needs one argument (the benchmark's name)" + benchname <- lift $ runP line_no "benchmark" parseTokenQ sec_label + flds <- collectFields (parseBenchmarkFields line_no) sec_fields + + -- Check that a valid benchmark type has been chosen. A type + -- field may be given inside a conditional block, so we must + -- check for that before complaining that a type field has not + -- been given. The benchmark must always have a valid type, so + -- we need to check both the 'then' and 'else' blocks, though + -- the blocks need not have the same type. + let checkBenchmarkType ts ct = + let ts' = mappend ts $ condTreeData ct + -- If a conditional has only a 'then' block and no + -- 'else' block, then it cannot have a valid type + -- in every branch, unless the type is specified at + -- a higher level in the tree. + checkComponent (_, _, Nothing) = False + -- If a conditional has a 'then' block and an 'else' + -- block, both must specify a benchmark type, unless the + -- type is specified higher in the tree. + checkComponent (_, t, Just e) = + checkBenchmarkType ts' t && checkBenchmarkType ts' e + -- Does the current node specify a benchmark type? + hasBenchmarkType = benchmarkInterface ts' + /= benchmarkInterface emptyBenchmark + components = condTreeComponents ct + -- If the current level of the tree specifies a type, + -- then we are done. If not, then one of the conditional + -- branches below the current node must specify a type. + -- Each node may have multiple immediate children; we + -- only one need one to specify a type because the + -- configure step uses 'mappend' to join together the + -- results of flag resolution. + in hasBenchmarkType || any checkComponent components + if checkBenchmarkType emptyBenchmark flds + then do + skipField + (repos, flags, lib, exes, tests, bms) <- getBody + return (repos, flags, lib, exes, tests, (benchname, flds) : bms) + else lift $ syntaxError line_no $ + "Benchmark \"" ++ benchname + ++ "\" is missing required field \"type\" or the field " + ++ "is not present in all conditional branches. The " + ++ "available benchmark types are: " + ++ intercalate ", " (map display knownBenchmarkTypes) + + | sec_type == "library" -> do + unless (null sec_label) $ lift $ + syntaxError line_no "'library' expects no argument" + flds <- collectFields parseLibFields sec_fields + skipField + (repos, flags, lib, exes, tests, bms) <- getBody + when (isJust lib) $ lift $ syntaxError line_no + "There can only be one library section in a package description." + return (repos, flags, Just flds, exes, tests, bms) + + | sec_type == "flag" -> do + when (null sec_label) $ lift $ + syntaxError line_no "'flag' needs one argument (the flag's name)" + flag <- lift $ parseFields + flagFieldDescrs + warnUnrec + (MkFlag (FlagName (lowercase sec_label)) "" True False) + sec_fields + skipField + (repos, flags, lib, exes, tests, bms) <- getBody + return (repos, flag:flags, lib, exes, tests, bms) + + | sec_type == "source-repository" -> do + when (null sec_label) $ lift $ syntaxError line_no $ + "'source-repository' needs one argument, " + ++ "the repo kind which is usually 'head' or 'this'" + kind <- case simpleParse sec_label of + Just kind -> return kind + Nothing -> lift $ syntaxError line_no $ + "could not parse repo kind: " ++ sec_label + repo <- lift $ parseFields + sourceRepoFieldDescrs + warnUnrec + SourceRepo { + repoKind = kind, + repoType = Nothing, + repoLocation = Nothing, + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing + } + sec_fields + skipField + (repos, flags, lib, exes, tests, bms) <- getBody + return (repo:repos, flags, lib, exes, tests, bms) + + | otherwise -> do + lift $ warning $ "Ignoring unknown section type: " ++ sec_type + skipField + getBody + Just f@(F {}) -> do + _ <- lift $ syntaxError (lineNo f) $ + "Plain fields are not allowed in between stanzas: " ++ show f + skipField + getBody + Just f@(IfBlock {}) -> do + _ <- lift $ syntaxError (lineNo f) $ + "If-blocks are not allowed in between stanzas: " ++ show f + skipField + getBody + Nothing -> return ([], [], Nothing, [], [], []) + + -- Extracts all fields in a block and returns a 'CondTree'. + -- + -- We have to recurse down into conditionals and we treat fields that + -- describe dependencies specially. + collectFields :: ([Field] -> PM a) -> [Field] + -> PM (CondTree ConfVar [Dependency] a) + collectFields parser allflds = do + + let simplFlds = [ F l n v | F l n v <- allflds ] + condFlds = [ f | f@IfBlock{} <- allflds ] + 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 + + ifs <- mapM processIfs condFlds + + return (CondNode a deps ifs) + where + isConstraint (F _ n _) = n `elem` constraintFieldNames + isConstraint _ = False + + processIfs (IfBlock l c t e) = do + cnd <- lift $ runP l "if" parseCondition c + t' <- collectFields parser t + e' <- case e of + [] -> return Nothing + es -> do fs <- collectFields parser es + return (Just fs) + return (cnd, t', e') + processIfs _ = cabalBug "processIfs called with wrong field type" + + parseLibFields :: [Field] -> PM Library + parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary + + -- Note: we don't parse the "executable" field here, hence the tail hack. + parseExeFields :: [Field] -> PM Executable + parseExeFields = lift . parseFields (tail executableFieldDescrs) + storeXFieldsExe emptyExecutable + + parseTestFields :: LineNo -> [Field] -> PM TestSuite + parseTestFields line fields = do + x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest + emptyTestStanza fields + lift $ validateTestSuite line x + + parseBenchmarkFields :: LineNo -> [Field] -> PM Benchmark + parseBenchmarkFields line fields = do + x <- lift $ parseFields benchmarkFieldDescrs storeXFieldsBenchmark + emptyBenchmarkStanza fields + lift $ validateBenchmark line x + + checkForUndefinedFlags :: + [Flag] -> + Maybe (CondTree ConfVar [Dependency] Library) -> + [(String, CondTree ConfVar [Dependency] Executable)] -> + [(String, CondTree ConfVar [Dependency] TestSuite)] -> + PM () + checkForUndefinedFlags flags mlib exes tests = do + let definedFlags = map flagName flags + maybe (return ()) (checkCondTreeFlags definedFlags) mlib + mapM_ (checkCondTreeFlags definedFlags . snd) exes + mapM_ (checkCondTreeFlags definedFlags . snd) tests + + checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM () + checkCondTreeFlags definedFlags ct = do + let fv = nub $ freeVars ct + unless (all (`elem` definedFlags) fv) $ + fail $ "These flags are used without having been defined: " + ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] + + +-- | Parse a list of fields, given a list of field descriptions, +-- a structure to accumulate the parsed fields, and a function +-- that can decide what to do with fields which don't match any +-- of the field descriptions. +parseFields :: [FieldDescr a] -- ^ descriptions of fields we know how to + -- parse + -> UnrecFieldParser a -- ^ possibly do something with + -- unrecognized fields + -> a -- ^ accumulator + -> [Field] -- ^ fields to be parsed + -> ParseResult a +parseFields descrs unrec ini fields = + do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields + unless (null unknowns) $ warning $ render $ + text "Unknown fields:" <+> + commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")") + (reverse unknowns)) + $+$ + text "Fields allowed in this section:" $$ + nest 4 (commaSep $ map fieldName descrs) + return a + where + commaSep = fsep . punctuate comma . map text + +parseField :: [FieldDescr a] -- ^ list of parseable fields + -> UnrecFieldParser a -- ^ possibly do something with + -- unrecognized fields + -> (a,[(Int,String)]) -- ^ accumulated result and warnings + -> Field -- ^ the field to be parsed + -> ParseResult (a, [(Int,String)]) +parseField (FieldDescr name _ parser : fields) unrec (a, us) (F line f val) + | name == f = parser line val a >>= \a' -> return (a',us) + | otherwise = parseField fields unrec (a,us) (F line f val) +parseField [] unrec (a,us) (F l f val) = return $ + case unrec (f,val) a of -- no fields matched, see if the 'unrec' + Just a' -> (a',us) -- function wants to do anything with it + Nothing -> (a, (l,f):us) +parseField _ _ _ _ = cabalBug "'parseField' called on a non-field" + +deprecatedFields :: [(String,String)] +deprecatedFields = + deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo + +deprecatedFieldsPkgDescr :: [(String,String)] +deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ] + +deprecatedFieldsBuildInfo :: [(String,String)] +deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ] + +-- Handle deprecated fields +deprecField :: Field -> ParseResult Field +deprecField (F line fld val) = do + fld' <- case lookup fld deprecatedFields of + Nothing -> return fld + Just newName -> do + warning $ "The field \"" ++ fld + ++ "\" is deprecated, please use \"" ++ newName ++ "\"" + return newName + return (F line fld' val) +deprecField _ = cabalBug "'deprecField' called on a non-field" + + +parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo +parseHookedBuildInfo inp = do + fields <- readFields inp + let ss@(mLibFields:exes) = stanzas fields + mLib <- parseLib mLibFields + biExes <- mapM parseExe (maybe ss (const exes) mLib) + return (mLib, biExes) + where + parseLib :: [Field] -> ParseResult (Maybe BuildInfo) + parseLib (bi@(F _ inFieldName _:_)) + | lowercase inFieldName /= "executable" = liftM Just (parseBI bi) + parseLib _ = return Nothing + + parseExe :: [Field] -> ParseResult (String, BuildInfo) + parseExe (F line inFieldName mName:bi) + | lowercase inFieldName == "executable" + = do bis <- parseBI bi + return (mName, bis) + | otherwise = syntaxError line "expecting 'executable' at top of stanza" + parseExe (_:_) = cabalBug "`parseExe' called on a non-field" + parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza" + + parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st + +-- --------------------------------------------------------------------------- +-- Pretty printing + +writePackageDescription :: FilePath -> PackageDescription -> IO () +writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) + +--TODO: make this use section syntax +-- add equivalent for GenericPackageDescription +showPackageDescription :: PackageDescription -> String +showPackageDescription pkg = render $ + ppPackage pkg + $$ ppCustomFields (customFieldsPD pkg) + $$ (case library pkg of + Nothing -> empty + Just lib -> ppLibrary lib) + $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ] + where + ppPackage = ppFields pkgDescrFieldDescrs + ppLibrary = ppFields libFieldDescrs + ppExecutable = ppFields executableFieldDescrs + +ppCustomFields :: [(String,String)] -> Doc +ppCustomFields flds = vcat (map ppCustomField flds) + +ppCustomField :: (String,String) -> Doc +ppCustomField (name,val) = text name <> colon <+> showFreeText val + +writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () +writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack + . showHookedBuildInfo + +showHookedBuildInfo :: HookedBuildInfo -> String +showHookedBuildInfo (mb_lib_bi, ex_bis) = render $ + (case mb_lib_bi of + Nothing -> empty + Just bi -> ppBuildInfo bi) + $$ vcat [ space + $$ text "executable:" <+> text name + $$ ppBuildInfo bi + | (name, bi) <- ex_bis ] + where + ppBuildInfo bi = ppFields binfoFieldDescrs bi + $$ ppCustomFields (customFieldsBI bi) + +-- replace all tabs used as indentation with whitespace, also return where +-- tabs were found +findIndentTabs :: String -> [(Int,Int)] +findIndentTabs = concatMap checkLine + . zip [1..] + . lines + where + checkLine (lineno, l) = + let (indent, _content) = span isSpace l + tabCols = map fst . filter ((== '\t') . snd) . zip [0..] + addLineNo = map (\col -> (lineno,col)) + in addLineNo (tabCols indent) + +--test_findIndentTabs = findIndentTabs $ unlines $ +-- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ] + +-- | 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 new file mode 100644 --- /dev/null +++ b/Distribution/PackageDescription/PrettyPrint.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.PrettyPrint +-- Copyright : Jürgen Nicklisch-Franken 2010 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Pretty printing for cabal files +-- +----------------------------------------------------------------------------- + +module Distribution.PackageDescription.PrettyPrint ( + writeGenericPackageDescription, + 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 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) + +-- | Recompile with false for regression testing +simplifiedPrinting :: Bool +simplifiedPrinting = False + +-- | Writes a .cabal file from a generic package description +writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO () +writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg) + +-- | Writes a generic package description to a string +showGenericPackageDescription :: GenericPackageDescription -> String +showGenericPackageDescription = render . ppGenericPackageDescription + +ppGenericPackageDescription :: GenericPackageDescription -> Doc +ppGenericPackageDescription gpd = + ppPackageDescription (packageDescription gpd) + $+$ ppGenPackageFlags (genPackageFlags gpd) + $+$ ppLibrary (condLibrary gpd) + $+$ ppExecutables (condExecutables gpd) + $+$ ppTestSuites (condTestSuites gpd) + $+$ ppBenchmarks (condBenchmarks gpd) + +ppPackageDescription :: PackageDescription -> Doc +ppPackageDescription pd = ppFields pkgDescrFieldDescrs pd + $+$ ppCustomFields (customFieldsPD pd) + $+$ ppSourceRepos (sourceRepos pd) + +ppSourceRepos :: [SourceRepo] -> Doc +ppSourceRepos [] = empty +ppSourceRepos (hd:tl) = ppSourceRepo hd $+$ ppSourceRepos tl + +ppSourceRepo :: SourceRepo -> Doc +ppSourceRepo repo = + emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$ + (nest indentWith (ppFields sourceRepoFieldDescrs' repo)) + where + sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"] + +-- TODO: this is a temporary hack. Ideally, fields containing default values +-- would be filtered out when the @FieldDescr a@ list is generated. +ppFieldsFiltered :: [(String, String)] -> [FieldDescr a] -> a -> Doc +ppFieldsFiltered removable fields x = ppFields (filter nondefault fields) x + where + nondefault (FieldDescr name getter _) = + maybe True (render (getter x) /=) (lookup name removable) + +binfoDefaults :: [(String, String)] +binfoDefaults = [("buildable", "True")] + +libDefaults :: [(String, String)] +libDefaults = ("exposed", "True") : binfoDefaults + +flagDefaults :: [(String, String)] +flagDefaults = [("default", "True"), ("manual", "False")] + +ppDiffFields :: [FieldDescr a] -> a -> a -> Doc +ppDiffFields fields x y = + vcat [ ppField name (getter x) + | FieldDescr name getter _ <- fields + , render (getter x) /= render (getter y) + ] + +ppCustomFields :: [(String,String)] -> Doc +ppCustomFields flds = vcat [ppCustomField f | f <- flds] + +ppCustomField :: (String,String) -> Doc +ppCustomField (name,val) = text name <> colon <+> showFreeText val + +ppGenPackageFlags :: [Flag] -> Doc +ppGenPackageFlags flds = vcat [ppFlag f | f <- flds] + +ppFlag :: Flag -> Doc +ppFlag flag@(MkFlag name _ _ _) = + emptyLine $ text "flag" <+> ppFlagName name $+$ nest indentWith fields + where + fields = ppFieldsFiltered flagDefaults flagFieldDescrs flag + +ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc +ppLibrary Nothing = empty +ppLibrary (Just condTree) = + emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib) + where + ppLib lib Nothing = ppFieldsFiltered libDefaults libFieldDescrs lib + $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) + ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib + $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) + +ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc +ppExecutables exes = + vcat [emptyLine $ text ("executable " ++ n) + $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes] + where + ppExe (Executable _ modulePath' buildInfo') Nothing = + (if modulePath' == "" then empty else text "main-is:" <+> text modulePath') + $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs buildInfo' + $+$ ppCustomFields (customFieldsBI buildInfo') + ppExe (Executable _ modulePath' buildInfo') + (Just (Executable _ modulePath2 buildInfo2)) = + (if modulePath' == "" || modulePath' == modulePath2 + then empty else text "main-is:" <+> text modulePath') + $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 + $+$ ppCustomFields (customFieldsBI buildInfo') + +ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc +ppTestSuites suites = + emptyLine $ vcat [ text ("test-suite " ++ n) + $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite) + | (n,condTree) <- suites] + where + ppTestSuite testsuite Nothing = + maybe empty (\t -> text "type:" <+> disp t) + maybeTestType + $+$ maybe empty (\f -> text "main-is:" <+> text f) + (testSuiteMainIs testsuite) + $+$ maybe empty (\m -> text "test-module:" <+> disp m) + (testSuiteModule testsuite) + $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (testBuildInfo testsuite) + $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite)) + where + maybeTestType | testInterface testsuite == mempty = Nothing + | otherwise = Just (testType testsuite) + + ppTestSuite (TestSuite _ _ buildInfo' _) + (Just (TestSuite _ _ buildInfo2 _)) = + ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 + $+$ ppCustomFields (customFieldsBI buildInfo') + + testSuiteMainIs test = case testInterface test of + TestSuiteExeV10 _ f -> Just f + _ -> Nothing + + testSuiteModule test = case testInterface test of + TestSuiteLibV09 _ m -> Just m + _ -> Nothing + +ppBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] -> Doc +ppBenchmarks suites = + emptyLine $ vcat [ text ("benchmark " ++ n) + $+$ nest indentWith (ppCondTree condTree Nothing ppBenchmark) + | (n,condTree) <- suites] + where + ppBenchmark benchmark Nothing = + maybe empty (\t -> text "type:" <+> disp t) + maybeBenchmarkType + $+$ maybe empty (\f -> text "main-is:" <+> text f) + (benchmarkMainIs benchmark) + $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (benchmarkBuildInfo benchmark) + $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark)) + where + maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing + | otherwise = Just (benchmarkType benchmark) + + ppBenchmark (Benchmark _ _ buildInfo' _) + (Just (Benchmark _ _ buildInfo2 _)) = + ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 + $+$ ppCustomFields (customFieldsBI buildInfo') + + benchmarkMainIs benchmark = case benchmarkInterface benchmark of + BenchmarkExeV10 _ f -> Just f + _ -> Nothing + +ppCondition :: Condition ConfVar -> Doc +ppCondition (Var x) = ppConfVar x +ppCondition (Lit b) = text (show b) +ppCondition (CNot c) = char '!' <> (ppCondition c) +ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||" + <+> ppCondition c2]) +ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&" + <+> ppCondition c2]) +ppConfVar :: ConfVar -> Doc +ppConfVar (OS os) = text "os" <> parens (disp os) +ppConfVar (Arch arch) = text "arch" <> parens (disp arch) +ppConfVar (Flag name) = text "flag" <> parens (ppFlagName name) +ppConfVar (Impl c v) = text "impl" <> parens (disp c <+> disp v) + +ppFlagName :: FlagName -> Doc +ppFlagName (FlagName name) = text name + +ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) -> Doc +ppCondTree ct@(CondNode it _ ifs) mbIt ppIt = + let res = (vcat $ map ppIf ifs) + $+$ ppIt it mbIt + in if isJust mbIt && isEmpty res + then ppCondTree ct Nothing ppIt + 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)) + +emptyLine :: Doc -> Doc +emptyLine d = text "" $+$ d + + + diff --git a/Distribution/PackageDescription/Utils.hs b/Distribution/PackageDescription/Utils.hs new file mode 100644 --- /dev/null +++ b/Distribution/PackageDescription/Utils.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Utils +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Common utils used by modules under Distribution.PackageDescription.*. + +module Distribution.PackageDescription.Utils ( + cabalBug, userBug + ) where + +-- ---------------------------------------------------------------------------- +-- Exception and logging utils + +userBug :: String -> a +userBug msg = error $ msg ++ ". This is a bug in your .cabal file." + +cabalBug :: String -> a +cabalBug msg = error $ msg ++ ". This is possibly a bug in Cabal.\n" + ++ "Please report it to the developers: " + ++ "https://github.com/haskell/cabal/issues/new" diff --git a/Distribution/ParseUtils.hs b/Distribution/ParseUtils.hs new file mode 100644 --- /dev/null +++ b/Distribution/ParseUtils.hs @@ -0,0 +1,755 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ParseUtils +-- Copyright : (c) The University of Glasgow 2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'. +-- +-- The @.cabal@ file format is not trivial, especially with the introduction +-- of configurations and the section syntax that goes with that. This module +-- has a bunch of parsing functions that is used by the @.cabal@ parser and a +-- couple others. It has the parsing framework code and also little parsers for +-- many of the formats we get in various @.cabal@ file fields, like module +-- names, comma separated lists etc. + +-- This module is meant to be local-only to Distribution... + +{-# OPTIONS_HADDOCK hide #-} +module Distribution.ParseUtils ( + LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, + runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning, + Field(..), fName, lineNo, + FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat, + showFields, showSingleNamedField, showSimpleSingleNamedField, + parseFields, parseFieldsFlat, + parseFilePathQ, parseTokenQ, parseTokenQ', + parseModuleNameQ, parseBuildTool, parsePkgconfigDependency, + parseOptVersion, parsePackageNameQ, parseVersionRangeQ, + parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ, + parseSepList, parseCommaList, parseOptCommaList, + showFilePath, showToken, showTestedWith, showFreeText, parseFreeText, + field, simpleField, listField, listFieldWithSep, spaceListField, + commaListField, commaListFieldWithSep, commaNewLineListField, + optsField, liftField, boolField, parseQuoted, indentWith, + + UnrecFieldParser, warnUnrec, ignoreUnrec, + ) where + +import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat) +import Distribution.License +import Distribution.Version + ( Version(..), VersionRange, anyVersion ) +import Distribution.Package ( PackageName(..), Dependency(..) ) +import Distribution.ModuleName (ModuleName) +import Distribution.Compat.ReadP as ReadP hiding (get) +import Distribution.ReadE +import Distribution.Text + ( Text(..) ) +import Distribution.Simple.Utils + ( comparing, dropWhileEndLE, intercalate, lowercase + , normaliseLineEndings ) +import Language.Haskell.Extension + ( Language, Extension ) + +import Text.PrettyPrint hiding (braces) +import Data.Char (isSpace, toLower, isAlphaNum, isDigit) +import Data.Maybe (fromMaybe) +import Data.Tree as Tree (Tree(..), flatten) +import qualified Data.Map as Map +import Control.Monad (foldM, ap) +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative (Applicative(..)) +#endif +import System.FilePath (normalise) +import Data.List (sortBy) + +-- ----------------------------------------------------------------------------- + +type LineNo = Int +type Separator = ([Doc] -> Doc) + +data PError = AmbiguousParse String LineNo + | NoParse String LineNo + | TabsError LineNo + | FromString String (Maybe LineNo) + deriving (Eq, Show) + +data PWarning = PWarning String + | UTFWarning LineNo String + deriving (Eq, Show) + +showPWarning :: FilePath -> PWarning -> String +showPWarning fpath (PWarning msg) = + normalise fpath ++ ": " ++ msg +showPWarning fpath (UTFWarning line fname) = + normalise fpath ++ ":" ++ show line + ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field." + +data ParseResult a = ParseFailed PError | ParseOk [PWarning] a + deriving Show + +instance Functor ParseResult where + fmap _ (ParseFailed err) = ParseFailed err + fmap f (ParseOk ws x) = ParseOk ws $ f x + +instance Applicative ParseResult where + pure = return + (<*>) = ap + + +instance Monad ParseResult where + return = ParseOk [] + ParseFailed err >>= _ = ParseFailed err + ParseOk ws x >>= f = case f x of + ParseFailed err -> ParseFailed err + ParseOk ws' x' -> ParseOk (ws'++ws) x' + fail s = ParseFailed (FromString s Nothing) + +catchParseError :: ParseResult a -> (PError -> ParseResult a) + -> ParseResult a +p@(ParseOk _ _) `catchParseError` _ = p +ParseFailed e `catchParseError` k = k e + +parseFail :: PError -> ParseResult a +parseFail = ParseFailed + +runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a +runP line fieldname p s = + case [ x | (x,"") <- results ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + --TODO: what is this double parse thing all about? + -- Can't we just do the all isSpace test the first time? + [] -> case [ x | (x,ys) <- results, all isSpace ys ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + [] -> ParseFailed (NoParse fieldname line) + _ -> ParseFailed (AmbiguousParse fieldname line) + _ -> ParseFailed (AmbiguousParse fieldname line) + where results = readP_to_S p s + +runE :: LineNo -> String -> ReadE a -> String -> ParseResult a +runE line fieldname p s = + case runReadE p s of + Right a -> ParseOk (utf8Warnings line fieldname s) a + Left e -> syntaxError line $ + "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s + +utf8Warnings :: LineNo -> String -> String -> [PWarning] +utf8Warnings line fieldname s = + take 1 [ UTFWarning n fieldname + | (n,l) <- zip [line..] (lines s) + , '\xfffd' `elem` l ] + +locatedErrorMsg :: PError -> (Maybe LineNo, String) +locatedErrorMsg (AmbiguousParse f n) = (Just n, + "Ambiguous parse in field '"++f++"'.") +locatedErrorMsg (NoParse f n) = (Just n, + "Parse of field '"++f++"' failed.") +locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.") +locatedErrorMsg (FromString s n) = (n, s) + +syntaxError :: LineNo -> String -> ParseResult a +syntaxError n s = ParseFailed $ FromString s (Just n) + +tabsError :: LineNo -> ParseResult a +tabsError ln = ParseFailed $ TabsError ln + +warning :: String -> ParseResult () +warning s = ParseOk [PWarning s] () + +-- | Field descriptor. The parameter @a@ parameterizes over where the field's +-- value is stored in. +data FieldDescr a + = FieldDescr + { fieldName :: String + , fieldGet :: a -> Doc + , fieldSet :: LineNo -> String -> a -> ParseResult a + -- ^ @fieldSet n str x@ Parses the field value from the given input + -- string @str@ and stores the result in @x@ if the parse was + -- successful. Otherwise, reports an error on line number @n@. + } + +field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a +field name showF readF = + FieldDescr name showF (\line val _st -> runP line name readF val) + +-- Lift a field descriptor storing into an 'a' to a field descriptor storing +-- into a 'b'. +liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b +liftField get set (FieldDescr name showF parseF) + = FieldDescr name (showF . get) + (\line str b -> do + a <- parseF line str (get b) + return (set a b)) + +-- Parser combinator for simple fields. Takes a field name, a pretty printer, +-- a parser function, an accessor, and a setter, returns a FieldDescr over the +-- compoid structure. +simpleField :: String -> (a -> Doc) -> ReadP a a + -> (b -> a) -> (a -> b -> b) -> FieldDescr b +simpleField name showF readF get set + = liftField get set $ field name showF readF + +commaListFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaListFieldWithSep separator name showF readF get set = + liftField get set' $ + field name showF' (parseCommaList readF) + where + set' xs b = set (get b ++ xs) b + showF' = separator . punctuate comma . map showF + +commaListField :: String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaListField = commaListFieldWithSep fsep + +commaNewLineListField :: String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaNewLineListField = commaListFieldWithSep sep + +spaceListField :: String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +spaceListField name showF readF get set = + liftField get set' $ + field name showF' (parseSpaceList readF) + where + set' xs b = set (get b ++ xs) b + showF' = fsep . map showF + +listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listFieldWithSep separator name showF readF get set = + liftField get set' $ + field name showF' (parseOptCommaList readF) + where + set' xs b = set (get b ++ xs) b + showF' = separator . map showF + +listField :: String -> (a -> Doc) -> ReadP [a] a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listField = listFieldWithSep fsep + +optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) + -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b +optsField name flavor get set = + liftField (fromMaybe [] . lookup flavor . get) + (\opts b -> set (reorder (update flavor opts (get b))) b) $ + field name showF (sepBy parseTokenQ' (munch1 isSpace)) + where + update _ opts l | all null opts = l --empty opts as if no opts + update f opts [] = [(f,opts)] + update f opts ((f',opts'):rest) + | f == f' = (f, opts' ++ opts) : rest + | otherwise = (f',opts') : update f opts rest + reorder = sortBy (comparing fst) + showF = hsep . map text + +-- TODO: this is a bit smelly hack. It's because we want to parse bool fields +-- liberally but not accept new parses. We cannot do that with ReadP +-- because it does not support warnings. We need a new parser framework! +boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b +boolField name get set = liftField get set (FieldDescr name showF readF) + where + showF = text . show + readF line str _ + | str == "True" = ParseOk [] True + | str == "False" = ParseOk [] False + | lstr == "true" = ParseOk [caseWarning] True + | lstr == "false" = ParseOk [caseWarning] False + | otherwise = ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = PWarning $ + "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'." + +ppFields :: [FieldDescr a] -> a -> Doc +ppFields fields x = + vcat [ ppField name (getter x) | FieldDescr name getter _ <- fields ] + +ppField :: String -> Doc -> Doc +ppField name fielddoc + | isEmpty fielddoc = empty + | name `elem` nestedFields = text name <> colon $+$ nest indentWith fielddoc + | otherwise = text name <> colon <+> fielddoc + where + nestedFields = + [ "description" + , "build-depends" + , "data-files" + , "extra-source-files" + , "extra-tmp-files" + , "exposed-modules" + , "c-sources" + , "js-sources" + , "extra-libraries" + , "includes" + , "install-includes" + , "other-modules" + , "depends" + ] + +showFields :: [FieldDescr a] -> a -> String +showFields fields = render . ($+$ text "") . ppFields fields + +showSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String) +showSingleNamedField fields f = + case [ get | (FieldDescr f' get _) <- fields, f' == f ] of + [] -> Nothing + (get:_) -> Just (render . ppField f . get) + +showSimpleSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String) +showSimpleSingleNamedField fields f = + case [ get | (FieldDescr f' get _) <- fields, f' == f ] of + [] -> Nothing + (get:_) -> Just (renderStyle myStyle . get) + where myStyle = style { mode = LeftMode } + +parseFields :: [FieldDescr a] -> a -> String -> ParseResult a +parseFields fields initial str = + readFields str >>= accumFields fields initial + +parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a +parseFieldsFlat fields initial str = + readFieldsFlat str >>= accumFields fields initial + +accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a +accumFields fields = foldM setField + where + fieldMap = Map.fromList + [ (name, f) | f@(FieldDescr name _ _) <- fields ] + setField accum (F line name value) = case Map.lookup name fieldMap of + Just (FieldDescr _ _ set) -> set line value accum + Nothing -> do + warning ("Unrecognized field " ++ name ++ " on line " ++ show line) + return accum + setField accum f = do + warning ("Unrecognized stanza on line " ++ show (lineNo f)) + return accum + +-- | The type of a function which, given a name-value pair of an +-- unrecognized field, and the current structure being built, +-- decides whether to incorporate the unrecognized field +-- (by returning Just x, where x is a possibly modified version +-- of the structure being built), or not (by returning Nothing). +type UnrecFieldParser a = (String,String) -> a -> Maybe a + +-- | A default unrecognized field parser which simply returns Nothing, +-- i.e. ignores all unrecognized fields, so warnings will be generated. +warnUnrec :: UnrecFieldParser a +warnUnrec _ _ = Nothing + +-- | A default unrecognized field parser which silently (i.e. no +-- warnings will be generated) ignores unrecognized fields, by +-- returning the structure being built unmodified. +ignoreUnrec :: UnrecFieldParser a +ignoreUnrec _ = Just + +------------------------------------------------------------------------------ + +-- The data type for our three syntactic categories +data Field + = F LineNo String String + -- ^ A regular @: @ field + | Section LineNo String String [Field] + -- ^ A section with a name and possible parameter. The syntactic + -- structure is: + -- + -- @ + -- { + -- * + -- } + -- @ + | IfBlock LineNo String [Field] [Field] + -- ^ A conditional block with an optional else branch: + -- + -- @ + -- if { + -- * + -- } else { + -- * + -- } + -- @ + deriving (Show + ,Eq) -- for testing + +lineNo :: Field -> LineNo +lineNo (F n _ _) = n +lineNo (Section n _ _ _) = n +lineNo (IfBlock n _ _ _) = n + +fName :: Field -> String +fName (F _ n _) = n +fName (Section _ n _ _) = n +fName _ = error "fname: not a field or section" + +readFields :: String -> ParseResult [Field] +readFields input = ifelse + =<< mapM (mkField 0) + =<< mkTree tokens + + where ls = (lines . normaliseLineEndings) input + tokens = (concatMap tokeniseLine . trimLines) ls + +readFieldsFlat :: String -> ParseResult [Field] +readFieldsFlat input = mapM (mkField 0) + =<< mkTree tokens + where ls = (lines . normaliseLineEndings) input + tokens = (concatMap tokeniseLineFlat . trimLines) ls + +-- attach line number and determine indentation +trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)] +trimLines ls = [ (lineno, indent, hastabs, trimTrailing l') + | (lineno, l) <- zip [1..] ls + , let (sps, l') = span isSpace l + indent = length sps + hastabs = '\t' `elem` sps + , validLine l' ] + where validLine ('-':'-':_) = False -- Comment + validLine [] = False -- blank line + validLine _ = True + +-- | We parse generically based on indent level and braces '{' '}'. To do that +-- we split into lines and then '{' '}' tokens and other spans within a line. +data Token = + -- | The 'Line' token is for bits that /start/ a line, eg: + -- + -- > "\n blah blah { blah" + -- + -- tokenises to: + -- + -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"] + -- + -- so lines are the only ones that can have nested layout, since they + -- have a known indentation level. + -- + -- eg: we can't have this: + -- + -- > if ... { + -- > } else + -- > other + -- + -- because other cannot nest under else, since else doesn't start a line + -- so cannot have nested layout. It'd have to be: + -- + -- > if ... { + -- > } + -- > else + -- > other + -- + -- but that's not so common, people would normally use layout or + -- brackets not both in a single @if else@ construct. + -- + -- > if ... { foo : bar } + -- > else + -- > other + -- + -- this is OK + Line LineNo Indent HasTabs String + | Span LineNo String -- ^ span in a line, following brackets + | OpenBracket LineNo | CloseBracket LineNo + +type Indent = Int +type HasTabs = Bool + +-- | Tokenise a single line, splitting on '{' '}' and the spans in between. +-- Also trims leading & trailing space on those spans within the line. +tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token] +tokeniseLine (n0, i, t, l) = case split n0 l of + (Span _ l':ss) -> Line n0 i t l' :ss + cs -> cs + where split _ "" = [] + split n s = case span (\c -> c /='}' && c /= '{') s of + ("", '{' : s') -> OpenBracket n : split n s' + (w , '{' : s') -> mkspan n w (OpenBracket n : split n s') + ("", '}' : s') -> CloseBracket n : split n s' + (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') + (w , _) -> mkspan n w [] + + mkspan n s ss | null s' = ss + | otherwise = Span n s' : ss + where s' = trimTrailing (trimLeading s) + +tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token] +tokeniseLineFlat (n0, i, t, l) + | null l' = [] + | otherwise = [Line n0 i t l'] + where + l' = trimTrailing (trimLeading l) + +trimLeading, trimTrailing :: String -> String +trimLeading = dropWhile isSpace +trimTrailing = dropWhileEndLE isSpace + + +type SyntaxTree = Tree (LineNo, HasTabs, String) + +-- | Parse the stream of tokens into a tree of them, based on indent \/ layout +mkTree :: [Token] -> ParseResult [SyntaxTree] +mkTree toks = + layout 0 [] toks >>= \(trees, trailing) -> case trailing of + [] -> return trees + OpenBracket n:_ -> syntaxError n "mismatched brackets, unexpected {" + CloseBracket n:_ -> syntaxError n "mismatched brackets, unexpected }" + -- the following two should never happen: + Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l + Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l + + +-- | Parse the stream of tokens into a tree of them, based on indent +-- This parse state expect to be in a layout context, though possibly +-- nested within a braces context so we may still encounter closing braces. +layout :: Indent -- ^ indent level of the parent\/previous line + -> [SyntaxTree] -- ^ accumulating param, trees in this level + -> [Token] -- ^ remaining tokens + -> ParseResult ([SyntaxTree], [Token]) + -- ^ collected trees on this level and trailing tokens +layout _ a [] = return (reverse a, []) +layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss) +layout i a (Line n _ t l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + layout i (Node (n,t,l) sub:a) ss' + +layout i a (Span n l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + layout i (Node (n,False,l) sub:a) ss' + +-- look ahead to see if following lines are more indented, giving a sub-tree +layout i a (Line n i' t l:ss) = do + lookahead <- layout (i'+1) [] ss + case lookahead of + ([], _) -> layout i (Node (n,t,l) [] :a) ss + (ts, ss') -> layout i (Node (n,t,l) ts :a) ss' + +layout _ _ ( OpenBracket n :_) = syntaxError n "unexpected '{'" +layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss) +layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: " + ++ show l + +-- | Parse the stream of tokens into a tree of them, based on explicit braces +-- This parse state expects to find a closing bracket. +braces :: LineNo -- ^ line of the '{', used for error messages + -> [SyntaxTree] -- ^ accumulating param, trees in this level + -> [Token] -- ^ remaining tokens + -> ParseResult ([SyntaxTree],[Token]) + -- ^ collected trees on this level and trailing tokens +braces m a (Line n _ t l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + braces m (Node (n,t,l) sub:a) ss' + +braces m a (Span n l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + braces m (Node (n,False,l) sub:a) ss' + +braces m a (Line n i t l:ss) = do + lookahead <- layout (i+1) [] ss + case lookahead of + ([], _) -> braces m (Node (n,t,l) [] :a) ss + (ts, ss') -> braces m (Node (n,t,l) ts :a) ss' + +braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss +braces _ a (CloseBracket _:ss) = return (reverse a, ss) +braces n _ [] = syntaxError n $ "opening brace '{'" + ++ "has no matching closing brace '}'" +braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'" + +-- | Convert the parse tree into the Field AST +-- Also check for dodgy uses of tabs in indentation. +mkField :: Int -> SyntaxTree -> ParseResult Field +mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n +mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of + ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l + (name, rest) -> case trimLeading rest of + (':':rest') -> do let followingLines = concatMap Tree.flatten ts + tabs = not (null [()| (_,True,_) <- followingLines ]) + if tabs && d >= 1 + then tabsError n + else return $ F n (map toLower name) + (fieldValue rest' followingLines) + rest' -> do ts' <- mapM (mkField (d+1)) ts + return (Section n (map toLower name) rest' ts') + where fieldValue firstLine followingLines = + let firstLine' = trimLeading firstLine + followingLines' = map (\(_,_,s) -> stripDot s) followingLines + allLines | null firstLine' = followingLines' + | otherwise = firstLine' : followingLines' + in intercalate "\n" allLines + stripDot "." = "" + stripDot s = s + +-- | Convert if/then/else 'Section's to 'IfBlock's +ifelse :: [Field] -> ParseResult [Field] +ifelse [] = return [] +ifelse (Section n "if" cond thenpart + :Section _ "else" as elsepart:fs) + | null cond = syntaxError n "'if' with missing condition" + | null thenpart = syntaxError n "'then' branch of 'if' is empty" + | not (null as) = syntaxError n "'else' takes no arguments" + | null elsepart = syntaxError n "'else' branch of 'if' is empty" + | otherwise = do tp <- ifelse thenpart + ep <- ifelse elsepart + fs' <- ifelse fs + return (IfBlock n cond tp ep:fs') +ifelse (Section n "if" cond thenpart:fs) + | null cond = syntaxError n "'if' with missing condition" + | null thenpart = syntaxError n "'then' branch of 'if' is empty" + | otherwise = do tp <- ifelse thenpart + fs' <- ifelse fs + return (IfBlock n cond tp []:fs') +ifelse (Section n "else" _ _:_) = syntaxError n + "stray 'else' with no preceding 'if'" +ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs' + fs''' <- ifelse fs + return (Section n s a fs'' : fs''') +ifelse (f:fs) = do fs' <- ifelse fs + return (f : fs') + +------------------------------------------------------------------------------ + +-- |parse a module name +parseModuleNameQ :: ReadP r ModuleName +parseModuleNameQ = parseQuoted parse <++ parse + +parseFilePathQ :: ReadP r FilePath +parseFilePathQ = parseTokenQ + -- removed until normalise is no longer broken, was: + -- liftM normalise parseTokenQ + +betweenSpaces :: ReadP r a -> ReadP r a +betweenSpaces act = do skipSpaces + res <- act + skipSpaces + return res + +parseBuildTool :: ReadP r Dependency +parseBuildTool = do name <- parseBuildToolNameQ + ver <- betweenSpaces $ + parseVersionRangeQ <++ return anyVersion + return $ Dependency name ver + +parseBuildToolNameQ :: ReadP r PackageName +parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName + +-- like parsePackageName but accepts symbols in components +parseBuildToolName :: ReadP r PackageName +parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-') + return (PackageName (intercalate "-" ns)) + where component = do + cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_') + if all isDigit cs then pfail else return cs + +-- pkg-config allows versions and other letters in package names, +-- eg "gtk+-2.0" is a valid pkg-config package _name_. +-- It then has a package version number like 2.10.13 +parsePkgconfigDependency :: ReadP r Dependency +parsePkgconfigDependency = do name <- munch1 + (\c -> isAlphaNum c || c `elem` "+-._") + ver <- betweenSpaces $ + parseVersionRangeQ <++ return anyVersion + return $ Dependency (PackageName name) ver + +parsePackageNameQ :: ReadP r PackageName +parsePackageNameQ = parseQuoted parse <++ parse + +parseVersionRangeQ :: ReadP r VersionRange +parseVersionRangeQ = parseQuoted parse <++ parse + +parseOptVersion :: ReadP r Version +parseOptVersion = parseQuoted ver <++ ver + where ver :: ReadP r Version + ver = parse <++ return noVersion + noVersion = Version [] [] + +parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) +parseTestedWithQ = parseQuoted tw <++ tw + where + tw :: ReadP r (CompilerFlavor,VersionRange) + tw = do compiler <- parseCompilerFlavorCompat + version <- betweenSpaces $ parse <++ return anyVersion + return (compiler,version) + +parseLicenseQ :: ReadP r License +parseLicenseQ = parseQuoted parse <++ parse + +-- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a +-- because the "compat" version of ReadP isn't quite powerful enough. In +-- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a +-- Hence the trick above to make 'lic' polymorphic. + +parseLanguageQ :: ReadP r Language +parseLanguageQ = parseQuoted parse <++ parse + +parseExtensionQ :: ReadP r Extension +parseExtensionQ = parseQuoted parse <++ parse + +parseHaskellString :: ReadP r String +parseHaskellString = readS_to_P reads + +parseTokenQ :: ReadP r String +parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') + +parseTokenQ' :: ReadP r String +parseTokenQ' = parseHaskellString <++ munch1 (not . isSpace) + +parseSepList :: ReadP r b + -> ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseSepList sepr p = sepBy p separator + where separator = betweenSpaces sepr + +parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseSpaceList p = sepBy p skipSpaces + +parseCommaList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseCommaList = parseSepList (ReadP.char ',') + +parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseOptCommaList = parseSepList (optional (ReadP.char ',')) + +parseQuoted :: ReadP r a -> ReadP r a +parseQuoted = between (ReadP.char '"') (ReadP.char '"') + +parseFreeText :: ReadP.ReadP s String +parseFreeText = ReadP.munch (const True) + +-- -------------------------------------------- +-- ** Pretty printing + +showFilePath :: FilePath -> Doc +showFilePath "" = empty +showFilePath x = showToken x + +showToken :: String -> Doc +showToken str + | not (any dodgy str) && + not (null str) = text str + | otherwise = text (show str) + where dodgy c = isSpace c || c == ',' + +showTestedWith :: (CompilerFlavor,VersionRange) -> Doc +showTestedWith (compiler, version) = text (show compiler) <+> disp version + +-- | Pretty-print free-format text, ensuring that it is vertically aligned, +-- and with blank lines replaced by dots for correct re-parsing. +showFreeText :: String -> Doc +showFreeText "" = empty +showFreeText s = vcat [text (if null l then "." else l) | l <- lines_ s] + +-- | 'lines_' breaks a string up into a list of strings at newline +-- characters. The resulting strings do not contain newlines. +lines_ :: String -> [String] +lines_ [] = [""] +lines_ s = let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines_ s'' + +-- | the indentation used for pretty printing +indentWith :: Int +indentWith = 4 diff --git a/Distribution/ReadE.hs b/Distribution/ReadE.hs new file mode 100644 --- /dev/null +++ b/Distribution/ReadE.hs @@ -0,0 +1,51 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ReadE +-- Copyright : Jose Iborra 2008 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Simple parsing with failure + +module Distribution.ReadE ( + -- * ReadE + ReadE(..), succeedReadE, failReadE, + -- * Projections + parseReadE, readEOrFail, + readP_to_E + ) where + +import Distribution.Compat.ReadP +import Data.Char ( isSpace ) + +-- | Parser with simple error reporting +newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a} +type ErrorMsg = String + +instance Functor ReadE where + fmap f (ReadE p) = ReadE $ \txt -> case p txt of + Right a -> Right (f a) + Left err -> Left err + +succeedReadE :: (String -> a) -> ReadE a +succeedReadE f = ReadE (Right . f) + +failReadE :: ErrorMsg -> ReadE a +failReadE = ReadE . const . Left + +parseReadE :: ReadE a -> ReadP r a +parseReadE (ReadE p) = do + txt <- look + either fail return (p txt) + +readEOrFail :: ReadE a -> String -> a +readEOrFail r = either error id . runReadE r + +readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a +readP_to_E err r = + ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt + , all isSpace s ] + of [] -> Left (err txt) + (p:_) -> Right p diff --git a/Distribution/Simple.hs b/Distribution/Simple.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple.hs @@ -0,0 +1,700 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the command line front end to the Simple build system. When given +-- the parsed command-line args and package information, is able to perform +-- basic commands like configure, build, install, register, etc. +-- +-- This module exports the main functions that Setup.hs scripts use. It +-- re-exports the 'UserHooks' type, the standard entry points like +-- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of +-- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own +-- behaviour. +-- +-- This module isn't called \"Simple\" because it's simple. Far from +-- it. It's called \"Simple\" because it does complicated things to +-- simple software. +-- +-- The original idea was that there could be different build systems that all +-- presented the same compatible command line interfaces. There is still a +-- "Distribution.Make" system but in practice no packages use it. + +{- +Work around this warning: +libraries/Cabal/Distribution/Simple.hs:78:0: + Warning: In the use of `runTests' + (imported from Distribution.Simple.UserHooks): + Deprecated: "Please use the new testing interface instead!" +-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module Distribution.Simple ( + module Distribution.Package, + module Distribution.Version, + module Distribution.License, + module Distribution.Simple.Compiler, + module Language.Haskell.Extension, + -- * Simple interface + defaultMain, defaultMainNoRead, defaultMainArgs, + -- * Customization + UserHooks(..), Args, + defaultMainWithHooks, defaultMainWithHooksArgs, + -- ** Standard sets of hooks + simpleUserHooks, + autoconfUserHooks, + defaultUserHooks, emptyUserHooks, + -- ** Utils + defaultHookedPackageDesc + ) where + +-- local +import Distribution.Simple.Compiler hiding (Flag) +import Distribution.Simple.UserHooks +import Distribution.Package --must not specify imports, since we're exporting module. +import Distribution.PackageDescription + ( PackageDescription(..), GenericPackageDescription, Executable(..) + , updatePackageDescription, hasLibs + , HookedBuildInfo, emptyHookedBuildInfo ) +import Distribution.PackageDescription.Parse + ( readPackageDescription, readHookedBuildInfo ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.Simple.Program + ( defaultProgramConfiguration, addKnownPrograms, builtinPrograms + , restoreProgramConfiguration, reconfigurePrograms ) +import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler) +import Distribution.Simple.Setup +import Distribution.Simple.Command + +import Distribution.Simple.Build ( build, repl ) +import Distribution.Simple.SrcDist ( sdist ) +import Distribution.Simple.Register + ( register, unregister ) + +import Distribution.Simple.Configure + ( getPersistBuildConfig, maybeGetPersistBuildConfig + , writePersistBuildConfig, checkPersistBuildConfigOutdated + , configure, checkForeignDeps ) + +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.Bench (bench) +import Distribution.Simple.BuildPaths ( srcPref) +import Distribution.Simple.Test (test) +import Distribution.Simple.Install (install) +import Distribution.Simple.Haddock (haddock, hscolour) +import Distribution.Simple.Utils + (die, notice, info, warn, setupMessage, chattyTry, + defaultPackageDesc, defaultHookedPackageDesc, + rawSystemExitWithEnv, cabalVersion, topHandler ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Verbosity +import Language.Haskell.Extension +import Distribution.Version +import Distribution.License +import Distribution.Text + ( display ) + +-- Base +import System.Environment(getArgs, getProgName) +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 Control.Monad (when) +import Data.List (intercalate, unionBy, nub, (\\)) + +-- | A simple implementation of @main@ for a Cabal setup script. +-- It reads the package description file using IO, and performs the +-- action specified on the command line. +defaultMain :: IO () +defaultMain = getArgs >>= defaultMainHelper simpleUserHooks + +-- | A version of 'defaultMain' that is passed the command line +-- arguments, rather than getting them from the environment. +defaultMainArgs :: [String] -> IO () +defaultMainArgs = defaultMainHelper simpleUserHooks + +-- | A customizable version of 'defaultMain'. +defaultMainWithHooks :: UserHooks -> IO () +defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks + +-- | A customizable version of 'defaultMain' that also takes the command +-- line arguments. +defaultMainWithHooksArgs :: UserHooks -> [String] -> IO () +defaultMainWithHooksArgs = defaultMainHelper + +-- | Like 'defaultMain', but accepts the package description as input +-- rather than using IO to read it. +defaultMainNoRead :: GenericPackageDescription -> IO () +defaultMainNoRead pkg_descr = + getArgs >>= + defaultMainHelper simpleUserHooks { readDesc = return (Just pkg_descr) } + +defaultMainHelper :: UserHooks -> Args -> IO () +defaultMainHelper hooks args = topHandler $ + case commandsRun (globalCommand commands) commands args of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (flags, commandParse) -> + case commandParse of + _ | fromFlag (globalVersion flags) -> printVersion + | fromFlag (globalNumericVersion flags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action + + where + printHelp help = getProgName >>= putStr . help + printOptionsList = putStr . unlines + printErrors errs = do + putStr (intercalate "\n" errs) + exitWith (ExitFailure 1) + printNumericVersion = putStrLn $ display cabalVersion + printVersion = putStrLn $ "Cabal library version " + ++ display cabalVersion + + progs = addKnownPrograms (hookedPrograms hooks) defaultProgramConfiguration + commands = + [configureCommand progs `commandAddAction` \fs as -> + configureAction hooks fs as >> return () + ,buildCommand progs `commandAddAction` buildAction hooks + ,replCommand progs `commandAddAction` replAction hooks + ,installCommand `commandAddAction` installAction hooks + ,copyCommand `commandAddAction` copyAction hooks + ,haddockCommand `commandAddAction` haddockAction hooks + ,cleanCommand `commandAddAction` cleanAction hooks + ,sdistCommand `commandAddAction` sdistAction hooks + ,hscolourCommand `commandAddAction` hscolourAction hooks + ,registerCommand `commandAddAction` registerAction hooks + ,unregisterCommand `commandAddAction` unregisterAction hooks + ,testCommand `commandAddAction` testAction hooks + ,benchmarkCommand `commandAddAction` benchAction hooks + ] + +-- | Combine the preprocessors in the given hooks with the +-- preprocessors built into cabal. +allSuffixHandlers :: UserHooks + -> [PPSuffixHandler] +allSuffixHandlers hooks + = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers + where + overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] + overridesPP = unionBy (\x y -> fst x == fst y) + +configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo +configureAction hooks flags args = do + let distPref = fromFlag $ configDistPref flags + pbi <- preConf hooks args flags + + (mb_pd_file, pkg_descr0) <- confPkgDescr + + -- get_pkg_descr (configVerbosity flags') + --let pkg_descr = updatePackageDescription pbi pkg_descr0 + let epkg_descr = (pkg_descr0, pbi) + + --(warns, ers) <- sanityCheckPackage pkg_descr + --errorOut (configVerbosity flags') warns ers + + localbuildinfo0 <- confHook hooks epkg_descr flags + + -- remember the .cabal filename if we know it + -- and all the extra command line args + let localbuildinfo = localbuildinfo0 { + pkgDescrFile = mb_pd_file, + extraConfigArgs = args + } + writePersistBuildConfig distPref localbuildinfo + + let pkg_descr = localPkgDescr localbuildinfo + postConf hooks args flags pkg_descr localbuildinfo + return localbuildinfo + where + verbosity = fromFlag (configVerbosity flags) + confPkgDescr :: IO (Maybe FilePath, GenericPackageDescription) + confPkgDescr = do + mdescr <- readDesc hooks + case mdescr of + Just descr -> return (Nothing, descr) + Nothing -> do + pdfile <- defaultPackageDesc verbosity + descr <- readPackageDescription verbosity pdfile + return (Just pdfile, descr) + +buildAction :: UserHooks -> BuildFlags -> Args -> IO () +buildAction hooks flags args = do + let distPref = fromFlag $ buildDistPref flags + verbosity = fromFlag $ buildVerbosity flags + + lbi <- getBuildConfig hooks verbosity distPref + progs <- reconfigurePrograms verbosity + (buildProgramPaths flags) + (buildProgramArgs flags) + (withPrograms lbi) + + hookedAction preBuild buildHook postBuild + (return lbi { withPrograms = progs }) + hooks flags { buildArgs = args } args + +replAction :: UserHooks -> ReplFlags -> Args -> IO () +replAction hooks flags args = do + let distPref = fromFlag $ replDistPref flags + verbosity = fromFlag $ replVerbosity flags + + lbi <- getBuildConfig hooks verbosity distPref + progs <- reconfigurePrograms verbosity + (replProgramPaths flags) + (replProgramArgs flags) + (withPrograms lbi) + + pbi <- preRepl hooks args flags + let lbi' = lbi { withPrograms = progs } + pkg_descr0 = localPkgDescr lbi' + pkg_descr = updatePackageDescription pbi pkg_descr0 + replHook hooks pkg_descr lbi' hooks flags args + postRepl hooks args flags pkg_descr lbi' + +hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () +hscolourAction hooks flags args + = do let distPref = fromFlag $ hscolourDistPref flags + verbosity = fromFlag $ hscolourVerbosity flags + hookedAction preHscolour hscolourHook postHscolour + (getBuildConfig hooks verbosity distPref) + hooks flags args + +haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () +haddockAction hooks flags args = do + let distPref = fromFlag $ haddockDistPref flags + verbosity = fromFlag $ haddockVerbosity flags + + lbi <- getBuildConfig hooks verbosity distPref + progs <- reconfigurePrograms verbosity + (haddockProgramPaths flags) + (haddockProgramArgs flags) + (withPrograms lbi) + + hookedAction preHaddock haddockHook postHaddock + (return lbi { withPrograms = progs }) + hooks flags args + +cleanAction :: UserHooks -> CleanFlags -> Args -> IO () +cleanAction hooks flags args = do + pbi <- preClean hooks args flags + + pdfile <- defaultPackageDesc verbosity + ppd <- readPackageDescription verbosity pdfile + let pkg_descr0 = flattenPackageDescription ppd + -- We don't sanity check for clean as an error + -- here would prevent cleaning: + --sanityCheckHookedBuildInfo pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + + cleanHook hooks pkg_descr () hooks flags + postClean hooks args flags pkg_descr () + where verbosity = fromFlag (cleanVerbosity flags) + +copyAction :: UserHooks -> CopyFlags -> Args -> IO () +copyAction hooks flags args + = do let distPref = fromFlag $ copyDistPref flags + verbosity = fromFlag $ copyVerbosity flags + hookedAction preCopy copyHook postCopy + (getBuildConfig hooks verbosity distPref) + hooks flags args + +installAction :: UserHooks -> InstallFlags -> Args -> IO () +installAction hooks flags args + = do let distPref = fromFlag $ installDistPref flags + verbosity = fromFlag $ installVerbosity flags + hookedAction preInst instHook postInst + (getBuildConfig hooks verbosity distPref) + hooks flags args + +sdistAction :: UserHooks -> SDistFlags -> Args -> IO () +sdistAction hooks flags args = do + let distPref = fromFlag $ sDistDistPref flags + pbi <- preSDist hooks args flags + + mlbi <- maybeGetPersistBuildConfig distPref + pdfile <- defaultPackageDesc verbosity + ppd <- readPackageDescription verbosity pdfile + let pkg_descr0 = flattenPackageDescription ppd + sanityCheckHookedBuildInfo pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + + sDistHook hooks pkg_descr mlbi hooks flags + postSDist hooks args flags pkg_descr mlbi + where verbosity = fromFlag (sDistVerbosity flags) + +testAction :: UserHooks -> TestFlags -> Args -> IO () +testAction hooks flags args = do + let distPref = fromFlag $ testDistPref flags + verbosity = fromFlag $ testVerbosity flags + localBuildInfo <- getBuildConfig hooks verbosity distPref + let pkg_descr = localPkgDescr localBuildInfo + -- It is safe to do 'runTests' before the new test handler because the + -- default action is a no-op and if the package uses the old test interface + -- the new handler will find no tests. + runTests hooks args False pkg_descr localBuildInfo + hookedActionWithArgs preTest testHook postTest + (getBuildConfig hooks verbosity distPref) + hooks flags args + +benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO () +benchAction hooks flags args = do + let distPref = fromFlag $ benchmarkDistPref flags + verbosity = fromFlag $ benchmarkVerbosity flags + hookedActionWithArgs preBench benchHook postBench + (getBuildConfig hooks verbosity distPref) + hooks flags args + +registerAction :: UserHooks -> RegisterFlags -> Args -> IO () +registerAction hooks flags args + = do let distPref = fromFlag $ regDistPref flags + verbosity = fromFlag $ regVerbosity flags + hookedAction preReg regHook postReg + (getBuildConfig hooks verbosity distPref) + hooks flags args + +unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () +unregisterAction hooks flags args + = do let distPref = fromFlag $ regDistPref flags + verbosity = fromFlag $ regVerbosity flags + hookedAction preUnreg unregHook postUnreg + (getBuildConfig hooks verbosity distPref) + hooks flags args + +hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo) + -> (UserHooks -> PackageDescription -> LocalBuildInfo + -> UserHooks -> flags -> IO ()) + -> (UserHooks -> Args -> flags -> PackageDescription + -> LocalBuildInfo -> IO ()) + -> IO LocalBuildInfo + -> UserHooks -> flags -> Args -> IO () +hookedAction pre_hook cmd_hook = + hookedActionWithArgs pre_hook (\h _ pd lbi uh flags -> cmd_hook h pd lbi uh flags) + +hookedActionWithArgs :: (UserHooks -> Args -> flags -> IO HookedBuildInfo) + -> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo + -> UserHooks -> flags -> IO ()) + -> (UserHooks -> Args -> flags -> PackageDescription + -> LocalBuildInfo -> IO ()) + -> IO LocalBuildInfo + -> UserHooks -> flags -> Args -> IO () +hookedActionWithArgs pre_hook cmd_hook post_hook get_build_config hooks flags args = do + pbi <- pre_hook hooks args flags + localbuildinfo <- get_build_config + let pkg_descr0 = localPkgDescr localbuildinfo + --pkg_descr0 <- get_pkg_descr (get_verbose flags) + sanityCheckHookedBuildInfo pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + -- TODO: should we write the modified package descr back to the + -- localbuildinfo? + cmd_hook hooks args pkg_descr localbuildinfo hooks flags + post_hook hooks args flags pkg_descr localbuildinfo + +sanityCheckHookedBuildInfo :: PackageDescription -> HookedBuildInfo -> IO () +sanityCheckHookedBuildInfo PackageDescription { library = Nothing } (Just _,_) + = die $ "The buildinfo contains info for a library, " + ++ "but the package does not have a library." + +sanityCheckHookedBuildInfo pkg_descr (_, hookExes) + | not (null nonExistant) + = die $ "The buildinfo contains info for an executable called '" + ++ head nonExistant ++ "' but the package does not have a " + ++ "executable with that name." + where + pkgExeNames = nub (map exeName (executables pkg_descr)) + hookExeNames = nub (map fst hookExes) + nonExistant = hookExeNames \\ pkgExeNames + +sanityCheckHookedBuildInfo _ _ = return () + + +getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo +getBuildConfig hooks verbosity distPref = do + lbi_wo_programs <- getPersistBuildConfig distPref + -- Restore info about unconfigured programs, since it is not serialized + let lbi = lbi_wo_programs { + withPrograms = restoreProgramConfiguration + (builtinPrograms ++ hookedPrograms hooks) + (withPrograms lbi_wo_programs) + } + + case pkgDescrFile lbi of + Nothing -> return lbi + Just pkg_descr_file -> do + outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file + if outdated + then reconfigure pkg_descr_file lbi + else return lbi + + where + reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo + reconfigure pkg_descr_file lbi = do + notice verbosity $ pkg_descr_file ++ " has been changed. " + ++ "Re-configuring with most recently used options. " + ++ "If this fails, please run configure manually.\n" + let cFlags = configFlags lbi + let cFlags' = cFlags { + -- Since the list of unconfigured programs is not serialized, + -- restore it to the same value as normally used at the beginning + -- of a configure run: + configPrograms = restoreProgramConfiguration + (builtinPrograms ++ hookedPrograms hooks) + (configPrograms cFlags), + + -- Use the current, not saved verbosity level: + configVerbosity = Flag verbosity + } + configureAction hooks cFlags' (extraConfigArgs lbi) + + +-- -------------------------------------------------------------------------- +-- Cleaning + +clean :: PackageDescription -> CleanFlags -> IO () +clean pkg_descr flags = do + let distPref = fromFlag $ cleanDistPref flags + notice verbosity "cleaning..." + + maybeConfig <- if fromFlag (cleanSaveConf flags) + then maybeGetPersistBuildConfig distPref + else return Nothing + + -- remove the whole dist/ directory rather than tracking exactly what files + -- we created in there. + chattyTry "removing dist/" $ do + exists <- doesDirectoryExist distPref + when exists (removeDirectoryRecursive distPref) + + -- Any extra files the user wants to remove + mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr) + + -- If the user wanted to save the config, write it back + maybe (return ()) (writePersistBuildConfig distPref) maybeConfig + + where + removeFileOrDirectory :: FilePath -> IO () + removeFileOrDirectory fname = do + isDir <- doesDirectoryExist fname + isFile <- doesFileExist fname + if isDir then removeDirectoryRecursive fname + else when isFile $ removeFile fname + verbosity = fromFlag (cleanVerbosity flags) + +-- -------------------------------------------------------------------------- +-- Default hooks + +-- | Hooks that correspond to a plain instantiation of the +-- \"simple\" build system +simpleUserHooks :: UserHooks +simpleUserHooks = + emptyUserHooks { + confHook = configure, + postConf = finalChecks, + buildHook = defaultBuildHook, + replHook = defaultReplHook, + copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params + testHook = defaultTestHook, + benchHook = defaultBenchHook, + instHook = defaultInstallHook, + sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h), + cleanHook = \p _ _ f -> clean p f, + hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f, + haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f, + regHook = defaultRegHook, + unregHook = \p l _ f -> unregister p l f + } + where + finalChecks _args flags pkg_descr lbi = + checkForeignDeps pkg_descr lbi (lessVerbose verbosity) + where + verbosity = fromFlag (configVerbosity flags) + +-- | Basic autoconf 'UserHooks': +-- +-- * 'postConf' runs @.\/configure@, if present. +-- +-- * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst', +-- 'preReg' and 'preUnreg' read additional build information from +-- /package/@.buildinfo@, if present. +-- +-- Thus @configure@ can use local system information to generate +-- /package/@.buildinfo@ and possibly other files. + +{-# DEPRECATED defaultUserHooks + "Use simpleUserHooks or autoconfUserHooks, unless you need Cabal-1.2\n compatibility in which case you must stick with defaultUserHooks" #-} +defaultUserHooks :: UserHooks +defaultUserHooks = autoconfUserHooks { + confHook = \pkg flags -> do + let verbosity = fromFlag (configVerbosity flags) + warn verbosity + "defaultUserHooks in Setup script is deprecated." + confHook autoconfUserHooks pkg flags, + postConf = oldCompatPostConf + } + -- This is the annoying old version that only runs configure if it exists. + -- It's here for compatibility with existing Setup.hs scripts. See: + -- https://github.com/haskell/cabal/issues/158 + where oldCompatPostConf args flags pkg_descr lbi + = do let verbosity = fromFlag (configVerbosity flags) + noExtraFlags args + confExists <- doesFileExist "configure" + when confExists $ + runConfigureScript verbosity + backwardsCompatHack flags lbi + + pbi <- getHookedBuildInfo verbosity + sanityCheckHookedBuildInfo pkg_descr pbi + let pkg_descr' = updatePackageDescription pbi pkg_descr + postConf simpleUserHooks args flags pkg_descr' lbi + + backwardsCompatHack = True + +autoconfUserHooks :: UserHooks +autoconfUserHooks + = simpleUserHooks + { + postConf = defaultPostConf, + preBuild = \_ flags -> + -- not using 'readHook' here because 'build' takes + -- extra args + getHookedBuildInfo $ fromFlag $ buildVerbosity flags, + preClean = readHook cleanVerbosity, + preCopy = readHook copyVerbosity, + preInst = readHook installVerbosity, + preHscolour = readHook hscolourVerbosity, + preHaddock = readHook haddockVerbosity, + preReg = readHook regVerbosity, + preUnreg = readHook regVerbosity + } + where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () + defaultPostConf args flags pkg_descr lbi + = do let verbosity = fromFlag (configVerbosity flags) + noExtraFlags args + confExists <- doesFileExist "configure" + if confExists + then runConfigureScript verbosity + backwardsCompatHack flags lbi + else die "configure script not found." + + pbi <- getHookedBuildInfo verbosity + sanityCheckHookedBuildInfo pkg_descr pbi + let pkg_descr' = updatePackageDescription pbi pkg_descr + postConf simpleUserHooks args flags pkg_descr' lbi + + backwardsCompatHack = False + + readHook :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo + readHook get_verbosity a flags = do + noExtraFlags a + getHookedBuildInfo verbosity + where + verbosity = fromFlag (get_verbosity flags) + +runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo + -> IO () +runConfigureScript verbosity backwardsCompatHack flags lbi = do + + env <- getEnvironment + let programConfig = withPrograms lbi + (ccProg, ccFlags) <- configureCCompiler verbosity programConfig + -- The C compiler's compilation and linker flags (e.g. + -- "C compiler flags" and "Gcc Linker flags" from GHC) have already + -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS + -- to ccFlags + -- We don't try and tell configure which ld to use, as we don't have + -- a way to pass its flags too + let env' = appendToEnvironment ("CFLAGS", unwords ccFlags) + env + args' = args ++ ["--with-gcc=" ++ ccProg] + handleNoWindowsSH $ + rawSystemExitWithEnv verbosity "sh" args' env' + + where + args = "./configure" : configureArgs backwardsCompatHack flags + + appendToEnvironment (key, val) [] = [(key, val)] + appendToEnvironment (key, val) (kv@(k, v) : rest) + | key == k = (key, v ++ " " ++ val) : rest + | otherwise = kv : appendToEnvironment (key, val) rest + + handleNoWindowsSH action + | buildOS /= Windows + = action + + | otherwise + = action + `catchIO` \ioe -> if isDoesNotExistError ioe + then die notFoundMsg + else throwIO ioe + + notFoundMsg = "The package has a './configure' script. This requires a " + ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin." + +getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo +getHookedBuildInfo verbosity = do + maybe_infoFile <- defaultHookedPackageDesc + case maybe_infoFile of + Nothing -> return emptyHookedBuildInfo + Just infoFile -> do + info verbosity $ "Reading parameters from " ++ infoFile + readHookedBuildInfo verbosity infoFile + +defaultTestHook :: Args -> PackageDescription -> LocalBuildInfo + -> UserHooks -> TestFlags -> IO () +defaultTestHook args pkg_descr localbuildinfo _ flags = + test args pkg_descr localbuildinfo flags + +defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo + -> UserHooks -> BenchmarkFlags -> IO () +defaultBenchHook args pkg_descr localbuildinfo _ flags = + bench args pkg_descr localbuildinfo flags + +defaultInstallHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> InstallFlags -> IO () +defaultInstallHook pkg_descr localbuildinfo _ flags = do + let copyFlags = defaultCopyFlags { + copyDistPref = installDistPref flags, + copyDest = toFlag NoCopyDest, + copyVerbosity = installVerbosity flags + } + install pkg_descr localbuildinfo copyFlags + let registerFlags = defaultRegisterFlags { + regDistPref = installDistPref flags, + regInPlace = installInPlace flags, + regPackageDB = installPackageDB flags, + regVerbosity = installVerbosity flags + } + when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags + +defaultBuildHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> BuildFlags -> IO () +defaultBuildHook pkg_descr localbuildinfo hooks flags = + build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) + +defaultReplHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> ReplFlags -> [String] -> IO () +defaultReplHook pkg_descr localbuildinfo hooks flags args = + repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args + +defaultRegHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> RegisterFlags -> IO () +defaultRegHook pkg_descr localbuildinfo _ flags = + if hasLibs pkg_descr + then register pkg_descr localbuildinfo flags + else setupMessage verbosity + "Package contains no library to register:" (packageId pkg_descr) + where verbosity = fromFlag (regVerbosity flags) diff --git a/Distribution/Simple/Bench.hs b/Distribution/Simple/Bench.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Bench.hs @@ -0,0 +1,128 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Bench +-- Copyright : Johan Tibell 2011 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into running the benchmarks in a built +-- package. It performs the \"@.\/setup bench@\" action. It runs +-- benchmarks designated in the package description. + +module Distribution.Simple.Bench + ( bench + ) where + +import qualified Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(buildable) + , Benchmark(..), BenchmarkInterface(..), benchmarkType, hasBenchmarks ) +import Distribution.Simple.BuildPaths ( exeExtension ) +import Distribution.Simple.Compiler ( compilerInfo ) +import Distribution.Simple.InstallDirs + ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) + , substPathTemplate , toPathTemplate, PathTemplate ) +import qualified Distribution.Simple.LocalBuildInfo as LBI + ( LocalBuildInfo(..) ) +import Distribution.Simple.Setup ( BenchmarkFlags(..), fromFlag ) +import Distribution.Simple.UserHooks ( Args ) +import Distribution.Simple.Utils ( die, notice, rawSystemExitCode ) +import Distribution.Text + +import Control.Monad ( when, unless ) +import System.Exit ( ExitCode(..), exitFailure, exitWith ) +import System.Directory ( doesFileExist ) +import System.FilePath ( (), (<.>) ) + +-- | Perform the \"@.\/setup bench@\" action. +bench :: Args -- ^positional command-line arguments + -> PD.PackageDescription -- ^information from the .cabal file + -> LBI.LocalBuildInfo -- ^information from the configure step + -> BenchmarkFlags -- ^flags sent to benchmark + -> IO () +bench args pkg_descr lbi flags = do + let verbosity = fromFlag $ benchmarkVerbosity flags + benchmarkNames = args + pkgBenchmarks = PD.benchmarks pkg_descr + enabledBenchmarks = [ t | t <- pkgBenchmarks + , PD.benchmarkEnabled t + , PD.buildable (PD.benchmarkBuildInfo t) ] + + -- Run the benchmark + doBench :: PD.Benchmark -> IO ExitCode + doBench bm = + case PD.benchmarkInterface bm of + PD.BenchmarkExeV10 _ _ -> do + let cmd = LBI.buildDir lbi PD.benchmarkName bm + PD.benchmarkName bm <.> exeExtension + options = map (benchOption pkg_descr lbi bm) $ + benchmarkOptions flags + name = PD.benchmarkName bm + -- Check that the benchmark executable exists. + exists <- doesFileExist cmd + unless exists $ die $ + "Error: Could not find benchmark program \"" + ++ cmd ++ "\". Did you build the package first?" + + notice verbosity $ startMessage name + -- This will redirect the child process + -- stdout/stderr to the parent process. + exitcode <- rawSystemExitCode verbosity cmd options + notice verbosity $ finishMessage name exitcode + return exitcode + + _ -> do + notice verbosity $ "No support for running " + ++ "benchmark " ++ PD.benchmarkName bm ++ " of type: " + ++ show (disp $ PD.benchmarkType bm) + exitFailure + + when (not $ PD.hasBenchmarks pkg_descr) $ do + notice verbosity "Package has no benchmarks." + exitWith ExitSuccess + + when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ + die $ "No benchmarks enabled. Did you remember to configure with " + ++ "\'--enable-benchmarks\'?" + + bmsToRun <- case benchmarkNames of + [] -> return enabledBenchmarks + names -> flip mapM names $ \bmName -> + let benchmarkMap = zip enabledNames enabledBenchmarks + enabledNames = map PD.benchmarkName enabledBenchmarks + allNames = map PD.benchmarkName pkgBenchmarks + in case lookup bmName benchmarkMap of + Just t -> return t + _ | bmName `elem` allNames -> + die $ "Package configured with benchmark " + ++ bmName ++ " disabled." + | otherwise -> die $ "no such benchmark: " ++ bmName + + let totalBenchmarks = length bmsToRun + notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." + exitcodes <- mapM doBench bmsToRun + let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes) + unless allOk exitFailure + where + startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n" + finishMessage name exitcode = "Benchmark " ++ name ++ ": " + ++ (case exitcode of + ExitSuccess -> "FINISH" + ExitFailure _ -> "ERROR") + + +-- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't +-- necessarily a path. +benchOption :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.Benchmark + -> PathTemplate + -> String +benchOption pkg_descr lbi bm template = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (LBI.pkgKey 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 new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Build.hs @@ -0,0 +1,605 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008, 2012 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point to actually building the modules in a package. It +-- doesn't actually do much itself, most of the work is delegated to +-- compiler-specific actions. It does do some non-compiler specific bits like +-- running pre-processors. +-- + +module Distribution.Simple.Build ( + build, repl, + startInterpreter, + + initialBuildSteps, + writeAutogenFiles, + ) where + +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 + +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 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.Register + ( registerPackage, inplaceInstalledPackageInfo ) +import Distribution.Simple.Test.LibV09 ( stubFilePath, stubName ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, rewriteFile + , die, info, debug, warn, setupMessage ) + +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Text + ( display ) + +import qualified Data.Map as Map +import Data.Maybe + ( maybeToList ) +import Data.Either + ( partitionEithers ) +import Data.List + ( intersect, intercalate ) +import Control.Monad + ( when, unless, forM_ ) +import System.FilePath + ( (), (<.>) ) +import System.Directory + ( getCurrentDirectory, removeDirectoryRecursive, removeFile + , doesDirectoryExist, doesFileExist ) + +-- ----------------------------------------------------------------------------- +-- |Build the libraries and executables in this package. + +build :: PackageDescription -- ^ Mostly information from the .cabal file + -> LocalBuildInfo -- ^ Configuration information + -> BuildFlags -- ^ Flags that the user passed to build + -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling + -> IO () +build pkg_descr lbi flags suffixes = do + let distPref = fromFlag (buildDistPref flags) + verbosity = fromFlag (buildVerbosity flags) + + targets <- readBuildTargets pkg_descr (buildArgs flags) + targets' <- checkBuildTargets verbosity pkg_descr targets + let componentsToBuild = map fst (componentsInBuildOrder lbi (map fst targets')) + info verbosity $ "Component build order: " + ++ intercalate ", " (map showComponentName componentsToBuild) + + initialBuildSteps distPref pkg_descr lbi verbosity + when (null targets) $ + -- Only bother with this message if we're building the whole package + setupMessage verbosity "Building" (packageId pkg_descr) + + internalPackageDB <- createInternalPackageDB verbosity lbi distPref + + withComponentsInBuildOrder pkg_descr lbi componentsToBuild $ \comp clbi -> + let bi = componentBuildInfo comp + progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) + lbi' = lbi { + withPrograms = progs', + withPackageDB = withPackageDB lbi ++ [internalPackageDB] + } + in buildComponent verbosity (buildNumJobs flags) pkg_descr + lbi' suffixes comp clbi distPref + + +repl :: PackageDescription -- ^ Mostly information from the .cabal file + -> LocalBuildInfo -- ^ Configuration information + -> ReplFlags -- ^ Flags that the user passed to build + -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling + -> [String] + -> IO () +repl pkg_descr lbi flags suffixes args = do + let distPref = fromFlag (replDistPref flags) + verbosity = fromFlag (replVerbosity flags) + + targets <- readBuildTargets pkg_descr args + targets' <- case targets of + [] -> return $ take 1 [ componentName c + | c <- pkgEnabledComponents pkg_descr ] + [target] -> fmap (map fst) (checkBuildTargets verbosity pkg_descr [target]) + _ -> die $ "The 'repl' command does not support multiple targets at once." + let componentsToBuild = componentsInBuildOrder lbi targets' + componentForRepl = last componentsToBuild + debug verbosity $ "Component build order: " + ++ intercalate ", " + [ showComponentName c | (c,_) <- componentsToBuild ] + + initialBuildSteps distPref pkg_descr lbi verbosity + + internalPackageDB <- createInternalPackageDB verbosity lbi distPref + + let lbiForComponent comp lbi' = + lbi' { + withPackageDB = withPackageDB lbi ++ [internalPackageDB], + withPrograms = addInternalBuildTools pkg_descr lbi' + (componentBuildInfo comp) (withPrograms lbi') + } + + -- build any dependent components + sequence_ + [ let comp = getComponent pkg_descr cname + lbi' = lbiForComponent comp lbi + in buildComponent verbosity NoFlag + pkg_descr lbi' suffixes comp clbi distPref + | (cname, clbi) <- init componentsToBuild ] + + -- REPL for target components + let (cname, clbi) = componentForRepl + comp = getComponent pkg_descr cname + lbi' = lbiForComponent comp lbi + in replComponent verbosity pkg_descr lbi' suffixes comp clbi distPref + + +-- | Start an interpreter without loading any package files. +startInterpreter :: Verbosity -> ProgramDb -> Compiler -> PackageDBStack -> IO () +startInterpreter verbosity programDb comp packageDBs = + case compilerFlavor comp of + GHC -> GHC.startInterpreter verbosity programDb comp packageDBs + GHCJS -> GHCJS.startInterpreter verbosity programDb comp packageDBs + _ -> die "A REPL is not supported with this compiler." + +buildComponent :: Verbosity + -> Flag (Maybe Int) + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> Component + -> ComponentLocalBuildInfo + -> FilePath + -> IO () +buildComponent verbosity numJobs pkg_descr lbi suffixes + comp@(CLib lib) clbi distPref = do + preprocessComponent pkg_descr comp lbi False verbosity suffixes + info verbosity "Building library..." + 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) + + +buildComponent verbosity numJobs pkg_descr lbi suffixes + comp@(CExe exe) clbi _ = do + preprocessComponent pkg_descr comp lbi False verbosity suffixes + info verbosity $ "Building executable " ++ exeName exe ++ "..." + buildExe verbosity numJobs pkg_descr lbi exe clbi + + +buildComponent verbosity numJobs pkg_descr lbi suffixes + comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) + clbi _distPref = do + let exe = testSuiteExeV10AsExe test + preprocessComponent pkg_descr comp lbi False verbosity suffixes + info verbosity $ "Building test suite " ++ testName test ++ "..." + buildExe verbosity numJobs pkg_descr lbi exe clbi + + +buildComponent verbosity numJobs pkg_descr lbi0 suffixes + comp@(CTest + test@TestSuite { testInterface = TestSuiteLibV09{} }) + clbi -- This ComponentLocalBuildInfo corresponds to a detailed + -- test suite and not a real component. It should not + -- be used, except to construct the CLBIs for the + -- library and stub executable that will actually be + -- built. + distPref = do + pwd <- getCurrentDirectory + let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = + testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd + preprocessComponent pkg_descr comp lbi False verbosity suffixes + 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 + + +buildComponent _ _ _ _ _ + (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) + _ _ = + die $ "No support for building test suite type " ++ display tt + + +buildComponent verbosity numJobs pkg_descr lbi suffixes + comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) + clbi _ = do + let (exe, exeClbi) = benchmarkExeV10asExe bm clbi + preprocessComponent pkg_descr comp lbi False verbosity suffixes + info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..." + buildExe verbosity numJobs pkg_descr lbi exe exeClbi + + +buildComponent _ _ _ _ _ + (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) + _ _ = + die $ "No support for building benchmark type " ++ display tt + + +replComponent :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> Component + -> ComponentLocalBuildInfo + -> FilePath + -> IO () +replComponent verbosity pkg_descr lbi suffixes + comp@(CLib lib) clbi _ = do + preprocessComponent pkg_descr comp lbi False verbosity suffixes + replLib verbosity pkg_descr lbi lib clbi + +replComponent verbosity pkg_descr lbi suffixes + comp@(CExe exe) clbi _ = do + preprocessComponent pkg_descr comp lbi False verbosity suffixes + replExe verbosity pkg_descr lbi exe clbi + + +replComponent verbosity pkg_descr lbi suffixes + comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) + clbi _distPref = do + let exe = testSuiteExeV10AsExe test + preprocessComponent pkg_descr comp lbi False verbosity suffixes + replExe verbosity pkg_descr lbi exe clbi + + +replComponent verbosity pkg_descr lbi0 suffixes + comp@(CTest + test@TestSuite { testInterface = TestSuiteLibV09{} }) + clbi distPref = do + pwd <- getCurrentDirectory + 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 + + +replComponent _ _ _ _ + (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) + _ _ = + die $ "No support for building test suite type " ++ display tt + + +replComponent verbosity pkg_descr lbi suffixes + comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) + clbi _ = do + let (exe, exeClbi) = benchmarkExeV10asExe bm clbi + preprocessComponent pkg_descr comp lbi False verbosity suffixes + replExe verbosity pkg_descr lbi exe exeClbi + + +replComponent _ _ _ _ + (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) + _ _ = + die $ "No support for building benchmark type " ++ display tt + +---------------------------------------------------- +-- Shared code for buildComponent and replComponent +-- + +-- | Translate a exe-style 'TestSuite' component into an exe for building +testSuiteExeV10AsExe :: TestSuite -> Executable +testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } = + Executable { + exeName = testName test, + modulePath = mainFile, + buildInfo = testBuildInfo test + } +testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind" + +-- | Translate a lib-style 'TestSuite' component into a lib + exe for building +testSuiteLibV09AsLibAndExe :: PackageDescription + -> TestSuite + -> ComponentLocalBuildInfo + -> LocalBuildInfo + -> FilePath + -> FilePath + -> (PackageDescription, + Library, ComponentLocalBuildInfo, + LocalBuildInfo, + IPI.InstalledPackageInfo_ ModuleName, + Executable, ComponentLocalBuildInfo) +testSuiteLibV09AsLibAndExe pkg_descr + test@TestSuite { testInterface = TestSuiteLibV09 _ m } + clbi lbi distPref pwd = + (pkg, lib, libClbi, lbi', ipi, exe, exeClbi) + where + bi = testBuildInfo test + lib = Library { + exposedModules = [ m ], + reexportedModules = [], + requiredSignatures = [], + exposedSignatures = [], + libExposed = True, + libBuildInfo = bi + } + libClbi = LibComponentLocalBuildInfo + { componentPackageDeps = componentPackageDeps clbi + , componentPackageRenaming = componentPackageRenaming clbi + , componentLibraries = [LibraryName (testName test)] + , componentExposedModules = [IPI.ExposedModule m Nothing Nothing] + } + pkg = pkg_descr { + package = (package pkg_descr) { + pkgName = PackageName (testName test) + } + , 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 + testDir = buildDir lbi stubName test + stubName test ++ "-tmp" + testLibDep = thisPackageVersion $ package pkg + exe = Executable { + exeName = stubName test, + modulePath = stubFilePath test, + buildInfo = (testBuildInfo test) { + hsSourceDirs = [ testDir ], + targetBuildDepends = testLibDep + : (targetBuildDepends $ testBuildInfo test), + targetBuildRenaming = + Map.insert (packageName pkg) defaultRenaming + (targetBuildRenaming $ testBuildInfo test) + } + } + -- | The stub executable needs a new 'ComponentLocalBuildInfo' + -- that exposes the relevant test suite library. + exeClbi = ExeComponentLocalBuildInfo { + componentPackageDeps = + (IPI.installedPackageId ipi, packageId ipi) + : (filter (\(_, x) -> let PackageName name = pkgName x + in name == "Cabal" || name == "base") + (componentPackageDeps clbi)), + componentPackageRenaming = + Map.insert (packageName ipi) defaultRenaming + (componentPackageRenaming clbi) + } +testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" + + +-- | Translate a exe-style 'Benchmark' component into an exe for building +benchmarkExeV10asExe :: Benchmark -> ComponentLocalBuildInfo + -> (Executable, ComponentLocalBuildInfo) +benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } + clbi = + (exe, exeClbi) + where + exe = Executable { + exeName = benchmarkName bm, + modulePath = f, + buildInfo = benchmarkBuildInfo bm + } + exeClbi = ExeComponentLocalBuildInfo { + componentPackageDeps = componentPackageDeps clbi, + componentPackageRenaming = componentPackageRenaming clbi + } +benchmarkExeV10asExe Benchmark{} _ = error "benchmarkExeV10asExe: wrong kind" + +-- | Initialize a new package db file for libraries defined +-- internally to the package. +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 + +addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo + -> ProgramDb -> ProgramDb +addInternalBuildTools pkg lbi bi progs = + foldr updateProgram progs internalBuildTools + where + internalBuildTools = + [ simpleConfiguredProgram toolName (FoundOnSystem toolLocation) + | toolName <- toolNames + , let toolLocation = buildDir lbi toolName toolName <.> exeExtension ] + toolNames = intersect buildToolNames internalExeNames + internalExeNames = map exeName (executables pkg) + buildToolNames = map buildToolName (buildTools bi) + where + buildToolName (Dependency (PackageName name) _ ) = name + + +-- TODO: build separate libs in separate dirs so that we can build +-- multiple libs, e.g. for 'LibTest' library-style test suites +buildLib :: Verbosity -> Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity numJobs pkg_descr lbi lib clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildLib verbosity numJobs pkg_descr lbi lib clbi + GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi + JHC -> JHC.buildLib verbosity pkg_descr lbi lib clbi + LHC -> LHC.buildLib verbosity pkg_descr lbi lib clbi + UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi + HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi + _ -> die "Building is not supported with this compiler." + +buildExe :: Verbosity -> Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity numJobs pkg_descr lbi exe clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi + GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi + JHC -> JHC.buildExe verbosity pkg_descr lbi exe clbi + LHC -> LHC.buildExe verbosity pkg_descr lbi exe clbi + UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi + _ -> die "Building is not supported with this compiler." + +replLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +replLib verbosity pkg_descr lbi lib clbi = + case compilerFlavor (compiler lbi) of + -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass + -- NoFlag as the numJobs parameter. + GHC -> GHC.replLib verbosity NoFlag pkg_descr lbi lib clbi + GHCJS -> GHCJS.replLib verbosity NoFlag pkg_descr lbi lib clbi + _ -> die "A REPL is not supported for this compiler." + +replExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +replExe verbosity pkg_descr lbi exe clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.replExe verbosity NoFlag pkg_descr lbi exe clbi + GHCJS -> GHCJS.replExe verbosity NoFlag pkg_descr lbi exe clbi + _ -> die "A REPL is not supported for this compiler." + + +initialBuildSteps :: FilePath -- ^"dist" prefix + -> PackageDescription -- ^mostly information from the .cabal file + -> LocalBuildInfo -- ^Configuration information + -> Verbosity -- ^The verbosity to use + -> IO () +initialBuildSteps _distPref pkg_descr lbi verbosity = do + -- check that there's something to build + let buildInfos = + map libBuildInfo (maybeToList (library pkg_descr)) ++ + map buildInfo (executables pkg_descr) + unless (any buildable buildInfos) $ do + let name = display (packageId pkg_descr) + die ("Package " ++ name ++ " can't be built on this system.") + + createDirectoryIfMissingVerbose verbosity True (buildDir lbi) + + writeAutogenFiles verbosity pkg_descr lbi + +-- | Generate and write out the Paths_.hs and cabal_macros.h files +-- +writeAutogenFiles :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> IO () +writeAutogenFiles verbosity pkg lbi = do + createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi) + + let pathsModulePath = autogenModulesDir lbi + ModuleName.toFilePath (autogenModuleName pkg) <.> "hs" + rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi) + + let cppHeaderPath = autogenModulesDir lbi cppHeaderName + rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi) + +-- | Check that the given build targets are valid in the current context. +-- +-- Also swizzle into a more convenient form. +-- +checkBuildTargets :: Verbosity -> PackageDescription -> [BuildTarget] + -> IO [(ComponentName, Maybe (Either ModuleName FilePath))] +checkBuildTargets _ pkg [] = + return [ (componentName c, Nothing) | c <- pkgEnabledComponents pkg ] + +checkBuildTargets verbosity pkg targets = do + + let (enabled, disabled) = + partitionEithers + [ case componentDisabledReason (getComponent pkg cname) of + Nothing -> Left target' + Just reason -> Right (cname, reason) + | target <- targets + , let target'@(cname,_) = swizzleTarget target ] + + case disabled of + [] -> return () + ((cname,reason):_) -> die $ formatReason (showComponentName cname) reason + + forM_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) -> + warn verbosity $ "Ignoring '" ++ either display id t ++ ". The whole " + ++ showComponentName c ++ " will be built. (Support for " + ++ "module and file targets has not been implemented yet.)" + + return enabled + + where + swizzleTarget (BuildTargetComponent c) = (c, Nothing) + swizzleTarget (BuildTargetModule c m) = (c, Just (Left m)) + swizzleTarget (BuildTargetFile c f) = (c, Just (Right f)) + + formatReason cn DisabledComponent = + "Cannot build the " ++ cn ++ " because the component is marked " + ++ "as disabled in the .cabal file." + formatReason cn DisabledAllTests = + "Cannot build the " ++ cn ++ " because test suites are not " + ++ "enabled. Run configure with the flag --enable-tests" + formatReason cn DisabledAllBenchmarks = + "Cannot build the " ++ cn ++ " because benchmarks are not " + ++ "enabled. Re-run configure with the flag --enable-benchmarks" diff --git a/Distribution/Simple/Build/Macros.hs b/Distribution/Simple/Build/Macros.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Build/Macros.hs @@ -0,0 +1,109 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build.Macros +-- Copyright : Simon Marlow 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Generate cabal_macros.h - CPP macros for package version testing +-- +-- When using CPP you get +-- +-- > VERSION_ +-- > MIN_VERSION_(A,B,C) +-- +-- for each /package/ in @build-depends@, which is true if the version of +-- /package/ in use is @>= A.B.C@, using the normal ordering on version +-- numbers. +-- +module Distribution.Simple.Build.Macros ( + generate, + generatePackageVersionMacros, + ) where + +import Data.Maybe + ( isJust ) +import Distribution.Package + ( PackageIdentifier(PackageIdentifier) ) +import Distribution.Version + ( Version(versionBranch) ) +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.Simple.Compiler + ( packageKeySupported ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(compiler, pkgKey, withPrograms), externalPackageDeps ) +import Distribution.Simple.Program.Db + ( configuredPrograms ) +import Distribution.Simple.Program.Types + ( ConfiguredProgram(programId, programVersion) ) +import Distribution.Text + ( display ) + +-- ------------------------------------------------------------ +-- * Generate cabal_macros.h +-- ------------------------------------------------------------ + +-- | The contents of the @cabal_macros.h@ for the given configured package. +-- +generate :: PackageDescription -> LocalBuildInfo -> String +generate _pkg_descr lbi = + "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" ++ + generatePackageVersionMacros (map snd (externalPackageDeps lbi)) ++ + generateToolVersionMacros (configuredPrograms . withPrograms $ lbi) ++ + generatePackageKeyMacro lbi + +-- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@ +-- macros for a list of package ids (usually used with the specific deps of +-- a configured package). +-- +generatePackageVersionMacros :: [PackageIdentifier] -> String +generatePackageVersionMacros pkgids = concat + [ "/* package " ++ display pkgid ++ " */\n" + ++ generateMacros "" pkgname version + | pkgid@(PackageIdentifier name version) <- pkgids + , let pkgname = map fixchar (display name) + ] + +-- | Helper function that generates just the @TOOL_VERSION_pkg@ and +-- @MIN_TOOL_VERSION_pkg@ macros for a list of configured programs. +-- +generateToolVersionMacros :: [ConfiguredProgram] -> String +generateToolVersionMacros progs = concat + [ "/* tool " ++ progid ++ " */\n" + ++ generateMacros "TOOL_" progname version + | prog <- progs + , isJust . programVersion $ prog + , let progid = programId prog ++ "-" ++ display version + progname = map fixchar (programId prog) + Just version = programVersion prog + ] + +-- | Common implementation of 'generatePackageVersionMacros' and +-- 'generateToolVersionMacros'. +-- +generateMacros :: String -> String -> Version -> String +generateMacros prefix name version = + concat + ["#define ", prefix, "VERSION_",name," ",show (display version),"\n" + ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + 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 = "" + +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c diff --git a/Distribution/Simple/Build/PathsModule.hs b/Distribution/Simple/Build/PathsModule.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Build/PathsModule.hs @@ -0,0 +1,303 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build.Macros +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Generating the Paths_pkgname module. +-- +-- This is a module that Cabal generates for the benefit of packages. It +-- enables them to find their version number and find any installed data files +-- at runtime. This code should probably be split off into another module. +-- +module Distribution.Simple.Build.PathsModule ( + generate, pkgPathEnvVar + ) where + +import Distribution.System + ( OS(Windows), buildOS, Arch(..), buildArch ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), compilerFlavor, compilerVersion ) +import Distribution.Package + ( packageId, packageName, packageVersion ) +import Distribution.PackageDescription + ( PackageDescription(..), hasLibs ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), InstallDirs(..) + , absoluteInstallDirs, prefixRelativeInstallDirs ) +import Distribution.Simple.Setup ( CopyDest(NoCopyDest) ) +import Distribution.Simple.BuildPaths + ( autogenModuleName ) +import Distribution.Simple.Utils + ( shortRelativePath ) +import Distribution.Text + ( display ) +import Distribution.Version + ( Version(..), orLaterVersion, withinRange ) + +import System.FilePath + ( pathSeparator ) +import Data.Maybe + ( fromJust, isNothing ) + +-- ------------------------------------------------------------ +-- * Building Paths_.hs +-- ------------------------------------------------------------ + +generate :: PackageDescription -> LocalBuildInfo -> String +generate pkg_descr lbi = + let pragmas + | absolute = "" + | supports_language_pragma = + "{-# LANGUAGE ForeignFunctionInterface #-}\n" + | otherwise = + "{-# OPTIONS_GHC -fffi #-}\n"++ + "{-# OPTIONS_JHC -fffi #-}\n" + + foreign_imports + | absolute = "" + | otherwise = + "import Foreign\n"++ + "import Foreign.C\n" + + reloc_imports + | reloc = + "import System.Environment (getExecutablePath)\n" + | otherwise = "" + + header = + pragmas++ + "module " ++ display paths_modulename ++ " (\n"++ + " version,\n"++ + " getBinDir, getLibDir, getDataDir, getLibexecDir,\n"++ + " getDataFileName, getSysconfDir\n"++ + " ) where\n"++ + "\n"++ + foreign_imports++ + "import qualified Control.Exception as Exception\n"++ + "import Data.Version (Version(..))\n"++ + "import System.Environment (getEnv)\n"++ + reloc_imports ++ + "import Prelude\n"++ + "\n"++ + "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++ + "catchIO = Exception.catch\n" ++ + "\n"++ + "version :: Version"++ + "\nversion = Version " ++ show branch ++ " " ++ show tags + where Version branch tags = packageVersion pkg_descr + + body + | reloc = + "\n\nbindirrel :: FilePath\n" ++ + "bindirrel = " ++ show flat_bindirreloc ++ + "\n"++ + "\ngetBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++ + "getBinDir = "++mkGetEnvOrReloc "bindir" flat_bindirreloc++"\n"++ + "getLibDir = "++mkGetEnvOrReloc "libdir" flat_libdirreloc++"\n"++ + "getDataDir = "++mkGetEnvOrReloc "datadir" flat_datadirreloc++"\n"++ + "getLibexecDir = "++mkGetEnvOrReloc "libexecdir" flat_libexecdirreloc++"\n"++ + "getSysconfDir = "++mkGetEnvOrReloc "sysconfdir" flat_sysconfdirreloc++"\n"++ + "\n"++ + "getDataFileName :: FilePath -> IO FilePath\n"++ + "getDataFileName name = do\n"++ + " dir <- getDataDir\n"++ + " return (dir `joinFileName` name)\n"++ + "\n"++ + get_prefix_reloc_stuff++ + "\n"++ + filename_stuff + | absolute = + "\nbindir, libdir, datadir, libexecdir, sysconfdir :: FilePath\n"++ + "\nbindir = " ++ show flat_bindir ++ + "\nlibdir = " ++ show flat_libdir ++ + "\ndatadir = " ++ show flat_datadir ++ + "\nlibexecdir = " ++ show flat_libexecdir ++ + "\nsysconfdir = " ++ show flat_sysconfdir ++ + "\n"++ + "\ngetBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++ + "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++ + "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++ + "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++ + "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++ + "getSysconfDir = "++mkGetEnvOr "sysconfdir" "return sysconfdir"++"\n"++ + "\n"++ + "getDataFileName :: FilePath -> IO FilePath\n"++ + "getDataFileName name = do\n"++ + " dir <- getDataDir\n"++ + " return (dir ++ "++path_sep++" ++ name)\n" + | otherwise = + "\nprefix, bindirrel :: FilePath" ++ + "\nprefix = " ++ show flat_prefix ++ + "\nbindirrel = " ++ show (fromJust flat_bindirrel) ++ + "\n\n"++ + "getBinDir :: IO FilePath\n"++ + "getBinDir = getPrefixDirRel bindirrel\n\n"++ + "getLibDir :: IO FilePath\n"++ + "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"++ + "getDataDir :: IO FilePath\n"++ + "getDataDir = "++ mkGetEnvOr "datadir" + (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++ + "getLibexecDir :: IO FilePath\n"++ + "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"++ + "getSysconfDir :: IO FilePath\n"++ + "getSysconfDir = "++mkGetDir flat_sysconfdir flat_sysconfdirrel++"\n\n"++ + "getDataFileName :: FilePath -> IO FilePath\n"++ + "getDataFileName name = do\n"++ + " dir <- getDataDir\n"++ + " return (dir `joinFileName` name)\n"++ + "\n"++ + get_prefix_stuff++ + "\n"++ + filename_stuff + in header++body + + where + InstallDirs { + prefix = flat_prefix, + bindir = flat_bindir, + libdir = flat_libdir, + datadir = flat_datadir, + libexecdir = flat_libexecdir, + sysconfdir = flat_sysconfdir + } = absoluteInstallDirs pkg_descr lbi NoCopyDest + InstallDirs { + bindir = flat_bindirrel, + libdir = flat_libdirrel, + datadir = flat_datadirrel, + libexecdir = flat_libexecdirrel, + sysconfdir = flat_sysconfdirrel + } = prefixRelativeInstallDirs (packageId pkg_descr) lbi + + flat_bindirreloc = shortRelativePath flat_prefix flat_bindir + flat_libdirreloc = shortRelativePath flat_prefix flat_libdir + flat_datadirreloc = shortRelativePath flat_prefix flat_datadir + flat_libexecdirreloc = shortRelativePath flat_prefix flat_libexecdir + flat_sysconfdirreloc = shortRelativePath flat_prefix flat_sysconfdir + + mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel + mkGetDir dir Nothing = "return " ++ show dir + + mkGetEnvOrReloc var dirrel = "catchIO (getEnv \""++var'++"\")" ++ + " (\\_ -> getPrefixDirReloc \"" ++ dirrel ++ + "\")" + where var' = pkgPathEnvVar pkg_descr var + + mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++ + " (\\_ -> "++expr++")" + where var' = pkgPathEnvVar pkg_descr var + + -- In several cases we cannot make relocatable installations + absolute = + hasLibs pkg_descr -- we can only make progs relocatable + || isNothing flat_bindirrel -- if the bin dir is an absolute path + || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) + + reloc = relocatable lbi + + supportsRelocatableProgs GHC = case buildOS of + Windows -> True + _ -> False + supportsRelocatableProgs GHCJS = case buildOS of + Windows -> True + _ -> False + supportsRelocatableProgs _ = False + + paths_modulename = autogenModuleName pkg_descr + + get_prefix_stuff = get_prefix_win32 buildArch + + path_sep = show [pathSeparator] + + supports_language_pragma = + (compilerFlavor (compiler lbi) == GHC && + (compilerVersion (compiler lbi) + `withinRange` orLaterVersion (Version [6,6,1] []))) || + compilerFlavor (compiler lbi) == GHCJS + +-- | Generates the name of the environment variable controlling the path +-- component of interest. +pkgPathEnvVar :: PackageDescription + -> String -- ^ path component; one of \"bindir\", \"libdir\", + -- \"datadir\", \"libexecdir\", or \"sysconfdir\" + -> String -- ^ environment variable name +pkgPathEnvVar pkg_descr var = + showPkgName (packageName pkg_descr) ++ "_" ++ var + where + showPkgName = map fixchar . display + fixchar '-' = '_' + fixchar c = c + +get_prefix_reloc_stuff :: String +get_prefix_reloc_stuff = + "getPrefixDirReloc :: FilePath -> IO FilePath\n"++ + "getPrefixDirReloc dirRel = do\n"++ + " exePath <- getExecutablePath\n"++ + " let (bindir,_) = splitFileName exePath\n"++ + " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n" + +get_prefix_win32 :: Arch -> String +get_prefix_win32 arch = + "getPrefixDirRel :: FilePath -> IO FilePath\n"++ + "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n"++ + " where\n"++ + " try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n"++ + " ret <- c_GetModuleFileName nullPtr buf size\n"++ + " case ret of\n"++ + " 0 -> return (prefix `joinFileName` dirRel)\n"++ + " _ | ret < size -> do\n"++ + " exePath <- peekCWString buf\n"++ + " let (bindir,_) = splitFileName exePath\n"++ + " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ + " | otherwise -> try_size (size * 2)\n"++ + "\n"++ + "foreign import " ++ cconv ++ " unsafe \"windows.h GetModuleFileNameW\"\n"++ + " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + where cconv = case arch of + I386 -> "stdcall" + X86_64 -> "ccall" + _ -> error "win32 supported only with I386, X86_64" + +filename_stuff :: String +filename_stuff = + "minusFileName :: FilePath -> String -> FilePath\n"++ + "minusFileName dir \"\" = dir\n"++ + "minusFileName dir \".\" = dir\n"++ + "minusFileName dir suffix =\n"++ + " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"++ + "\n"++ + "joinFileName :: String -> String -> FilePath\n"++ + "joinFileName \"\" fname = fname\n"++ + "joinFileName \".\" fname = fname\n"++ + "joinFileName dir \"\" = dir\n"++ + "joinFileName dir fname\n"++ + " | isPathSeparator (last dir) = dir++fname\n"++ + " | otherwise = dir++pathSeparator:fname\n"++ + "\n"++ + "splitFileName :: FilePath -> (String, String)\n"++ + "splitFileName p = (reverse (path2++drive), reverse fname)\n"++ + " where\n"++ + " (path,drive) = case p of\n"++ + " (c:':':p') -> (reverse p',[':',c])\n"++ + " _ -> (reverse p ,\"\")\n"++ + " (fname,path1) = break isPathSeparator path\n"++ + " path2 = case path1 of\n"++ + " [] -> \".\"\n"++ + " [_] -> path1 -- don't remove the trailing slash if \n"++ + " -- there is only one character\n"++ + " (c:path') | isPathSeparator c -> path'\n"++ + " _ -> path1\n"++ + "\n"++ + "pathSeparator :: Char\n"++ + (case buildOS of + Windows -> "pathSeparator = '\\\\'\n" + _ -> "pathSeparator = '/'\n") ++ + "\n"++ + "isPathSeparator :: Char -> Bool\n"++ + (case buildOS of + Windows -> "isPathSeparator c = c == '/' || c == '\\\\'\n" + _ -> "isPathSeparator c = c == '/'\n") diff --git a/Distribution/Simple/BuildPaths.hs b/Distribution/Simple/BuildPaths.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/BuildPaths.hs @@ -0,0 +1,121 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.BuildPaths +-- Copyright : Isaac Jones 2003-2004, +-- Duncan Coutts 2008 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A bunch of dirs, paths and file names used for intermediate build steps. +-- + +module Distribution.Simple.BuildPaths ( + defaultDistPref, srcPref, + hscolourPref, haddockPref, + autogenModulesDir, + + autogenModuleName, + cppHeaderName, + haddockName, + + mkLibName, + mkProfLibName, + mkSharedLibName, + + exeExtension, + objExtension, + dllExtension, + + ) where + + +import System.FilePath ((), (<.>)) + +import Distribution.Package + ( packageName ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Compiler + ( CompilerId(..) ) +import Distribution.PackageDescription (PackageDescription) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(buildDir), LibraryName(..) ) +import Distribution.Simple.Setup (defaultDistPref) +import Distribution.Text + ( display ) +import Distribution.System (OS(..), buildOS) + +-- --------------------------------------------------------------------------- +-- Build directories and files + +srcPref :: FilePath -> FilePath +srcPref distPref = distPref "src" + +hscolourPref :: FilePath -> PackageDescription -> FilePath +hscolourPref = haddockPref + +haddockPref :: FilePath -> PackageDescription -> FilePath +haddockPref distPref pkg_descr + = distPref "doc" "html" display (packageName pkg_descr) + +-- |The directory in which we put auto-generated modules +autogenModulesDir :: LocalBuildInfo -> String +autogenModulesDir lbi = buildDir lbi "autogen" + +cppHeaderName :: String +cppHeaderName = "cabal_macros.h" + +-- |The name of the auto-generated module associated with a package +autogenModuleName :: PackageDescription -> ModuleName +autogenModuleName pkg_descr = + ModuleName.fromString $ + "Paths_" ++ map fixchar (display (packageName pkg_descr)) + where fixchar '-' = '_' + fixchar c = c + +haddockName :: PackageDescription -> FilePath +haddockName pkg_descr = display (packageName pkg_descr) <.> "haddock" + +-- --------------------------------------------------------------------------- +-- Library file names + +mkLibName :: LibraryName -> String +mkLibName (LibraryName lib) = "lib" ++ lib <.> "a" + +mkProfLibName :: LibraryName -> String +mkProfLibName (LibraryName lib) = "lib" ++ lib ++ "_p" <.> "a" + +-- Implement proper name mangling for dynamical shared objects +-- libHS- +-- e.g. libHSbase-2.1-ghc6.6.1.so +mkSharedLibName :: CompilerId -> LibraryName -> String +mkSharedLibName (CompilerId compilerFlavor compilerVersion) (LibraryName lib) + = "lib" ++ lib ++ "-" ++ comp <.> dllExtension + where comp = display compilerFlavor ++ display compilerVersion + +-- ------------------------------------------------------------ +-- * Platform file extensions +-- ------------------------------------------------------------ + +-- ToDo: This should be determined via autoconf (AC_EXEEXT) +-- | Extension for executable files +-- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) +exeExtension :: String +exeExtension = case buildOS of + Windows -> "exe" + _ -> "" + +-- TODO: This should be determined via autoconf (AC_OBJEXT) +-- | Extension for object files. For GHC the extension is @\"o\"@. +objExtension :: String +objExtension = "o" + +-- | Extension for dynamically linked (or shared) libraries +-- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows) +dllExtension :: String +dllExtension = case buildOS of + Windows -> "dll" + OSX -> "dylib" + _ -> "so" diff --git a/Distribution/Simple/BuildTarget.hs b/Distribution/Simple/BuildTarget.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/BuildTarget.hs @@ -0,0 +1,939 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.BuildTargets +-- Copyright : (c) Duncan Coutts 2012 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Handling for user-specified build targets +----------------------------------------------------------------------------- +module Distribution.Simple.BuildTarget ( + + -- * Build targets + BuildTarget(..), + readBuildTargets, + + -- * Parsing user build targets + UserBuildTarget, + readUserBuildTargets, + UserBuildTargetProblem(..), + reportUserBuildTargetProblems, + + -- * Resolving build targets + resolveBuildTargets, + BuildTargetProblem(..), + reportBuildTargetProblems, + ) where + +import Distribution.Package + ( Package(..), PackageId, packageName ) + +import Distribution.PackageDescription + ( PackageDescription + , Executable(..) + , TestSuite(..), TestSuiteInterface(..), testModules + , Benchmark(..), BenchmarkInterface(..), benchmarkModules + , BuildInfo(..), libModules, exeModules ) +import Distribution.ModuleName + ( ModuleName, toFilePath ) +import Distribution.Simple.LocalBuildInfo + ( Component(..), ComponentName(..) + , pkgComponents, componentName, componentBuildInfo ) + +import Distribution.Text + ( display ) +import Distribution.Simple.Utils + ( die, lowercase, equating ) + +import Data.List + ( nub, stripPrefix, sortBy, groupBy, partition, intercalate ) +import Data.Ord +import Data.Maybe + ( listToMaybe, catMaybes ) +import Data.Either + ( partitionEithers ) +import qualified Data.Map as Map +import Control.Monad +#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 Data.Char + ( isSpace, isAlphaNum ) +import System.FilePath as FilePath + ( dropExtension, normalise, splitDirectories, joinPath, splitPath + , hasTrailingPathSeparator ) +import System.Directory + ( doesFileExist, doesDirectoryExist ) + +-- ------------------------------------------------------------ +-- * User build targets +-- ------------------------------------------------------------ + +-- | Various ways that a user may specify a build target. +-- +data UserBuildTarget = + + -- | A target specified by a single name. This could be a component + -- module or file. + -- + -- > cabal build foo + -- > cabal build Data.Foo + -- > cabal build Data/Foo.hs Data/Foo.hsc + -- + UserBuildTargetSingle String + + -- | A target specified by a qualifier and name. This could be a component + -- name qualified by the component namespace kind, or a module or file + -- qualified by the component name. + -- + -- > cabal build lib:foo exe:foo + -- > cabal build foo:Data.Foo + -- > cabal build foo:Data/Foo.hs + -- + | UserBuildTargetDouble String String + + -- A fully qualified target, either a module or file qualified by a + -- component name with the component namespace kind. + -- + -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs + -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo + -- + | UserBuildTargetTriple String String String + deriving (Show, Eq, Ord) + + +-- ------------------------------------------------------------ +-- * Resolved build targets +-- ------------------------------------------------------------ + +-- | A fully resolved build target. +-- +data BuildTarget = + + -- | A specific component + -- + BuildTargetComponent ComponentName + + -- | A specific module within a specific component. + -- + | BuildTargetModule ComponentName ModuleName + + -- | A specific file within a specific component. + -- + | BuildTargetFile ComponentName FilePath + deriving (Show,Eq) + + +-- ------------------------------------------------------------ +-- * Do everything +-- ------------------------------------------------------------ + +readBuildTargets :: PackageDescription -> [String] -> IO [BuildTarget] +readBuildTargets pkg targetStrs = do + let (uproblems, utargets) = readUserBuildTargets targetStrs + reportUserBuildTargetProblems uproblems + + utargets' <- mapM checkTargetExistsAsFile utargets + + let (bproblems, btargets) = resolveBuildTargets pkg utargets' + reportBuildTargetProblems bproblems + + return btargets + +checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool) +checkTargetExistsAsFile t = do + fexists <- existsAsFile (fileComponentOfTarget t) + return (t, fexists) + + where + existsAsFile f = do + exists <- doesFileExist f + case splitPath f of + (d:_) | hasTrailingPathSeparator d -> doesDirectoryExist d + (d:_:_) | not exists -> doesDirectoryExist d + _ -> return exists + + fileComponentOfTarget (UserBuildTargetSingle s1) = s1 + fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2 + fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3 + + +-- ------------------------------------------------------------ +-- * Parsing user targets +-- ------------------------------------------------------------ + +readUserBuildTargets :: [String] -> ([UserBuildTargetProblem] + ,[UserBuildTarget]) +readUserBuildTargets = partitionEithers . map readUserBuildTarget + +readUserBuildTarget :: String -> Either UserBuildTargetProblem + UserBuildTarget +readUserBuildTarget targetstr = + case readPToMaybe parseTargetApprox targetstr of + Nothing -> Left (UserBuildTargetUnrecognised targetstr) + Just tgt -> Right tgt + + where + parseTargetApprox :: Parse.ReadP r UserBuildTarget + parseTargetApprox = + (do a <- tokenQ + return (UserBuildTargetSingle a)) + +++ (do a <- token + _ <- Parse.char ':' + b <- tokenQ + return (UserBuildTargetDouble a b)) + +++ (do a <- token + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + return (UserBuildTargetTriple a b c)) + + token = Parse.munch1 (\x -> not (isSpace x) && x /= ':') + tokenQ = parseHaskellString <++ token + parseHaskellString :: Parse.ReadP r String + parseHaskellString = Parse.readS_to_P reads + + readPToMaybe :: Parse.ReadP a a -> String -> Maybe a + readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str + , all isSpace s ] + +data UserBuildTargetProblem + = UserBuildTargetUnrecognised String + deriving Show + +reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO () +reportUserBuildTargetProblems problems = do + case [ target | UserBuildTargetUnrecognised target <- problems ] of + [] -> return () + target -> + die $ unlines + [ "Unrecognised build target '" ++ name ++ "'." + | name <- target ] + ++ "Examples:\n" + ++ " - build foo -- component name " + ++ "(library, executable, test-suite or benchmark)\n" + ++ " - build Data.Foo -- module name\n" + ++ " - build Data/Foo.hsc -- file name\n" + ++ " - build lib:foo exe:foo -- component qualified by kind\n" + ++ " - build foo:Data.Foo -- module qualified by component\n" + ++ " - build foo:Data/Foo.hsc -- file qualified by component" + +showUserBuildTarget :: UserBuildTarget -> String +showUserBuildTarget = intercalate ":" . components + where + components (UserBuildTargetSingle s1) = [s1] + components (UserBuildTargetDouble s1 s2) = [s1,s2] + components (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3] + + +-- ------------------------------------------------------------ +-- * Resolving user targets to build targets +-- ------------------------------------------------------------ + +{- +stargets = + [ BuildTargetComponent (CExeName "foo") + , BuildTargetModule (CExeName "foo") (mkMn "Foo") + , BuildTargetModule (CExeName "tst") (mkMn "Foo") + ] + where + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + +ex_pkgid :: PackageIdentifier +Just ex_pkgid = simpleParse "thelib" +-} + +-- | Given a bunch of user-specified targets, try to resolve what it is they +-- refer to. +-- +resolveBuildTargets :: PackageDescription + -> [(UserBuildTarget, Bool)] + -> ([BuildTargetProblem], [BuildTarget]) +resolveBuildTargets pkg = partitionEithers + . map (uncurry (resolveBuildTarget pkg)) + +resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool + -> Either BuildTargetProblem BuildTarget +resolveBuildTarget pkg userTarget fexists = + case findMatch (matchBuildTarget pkg userTarget fexists) of + Unambiguous target -> Right target + Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets') + where targets' = disambiguateBuildTargets + (packageId pkg) userTarget + targets + None errs -> Left (classifyMatchErrors errs) + + where + classifyMatchErrors errs + | not (null expected) = let (things, got:_) = unzip expected in + BuildTargetExpected userTarget things got + | not (null nosuch) = BuildTargetNoSuch userTarget nosuch + | otherwise = error $ "resolveBuildTarget: internal error in matching" + where + expected = [ (thing, got) | MatchErrorExpected thing got <- errs ] + nosuch = [ (thing, got) | MatchErrorNoSuch thing got <- errs ] + + +data BuildTargetProblem + = BuildTargetExpected UserBuildTarget [String] String + -- ^ [expected thing] (actually got) + | BuildTargetNoSuch UserBuildTarget [(String, String)] + -- ^ [(no such thing, actually got)] + | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)] + deriving Show + + +disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget] + -> [(UserBuildTarget, BuildTarget)] +disambiguateBuildTargets pkgid original = + disambiguate (userTargetQualLevel original) + where + disambiguate ql ts + | null amb = unamb + | otherwise = unamb ++ disambiguate (succ ql) amb + where + (amb, unamb) = step ql ts + + userTargetQualLevel (UserBuildTargetSingle _ ) = QL1 + userTargetQualLevel (UserBuildTargetDouble _ _ ) = QL2 + userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3 + + step :: QualLevel -> [BuildTarget] + -> ([BuildTarget], [(UserBuildTarget, BuildTarget)]) + step ql = (\(amb, unamb) -> (map snd $ concat amb, concat unamb)) + . partition (\g -> length g > 1) + . groupBy (equating fst) + . sortBy (comparing fst) + . map (\t -> (renderBuildTarget ql t pkgid, t)) + +data QualLevel = QL1 | QL2 | QL3 + deriving (Enum, Show) + +renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget +renderBuildTarget ql target pkgid = + case ql of + QL1 -> UserBuildTargetSingle s1 where s1 = single target + QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target + QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target + + where + single (BuildTargetComponent cn ) = dispCName cn + single (BuildTargetModule _ m) = display m + single (BuildTargetFile _ f) = f + + double (BuildTargetComponent cn ) = (dispKind cn, dispCName cn) + double (BuildTargetModule cn m) = (dispCName cn, display m) + double (BuildTargetFile cn f) = (dispCName cn, f) + + triple (BuildTargetComponent _ ) = error "triple BuildTargetComponent" + triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, display m) + triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f) + + dispCName = componentStringName pkgid + dispKind = showComponentKindShort . componentKind + +reportBuildTargetProblems :: [BuildTargetProblem] -> IO () +reportBuildTargetProblems problems = do + + case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of + [] -> return () + targets -> + die $ unlines + [ "Unrecognised build target '" ++ showUserBuildTarget target + ++ "'.\n" + ++ "Expected a " ++ intercalate " or " expected + ++ ", rather than '" ++ got ++ "'." + | (target, expected, got) <- targets ] + + case [ (t, e) | BuildTargetNoSuch t e <- problems ] of + [] -> return () + targets -> + die $ unlines + [ "Unknown build target '" ++ showUserBuildTarget target + ++ "'.\nThere is no " + ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" + | (thing, got) <- nosuch ] ++ "." + | (target, nosuch) <- targets ] + where + mungeThing "file" = "file target" + mungeThing thing = thing + + case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of + [] -> return () + targets -> + die $ unlines + [ "Ambiguous build target '" ++ showUserBuildTarget target + ++ "'. It could be:\n " + ++ unlines [ " "++ showUserBuildTarget ut ++ + " (" ++ showBuildTargetKind bt ++ ")" + | (ut, bt) <- amb ] + | (target, amb) <- targets ] + + where + showBuildTargetKind (BuildTargetComponent _ ) = "component" + showBuildTargetKind (BuildTargetModule _ _) = "module" + showBuildTargetKind (BuildTargetFile _ _) = "file" + + +---------------------------------- +-- Top level BuildTarget matcher +-- + +matchBuildTarget :: PackageDescription + -> UserBuildTarget -> Bool -> Match BuildTarget +matchBuildTarget pkg = \utarget fexists -> + case utarget of + UserBuildTargetSingle str1 -> + matchBuildTarget1 cinfo str1 fexists + + UserBuildTargetDouble str1 str2 -> + matchBuildTarget2 cinfo str1 str2 fexists + + UserBuildTargetTriple str1 str2 str3 -> + matchBuildTarget3 cinfo str1 str2 str3 fexists + where + cinfo = pkgComponentInfo pkg + +matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget +matchBuildTarget1 cinfo str1 fexists = + matchComponent1 cinfo str1 + `matchPlusShadowing` matchModule1 cinfo str1 + `matchPlusShadowing` matchFile1 cinfo str1 fexists + + +matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool + -> Match BuildTarget +matchBuildTarget2 cinfo str1 str2 fexists = + matchComponent2 cinfo str1 str2 + `matchPlusShadowing` matchModule2 cinfo str1 str2 + `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists + + +matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool + -> Match BuildTarget +matchBuildTarget3 cinfo str1 str2 str3 fexists = + matchModule3 cinfo str1 str2 str3 + `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists + + +data ComponentInfo = ComponentInfo { + cinfoName :: ComponentName, + cinfoStrName :: ComponentStringName, + cinfoSrcDirs :: [FilePath], + cinfoModules :: [ModuleName], + cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) + cinfoCFiles :: [FilePath], + cinfoJsFiles :: [FilePath] + } + +type ComponentStringName = String + +pkgComponentInfo :: PackageDescription -> [ComponentInfo] +pkgComponentInfo pkg = + [ ComponentInfo { + cinfoName = componentName c, + cinfoStrName = componentStringName pkg (componentName c), + cinfoSrcDirs = hsSourceDirs bi, + cinfoModules = componentModules c, + cinfoHsFiles = componentHsFiles c, + cinfoCFiles = cSources bi, + cinfoJsFiles = jsSources bi + } + | c <- pkgComponents pkg + , let bi = componentBuildInfo c ] + +componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName +componentStringName pkg CLibName = display (packageName pkg) +componentStringName _ (CExeName name) = name +componentStringName _ (CTestName name) = name +componentStringName _ (CBenchName name) = name + +componentModules :: Component -> [ModuleName] +componentModules (CLib lib) = libModules lib +componentModules (CExe exe) = exeModules exe +componentModules (CTest test) = testModules test +componentModules (CBench bench) = benchmarkModules bench + +componentHsFiles :: Component -> [FilePath] +componentHsFiles (CExe exe) = [modulePath exe] +componentHsFiles (CTest TestSuite { + testInterface = TestSuiteExeV10 _ mainfile + }) = [mainfile] +componentHsFiles (CBench Benchmark { + benchmarkInterface = BenchmarkExeV10 _ mainfile + }) = [mainfile] +componentHsFiles _ = [] + +{- +ex_cs :: [ComponentInfo] +ex_cs = + [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) + , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) + ] + where + mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms) + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + pkgid :: PackageIdentifier + Just pkgid = simpleParse "thelib" +-} + +------------------------------ +-- Matching component kinds +-- + +data ComponentKind = LibKind | ExeKind | TestKind | BenchKind + deriving (Eq, Ord, Show) + +componentKind :: ComponentName -> ComponentKind +componentKind CLibName = LibKind +componentKind (CExeName _) = ExeKind +componentKind (CTestName _) = TestKind +componentKind (CBenchName _) = BenchKind + +cinfoKind :: ComponentInfo -> ComponentKind +cinfoKind = componentKind . cinfoName + +matchComponentKind :: String -> Match ComponentKind +matchComponentKind s + | s `elem` ["lib", "library"] = increaseConfidence >> return LibKind + | s `elem` ["exe", "executable"] = increaseConfidence >> return ExeKind + | s `elem` ["tst", "test", "test-suite"] = increaseConfidence + >> return TestKind + | s `elem` ["bench", "benchmark"] = increaseConfidence + >> return BenchKind + | otherwise = matchErrorExpected + "component kind" s + +showComponentKind :: ComponentKind -> String +showComponentKind LibKind = "library" +showComponentKind ExeKind = "executable" +showComponentKind TestKind = "test-suite" +showComponentKind BenchKind = "benchmark" + +showComponentKindShort :: ComponentKind -> String +showComponentKindShort LibKind = "lib" +showComponentKindShort ExeKind = "exe" +showComponentKindShort TestKind = "test" +showComponentKindShort BenchKind = "bench" + +------------------------------ +-- Matching component targets +-- + +matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget +matchComponent1 cs = \str1 -> do + guardComponentName str1 + c <- matchComponentName cs str1 + return (BuildTargetComponent (cinfoName c)) + +matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget +matchComponent2 cs = \str1 str2 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + return (BuildTargetComponent (cinfoName c)) + +-- utils: + +guardComponentName :: String -> Match () +guardComponentName s + | all validComponentChar s + && not (null s) = increaseConfidence + | otherwise = matchErrorExpected "component name" s + where + validComponentChar c = isAlphaNum c || c == '.' + || c == '_' || c == '-' || c == '\'' + +matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo +matchComponentName cs str = + orNoSuchThing "component" str + $ increaseConfidenceFor + $ matchInexactly caseFold + [ (cinfoStrName c, c) | c <- cs ] + str + +matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String + -> Match ComponentInfo +matchComponentKindAndName cs ckind str = + orNoSuchThing (showComponentKind ckind ++ " component") str + $ increaseConfidenceFor + $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) + [ ((cinfoKind c, cinfoStrName c), c) | c <- cs ] + (ckind, str) + + +------------------------------ +-- Matching module targets +-- + +matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget +matchModule1 cs = \str1 -> do + guardModuleName str1 + nubMatchErrors $ do + c <- tryEach cs + let ms = cinfoModules c + m <- matchModuleName ms str1 + return (BuildTargetModule (cinfoName c) m) + +matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget +matchModule2 cs = \str1 str2 -> do + guardComponentName str1 + guardModuleName str2 + c <- matchComponentName cs str1 + let ms = cinfoModules c + m <- matchModuleName ms str2 + return (BuildTargetModule (cinfoName c) m) + +matchModule3 :: [ComponentInfo] -> String -> String -> String + -> Match BuildTarget +matchModule3 cs str1 str2 str3 = do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + guardModuleName str3 + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (BuildTargetModule (cinfoName c) m) + +-- utils: + +guardModuleName :: String -> Match () +guardModuleName s + | all validModuleChar s + && not (null s) = increaseConfidence + | otherwise = matchErrorExpected "module name" s + where + validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' + +matchModuleName :: [ModuleName] -> String -> Match ModuleName +matchModuleName ms str = + orNoSuchThing "module" str + $ increaseConfidenceFor + $ matchInexactly caseFold + [ (display m, m) + | m <- ms ] + str + + +------------------------------ +-- Matching file targets +-- + +matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget +matchFile1 cs str1 exists = + nubMatchErrors $ do + c <- tryEach cs + filepath <- matchComponentFile c str1 exists + return (BuildTargetFile (cinfoName c) filepath) + + +matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget +matchFile2 cs str1 str2 exists = do + guardComponentName str1 + c <- matchComponentName cs str1 + filepath <- matchComponentFile c str2 exists + return (BuildTargetFile (cinfoName c) filepath) + + +matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool + -> Match BuildTarget +matchFile3 cs str1 str2 str3 exists = do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + filepath <- matchComponentFile c str3 exists + return (BuildTargetFile (cinfoName c) filepath) + + +matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath +matchComponentFile c str fexists = + expecting "file" str $ + matchPlus + (matchFileExists str fexists) + (matchPlusShadowing + (msum [ matchModuleFileRooted dirs ms str + , matchOtherFileRooted dirs hsFiles str ]) + (msum [ matchModuleFileUnrooted ms str + , matchOtherFileUnrooted hsFiles str + , matchOtherFileUnrooted cFiles str + , matchOtherFileUnrooted jsFiles str ])) + where + dirs = cinfoSrcDirs c + ms = cinfoModules c + hsFiles = cinfoHsFiles c + cFiles = cinfoCFiles c + jsFiles = cinfoJsFiles c + + +-- utils + +matchFileExists :: FilePath -> Bool -> Match a +matchFileExists _ False = mzero +matchFileExists fname True = do increaseConfidence + matchErrorNoSuch "file" fname + +matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath +matchModuleFileUnrooted ms str = do + let filepath = normalise str + _ <- matchModuleFileStem ms filepath + return filepath + +matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath +matchModuleFileRooted dirs ms str = nubMatches $ do + let filepath = normalise str + filepath' <- matchDirectoryPrefix dirs filepath + _ <- matchModuleFileStem ms filepath' + return filepath + +matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName +matchModuleFileStem ms = + increaseConfidenceFor + . matchInexactly caseFold + [ (toFilePath m, m) | m <- ms ] + . dropExtension + +matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath +matchOtherFileRooted dirs fs str = do + let filepath = normalise str + filepath' <- matchDirectoryPrefix dirs filepath + _ <- matchFile fs filepath' + return filepath + +matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath +matchOtherFileUnrooted fs str = do + let filepath = normalise str + _ <- matchFile fs filepath + return filepath + +matchFile :: [FilePath] -> FilePath -> Match FilePath +matchFile fs = increaseConfidenceFor + . matchInexactly caseFold [ (f, f) | f <- fs ] + +matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath +matchDirectoryPrefix dirs filepath = + exactMatches $ + catMaybes + [ stripDirectory (normalise dir) filepath | dir <- dirs ] + where + stripDirectory :: FilePath -> FilePath -> Maybe FilePath + stripDirectory dir fp = + joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp) + + +------------------------------ +-- Matching monad +-- + +-- | A matcher embodies a way to match some input as being some recognised +-- value. In particular it deals with multiple and ambiguous matches. +-- +-- There are various matcher primitives ('matchExactly', 'matchInexactly'), +-- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can +-- run a matcher against an input using 'findMatch'. +-- + +data Match a = NoMatch Confidence [MatchError] + | ExactMatch Confidence [a] + | InexactMatch Confidence [a] + deriving Show + +type Confidence = Int + +data MatchError = MatchErrorExpected String String + | MatchErrorNoSuch String String + deriving (Show, Eq) + + +instance Alternative Match where + empty = mzero + (<|>) = mplus + +instance MonadPlus Match where + mzero = matchZero + mplus = matchPlus + +matchZero :: Match a +matchZero = NoMatch 0 [] + +-- | Combine two matchers. Exact matches are used over inexact matches +-- but if we have multiple exact, or inexact then the we collect all the +-- ambiguous matches. +-- +matchPlus :: Match a -> Match a -> Match a +matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = + ExactMatch (max d1 d2) (xs ++ xs') +matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a +matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a +matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b +matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = + InexactMatch (max d1 d2) (xs ++ xs') +matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a +matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b +matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b +matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') + | d1 > d2 = a + | d1 < d2 = b + | otherwise = NoMatch d1 (ms ++ ms') + +-- | Combine two matchers. This is similar to '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. +-- +matchPlusShadowing :: Match a -> Match a -> Match a +matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a +matchPlusShadowing a b = matchPlus a b + +instance Functor Match where + fmap _ (NoMatch d ms) = NoMatch d ms + fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) + fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) + +instance Applicative Match where + pure = return + (<*>) = ap + +instance Monad Match where + return a = ExactMatch 0 [a] + NoMatch d ms >>= _ = NoMatch d ms + ExactMatch d xs >>= f = addDepth d + $ foldr matchPlus matchZero (map f xs) + InexactMatch d xs >>= f = addDepth d . forceInexact + $ foldr matchPlus matchZero (map f xs) + +addDepth :: Confidence -> Match a -> Match a +addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs +addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs +addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs + +forceInexact :: Match a -> Match a +forceInexact (ExactMatch d ys) = InexactMatch d ys +forceInexact m = m + +------------------------------ +-- Various match primitives +-- + +matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a +matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] +matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got] + +expecting :: String -> String -> Match a -> Match a +expecting thing got (NoMatch 0 _) = matchErrorExpected thing got +expecting _ _ m = m + +orNoSuchThing :: String -> String -> Match a -> Match a +orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got +orNoSuchThing _ _ m = m + +increaseConfidence :: Match () +increaseConfidence = ExactMatch 1 [()] + +increaseConfidenceFor :: Match a -> Match a +increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r + +nubMatches :: Eq a => Match a -> Match a +nubMatches (NoMatch d msgs) = NoMatch d msgs +nubMatches (ExactMatch d xs) = ExactMatch d (nub xs) +nubMatches (InexactMatch d xs) = InexactMatch d (nub xs) + +nubMatchErrors :: Match a -> Match a +nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs) +nubMatchErrors (ExactMatch d xs) = ExactMatch d xs +nubMatchErrors (InexactMatch d xs) = InexactMatch d xs + +-- | Lift a list of matches to an exact match. +-- +exactMatches, inexactMatches :: [a] -> Match a + +exactMatches [] = matchZero +exactMatches xs = ExactMatch 0 xs + +inexactMatches [] = matchZero +inexactMatches xs = InexactMatch 0 xs + +tryEach :: [a] -> Match a +tryEach = exactMatches + + +------------------------------ +-- Top level match runner +-- + +-- | Given a matcher and a key to look up, use the matcher to find all the +-- possible matches. There may be 'None', a single 'Unambiguous' match or +-- you may have an 'Ambiguous' match with several possibilities. +-- +findMatch :: Eq b => Match b -> MaybeAmbiguous b +findMatch match = + case match of + NoMatch _ msgs -> None (nub msgs) + ExactMatch _ xs -> checkAmbiguous xs + InexactMatch _ xs -> checkAmbiguous xs + where + checkAmbiguous xs = case nub xs of + [x] -> Unambiguous x + xs' -> Ambiguous xs' + +data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a] + deriving Show + + +------------------------------ +-- Basic matchers +-- + +{- +-- | A primitive matcher that looks up a value in a finite 'Map'. The +-- value must match exactly. +-- +matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b) +matchExactly xs = + \x -> case Map.lookup x m of + Nothing -> matchZero + Just ys -> ExactMatch 0 ys + where + m :: Ord a => Map a [b] + m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] +-} + +-- | A primitive matcher that looks up a value in a finite 'Map'. It checks +-- for an exact or inexact match. We get an inexact match if the match +-- is not exact, but the canonical forms match. It takes a canonicalisation +-- function for this purpose. +-- +-- So for example if we used string case fold as the canonicalisation +-- function, then we would get case insensitive matching (but it will still +-- report an exact match when the case matches too). +-- +matchInexactly :: (Ord a, Ord a') => + (a -> a') -> + [(a, b)] -> (a -> Match b) +matchInexactly cannonicalise xs = + \x -> case Map.lookup x m of + Just ys -> exactMatches ys + Nothing -> case Map.lookup (cannonicalise x) m' of + Just ys -> inexactMatches ys + Nothing -> matchZero + where + m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] + + -- the map of canonicalised keys to groups of inexact matches + m' = Map.mapKeysWith (++) cannonicalise m + + + +------------------------------ +-- Utils +-- + +caseFold :: String -> String +caseFold = lowercase diff --git a/Distribution/Simple/CCompiler.hs b/Distribution/Simple/CCompiler.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/CCompiler.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.CCompiler +-- Copyright : 2011, Dan Knapp +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This simple package provides types and functions for interacting with +-- C compilers. Currently it's just a type enumerating extant C-like +-- languages, which we call dialects. + +{- +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.CCompiler ( + CDialect(..), + cSourceExtensions, + cDialectFilenameExtension, + filenameCDialect + ) where + +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid + ( Monoid(..) ) +#endif +import System.FilePath + ( takeExtension ) + + +-- | Represents a dialect of C. The Monoid instance expresses backward +-- compatibility, in the sense that 'mappend a b' is the least inclusive +-- dialect which both 'a' and 'b' can be correctly interpreted as. +data CDialect = C + | ObjectiveC + | CPlusPlus + | ObjectiveCPlusPlus + deriving (Eq, Show) + +instance Monoid CDialect where + mempty = C + + mappend C anything = anything + mappend ObjectiveC CPlusPlus = ObjectiveCPlusPlus + mappend CPlusPlus ObjectiveC = ObjectiveCPlusPlus + mappend _ ObjectiveCPlusPlus = ObjectiveCPlusPlus + mappend ObjectiveC _ = ObjectiveC + mappend CPlusPlus _ = CPlusPlus + mappend ObjectiveCPlusPlus _ = ObjectiveCPlusPlus + + +-- | A list of all file extensions which are recognized as possibly containing +-- some dialect of C code. Note that this list is only for source files, +-- not for header files. +cSourceExtensions :: [String] +cSourceExtensions = ["c", "i", "ii", "m", "mi", "mm", "M", "mii", "cc", "cp", + "cxx", "cpp", "CPP", "c++", "C"] + + +-- | Takes a dialect of C and whether code is intended to be passed through +-- the preprocessor, and returns a filename extension for containing that +-- code. +cDialectFilenameExtension :: CDialect -> Bool -> String +cDialectFilenameExtension C True = "c" +cDialectFilenameExtension C False = "i" +cDialectFilenameExtension ObjectiveC True = "m" +cDialectFilenameExtension ObjectiveC False = "mi" +cDialectFilenameExtension CPlusPlus True = "cpp" +cDialectFilenameExtension CPlusPlus False = "ii" +cDialectFilenameExtension ObjectiveCPlusPlus True = "mm" +cDialectFilenameExtension ObjectiveCPlusPlus False = "mii" + + +-- | Infers from a filename's extension the dialect of C which it contains, +-- and whether it is intended to be passed through the preprocessor. +filenameCDialect :: String -> Maybe (CDialect, Bool) +filenameCDialect filename = do + extension <- case takeExtension filename of + '.':ext -> Just ext + _ -> Nothing + case extension of + "c" -> return (C, True) + "i" -> return (C, False) + "ii" -> return (CPlusPlus, False) + "m" -> return (ObjectiveC, True) + "mi" -> return (ObjectiveC, False) + "mm" -> return (ObjectiveCPlusPlus, True) + "M" -> return (ObjectiveCPlusPlus, True) + "mii" -> return (ObjectiveCPlusPlus, False) + "cc" -> return (CPlusPlus, True) + "cp" -> return (CPlusPlus, True) + "cxx" -> return (CPlusPlus, True) + "cpp" -> return (CPlusPlus, True) + "CPP" -> return (CPlusPlus, True) + "c++" -> return (CPlusPlus, True) + "C" -> return (CPlusPlus, True) + _ -> Nothing diff --git a/Distribution/Simple/Command.hs b/Distribution/Simple/Command.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Command.hs @@ -0,0 +1,600 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Command +-- Copyright : Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is to do with command line handling. The Cabal command line is +-- organised into a number of named sub-commands (much like darcs). The +-- 'CommandUI' abstraction represents one of these sub-commands, with a name, +-- description, a set of flags. Commands can be associated with actions and +-- run. It handles some common stuff automatically, like the @--help@ and +-- command line completion flags. It is designed to allow other tools make +-- derived commands. This feature is used heavily in @cabal-install@. + +module Distribution.Simple.Command ( + + -- * Command interface + CommandUI(..), + commandShowOptions, + CommandParse(..), + commandParseArgs, + getNormalCommandDescriptions, + helpCommandUI, + + -- ** Constructing commands + ShowOrParseArgs(..), + usageDefault, + usageAlternatives, + mkCommandUI, + hiddenCommand, + + -- ** Associating actions with commands + Command, + commandAddAction, + noExtraFlags, + + -- ** Running commands + commandsRun, + +-- * Option Fields + OptionField(..), Name, + +-- ** Constructing Option Fields + option, multiOption, + +-- ** Liftings & Projections + liftOption, viewAsFieldDescr, + +-- * Option Descriptions + OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder, + +-- ** OptDescr 'smart' constructors + MkOptDescr, + reqArg, reqArg', optArg, optArg', noArg, + boolOpt, boolOpt', choiceOpt, choiceOptFromEnum + + ) where + +import Control.Monad +import Data.Char (isAlpha, toLower) +import Data.List (sortBy) +import Data.Maybe +#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 Text.PrettyPrint ( punctuate, cat, comma, text ) +import Text.PrettyPrint as PP ( empty ) + +data CommandUI flags = CommandUI { + -- | The name of the command as it would be entered on the command line. + -- For example @\"build\"@. + commandName :: String, + -- | A short, one line description of the command to use in help texts. + commandSynopsis :: String, + -- | A function that maps a program name to a usage summary for this + -- command. + commandUsage :: String -> String, + -- | Additional explanation of the command to use in help texts. + commandDescription :: Maybe (String -> String), + -- | Post-Usage notes and examples in help texts + commandNotes :: Maybe (String -> String), + -- | Initial \/ empty flags + commandDefaultFlags :: flags, + -- | All the Option fields for this command + commandOptions :: ShowOrParseArgs -> [OptionField flags] + } + +data ShowOrParseArgs = ShowArgs | ParseArgs +type Name = String +type Description = String + +-- | We usually have a data type for storing configuration values, where +-- every field stores a configuration option, and the user sets +-- the value either via command line flags or a configuration file. +-- An individual OptionField models such a field, and we usually +-- build a list of options associated to a configuration data type. +data OptionField a = OptionField { + optionName :: Name, + optionDescr :: [OptDescr a] } + +-- | An OptionField takes one or more OptDescrs, describing the command line +-- interface for the field. +data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder + (ReadE (a->a)) (a -> [String]) + + | OptArg Description OptFlags ArgPlaceHolder + (ReadE (a->a)) (a->a) (a -> [Maybe String]) + + | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)] + + | BoolOpt Description OptFlags{-True-} OptFlags{-False-} + (Bool -> a -> a) (a-> Maybe Bool) + +-- | Short command line option strings +type SFlags = [Char] +-- | Long command line option strings +type LFlags = [String] +type OptFlags = (SFlags,LFlags) +type ArgPlaceHolder = String + + +-- | Create an option taking a single OptDescr. +-- No explicit Name is given for the Option, the name is the first LFlag given. +option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a + -> OptionField a +option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set] +option _ _ _ _ _ _ = error $ "Distribution.command.option: " + ++ "An OptionField must have at least one LFlag" + +-- | Create an option taking several OptDescrs. +-- You will have to give the flags and description individually to the +-- OptDescr constructor. +multiOption :: Name -> get -> set + -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially + -- applied to flags and description. + -> OptionField a +multiOption n get set args = OptionField n [arg get set | arg <- args] + +type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set + -> OptDescr a + +-- | Create a string-valued command line interface. +reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg ad mkflag showflag sf lf d get set = + ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) + (showflag . get) + +-- | Create a string-valued command line interface with a default value. +optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArg ad mkflag def showflag sf lf d get set = + OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) + (\b -> set (get b `mappend` def) b) + (showflag . get) + +-- | (String -> a) variant of "reqArg" +reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg' ad mkflag showflag = + reqArg ad (succeedReadE mkflag) showflag + +-- | (String -> a) variant of "optArg" +optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) + -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArg' ad mkflag showflag = + optArg ad (succeedReadE (mkflag . Just)) def showflag + where def = mkflag Nothing + +noArg :: (Eq b) => b -> MkOptDescr (a -> b) (b -> a -> a) a +noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d + +boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags + -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt g s sfT sfF _sf _lf@(n:_) d get set = + BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get) +boolOpt _ _ _ _ _ _ _ _ _ = error + "Distribution.Simple.Setup.boolOpt: unreachable" + +boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags + -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get) + +-- | create a Choice option +choiceOpt :: Eq b => [(b,OptFlags,Description)] + -> MkOptDescr (a -> b) (b -> a -> a) a +choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts + where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff] + +-- | create a Choice option out of an enumeration type. +-- As long flags, the Show output is used. As short flags, the first character +-- which does not conflict with a previous one is used. +choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => + MkOptDescr (a -> b) (b -> a -> a) a +choiceOptFromEnum _sf _lf d get = + choiceOpt [ (x, (sf, [map toLower $ show x]), d') + | (x, sf) <- sflags' + , let d' = d ++ show x] + _sf _lf d get + where sflags' = foldl f [] [firstOne..] + f prev x = let prevflags = concatMap snd prev in + prev ++ take 1 [(x, [toLower sf]) + | sf <- show x, isAlpha sf + , toLower sf `notElem` prevflags] + firstOne = minBound `asTypeOf` get undefined + +commandGetOpts :: ShowOrParseArgs -> CommandUI flags + -> [GetOpt.OptDescr (flags -> flags)] +commandGetOpts showOrParse command = + concatMap viewAsGetOpt (commandOptions command showOrParse) + +viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)] +viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa + where + optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) = + [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d] + where set' = readEOrFail set + optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) = + [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d] + where set' Nothing = def + set' (Just txt) = readEOrFail set txt + optDescrToGetOpt (ChoiceOpt alts) = + [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ] + optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) = + [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d ] + optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) = + [ GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d ] + optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) = + [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) + , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ] + +-- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > +-- Choice > Opt) and consider only the first one. +viewAsFieldDescr :: OptionField a -> FieldDescr a +viewAsFieldDescr (OptionField _n []) = + error "Distribution.command.viewAsFieldDescr: unexpected" +viewAsFieldDescr (OptionField n dd) = FieldDescr n get set + where + optDescr = head $ sortBy cmp dd + + cmp :: OptDescr a -> OptDescr a -> Ordering + ReqArg{} `cmp` ReqArg{} = EQ + ReqArg{} `cmp` _ = GT + BoolOpt{} `cmp` ReqArg{} = LT + BoolOpt{} `cmp` BoolOpt{} = EQ + BoolOpt{} `cmp` _ = GT + ChoiceOpt{} `cmp` ReqArg{} = LT + ChoiceOpt{} `cmp` BoolOpt{} = LT + ChoiceOpt{} `cmp` ChoiceOpt{} = EQ + ChoiceOpt{} `cmp` _ = GT + OptArg{} `cmp` OptArg{} = EQ + OptArg{} `cmp` _ = LT + +-- get :: a -> Doc + get t = case optDescr of + ReqArg _ _ _ _ ppr -> + (cat . punctuate comma . map text . ppr) t + + OptArg _ _ _ _ _ ppr -> + case ppr t of [] -> PP.empty + (Nothing : _) -> text "True" + (Just a : _) -> text a + + ChoiceOpt alts -> + fromMaybe PP.empty $ listToMaybe + [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t] + + BoolOpt _ _ _ _ enabled -> (maybe PP.empty disp . enabled) t + +-- set :: LineNo -> String -> a -> ParseResult a + set line val a = + case optDescr of + ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val + -- We parse for a single value instead of a + -- list, as one can't really implement + -- parseList :: ReadE a -> ReadE [a] with + -- the current ReadE definition + ChoiceOpt{} -> + case getChoiceByLongFlag optDescr val of + Just f -> return (f a) + _ -> syntaxError line val + + BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runP line n parse val + + OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val + -- Optional arguments are parsed just like + -- required arguments here; we don't + -- provide a method to set an OptArg field + -- to the default value. + +getChoiceByLongFlag :: OptDescr b -> String -> Maybe (b->b) +getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe + [ set | (_,(_sf,lf:_), set, _) <- alts + , lf == val] + +getChoiceByLongFlag _ _ = + error "Distribution.command.getChoiceByLongFlag: expected a choice option" + +getCurrentChoice :: OptDescr a -> a -> [String] +getCurrentChoice (ChoiceOpt alts) a = + [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a] + +getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr" + + +liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b +liftOption get' set' opt = + opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt} + + +liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b +liftOptDescr get' set' (ChoiceOpt opts) = + ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get')) + | (d, ff, set, get) <- opts] + +liftOptDescr get' set' (OptArg d ff ad set def get) = + OptArg d ff ad (liftSet get' set' `fmap` set) + (liftSet get' set' def) (get . get') + +liftOptDescr get' set' (ReqArg d ff ad set get) = + ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') + +liftOptDescr get' set' (BoolOpt d ffT ffF set get) = + BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') + +liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b +liftSet get' set' set x = set' (set $ get' x) x + +-- | Show flags in the standard long option command line format +commandShowOptions :: CommandUI flags -> flags -> [String] +commandShowOptions command v = concat + [ showOptDescr v od | o <- commandOptions command ParseArgs + , od <- optionDescr o] + where + maybePrefix [] = [] + maybePrefix (lOpt:_) = ["--" ++ lOpt] + + showOptDescr :: a -> OptDescr a -> [String] + showOptDescr x (BoolOpt _ (_,lfTs) (_,lfFs) _ enabled) + = case enabled x of + Nothing -> [] + Just True -> maybePrefix lfTs + Just False -> maybePrefix lfFs + showOptDescr x c@ChoiceOpt{} + = ["--" ++ val | val <- getCurrentChoice c x] + showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag) + = [ "--"++lf++"="++flag + | flag <- showflag x ] + showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag) + = [ case flag of + Just s -> "--"++lf++"="++s + Nothing -> "--"++lf + | flag <- showflag x ] + showOptDescr _ _ + = error "Distribution.Simple.Command.showOptDescr: unreachable" + + +commandListOptions :: CommandUI flags -> [String] +commandListOptions command = + concatMap listOption $ + addCommonFlags ShowArgs $ -- This is a slight hack, we don't want + -- "--list-options" showing up in the + -- list options output, so use ShowArgs + commandGetOpts ShowArgs command + where + listOption (GetOpt.Option shortNames longNames _ _) = + [ "-" ++ [name] | name <- shortNames ] + ++ [ "--" ++ name | name <- longNames ] + +-- | The help text for this command with descriptions of all the options. +commandHelp :: CommandUI flags -> String -> String +commandHelp command pname = + commandSynopsis command + ++ "\n\n" + ++ commandUsage command pname + ++ ( case commandDescription command of + Nothing -> "" + Just desc -> '\n': desc pname) + ++ "\n" + ++ ( if cname == "" + then "Global flags:" + else "Flags for " ++ cname ++ ":" ) + ++ ( GetOpt.usageInfo "" + . addCommonFlags ShowArgs + $ commandGetOpts ShowArgs command ) + ++ ( case commandNotes command of + Nothing -> "" + Just notes -> '\n': notes pname) + where cname = commandName command + +-- | Default "usage" documentation text for commands. +usageDefault :: String -> String -> String +usageDefault name pname = + "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" + ++ "Flags for " ++ name ++ ":" + +-- | Create "usage" documentation from a list of parameter +-- configurations. +usageAlternatives :: String -> [String] -> String -> String +usageAlternatives name strs pname = unlines + [ start ++ pname ++ " " ++ name ++ " " ++ s + | let starts = "Usage: " : repeat " or: " + , (start, s) <- zip starts strs + ] + +-- | Make a Command from standard 'GetOpt' options. +mkCommandUI :: String -- ^ name + -> String -- ^ synopsis + -> [String] -- ^ usage alternatives + -> flags -- ^ initial\/empty flags + -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options + -> CommandUI flags +mkCommandUI name synopsis usages flags options = CommandUI + { commandName = name + , commandSynopsis = synopsis + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = usageAlternatives name usages + , commandDefaultFlags = flags + , commandOptions = options + } + +-- | Common flags that apply to every command +data CommonFlag = HelpFlag | ListOptionsFlag + +commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag] +commonFlags showOrParseArgs = case showOrParseArgs of + ShowArgs -> [help] + ParseArgs -> [help, list] + where + help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag) + "Show this help text" + helpShortFlags = case showOrParseArgs of + ShowArgs -> ['h'] + ParseArgs -> ['h', '?'] + list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag) + "Print a list of command line flags" + +addCommonFlags :: ShowOrParseArgs + -> [GetOpt.OptDescr a] + -> [GetOpt.OptDescr (Either CommonFlag a)] +addCommonFlags showOrParseArgs options = + map (fmapOptDesc Left) (commonFlags showOrParseArgs) + ++ map (fmapOptDesc Right) options + where fmapOptDesc f (GetOpt.Option s l d m) = + GetOpt.Option s l (fmapArgDesc f d) m + fmapArgDesc f (GetOpt.NoArg a) = GetOpt.NoArg (f a) + fmapArgDesc f (GetOpt.ReqArg s d) = GetOpt.ReqArg (f . s) d + fmapArgDesc f (GetOpt.OptArg s d) = GetOpt.OptArg (f . s) d + +-- | Parse a bunch of command line arguments +-- +commandParseArgs :: CommandUI flags + -> Bool -- ^ Is the command a global or subcommand? + -> [String] + -> CommandParse (flags -> flags, [String]) +commandParseArgs command global args = + let options = addCommonFlags ParseArgs + $ commandGetOpts ParseArgs command + order | global = GetOpt.RequireOrder + | otherwise = GetOpt.Permute + in case GetOpt.getOpt' order options args of + (flags, _, _, _) + | any listFlag flags -> CommandList (commandListOptions command) + | any helpFlag flags -> CommandHelp (commandHelp command) + where listFlag (Left ListOptionsFlag) = True; listFlag _ = False + helpFlag (Left HelpFlag) = True; helpFlag _ = False + (flags, opts, opts', []) + | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') + | otherwise -> CommandErrors (unrecognised opts') + (_, _, _, errs) -> CommandErrors errs + + where -- Note: It is crucial to use reverse function composition here or to + -- reverse the flags here as we want to process the flags left to right + -- but data flow in function composition is right to left. + accum flags = foldr (flip (.)) id [ f | Right f <- flags ] + unrecognised opts = [ "unrecognized " + ++ "'" ++ (commandName command) ++ "'" + ++ " option `" ++ opt ++ "'\n" + | opt <- opts ] + -- For unrecognised global flags we put them in the position just after + -- the command, if there is one. This gives us a chance to parse them + -- as sub-command rather than global flags. + mix [] ys = ys + mix (x:xs) ys = x:ys++xs + +data CommandParse flags = CommandHelp (String -> String) + | CommandList [String] + | CommandErrors [String] + | CommandReadyToGo flags +instance Functor CommandParse where + fmap _ (CommandHelp help) = CommandHelp help + fmap _ (CommandList opts) = CommandList opts + fmap _ (CommandErrors errs) = CommandErrors errs + fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags) + + +data CommandType = NormalCommand | HiddenCommand +data Command action = + Command String String ([String] -> CommandParse action) CommandType + +-- | Mark command as hidden. Hidden commands don't show up in the 'progname +-- help' or 'progname --help' output. +hiddenCommand :: Command action -> Command action +hiddenCommand (Command name synopsys f _cmdType) = + Command name synopsys f HiddenCommand + +commandAddAction :: CommandUI flags + -> (flags -> [String] -> action) + -> Command action +commandAddAction command action = + Command (commandName command) + (commandSynopsis command) + (fmap (uncurry applyDefaultArgs) . commandParseArgs command False) + NormalCommand + + where applyDefaultArgs mkflags args = + let flags = mkflags (commandDefaultFlags command) + in action flags args + +commandsRun :: CommandUI a + -> [Command action] + -> [String] + -> CommandParse (a, CommandParse action) +commandsRun globalCommand commands args = + case commandParseArgs globalCommand True args of + CommandHelp help -> CommandHelp help + CommandList opts -> CommandList (opts ++ commandNames) + CommandErrors errs -> CommandErrors errs + CommandReadyToGo (mkflags, args') -> case args' of + ("help":cmdArgs) -> handleHelpCommand cmdArgs + (name:cmdArgs) -> case lookupCommand name of + [Command _ _ action _] + -> CommandReadyToGo (flags, action cmdArgs) + _ -> CommandReadyToGo (flags, badCommand name) + [] -> CommandReadyToGo (flags, noCommand) + where flags = mkflags (commandDefaultFlags globalCommand) + + where + lookupCommand cname = [ cmd | cmd@(Command cname' _ _ _) <- commands' + , cname' == cname ] + noCommand = CommandErrors ["no command given (try --help)\n"] + badCommand cname = CommandErrors ["unrecognised command: " ++ cname + ++ " (try --help)\n"] + commands' = commands ++ [commandAddAction helpCommandUI undefined] + commandNames = [ name | (Command name _ _ NormalCommand) <- commands' ] + + -- A bit of a hack: support "prog help" as a synonym of "prog --help" + -- furthermore, support "prog help command" as "prog command --help" + handleHelpCommand cmdArgs = + case commandParseArgs helpCommandUI True cmdArgs of + CommandHelp help -> CommandHelp help + CommandList list -> CommandList (list ++ commandNames) + CommandErrors _ -> CommandHelp globalHelp + CommandReadyToGo (_,[]) -> CommandHelp globalHelp + CommandReadyToGo (_,(name:cmdArgs')) -> + case lookupCommand name of + [Command _ _ action _] -> + case action ("--help":cmdArgs') of + CommandHelp help -> CommandHelp help + CommandList _ -> CommandList [] + _ -> CommandHelp globalHelp + _ -> badCommand name + + where globalHelp = commandHelp globalCommand + +-- | Utility function, many commands do not accept additional flags. This +-- action fails with a helpful error message if the user supplies any extra. +-- +noExtraFlags :: [String] -> IO () +noExtraFlags [] = return () +noExtraFlags extraFlags = + die $ "Unrecognised flags: " ++ intercalate ", " extraFlags +--TODO: eliminate this function and turn it into a variant on commandAddAction +-- instead like commandAddActionNoArgs that doesn't supply the [String] + +-- | Helper function for creating globalCommand description +getNormalCommandDescriptions :: [Command action] -> [(String, String)] +getNormalCommandDescriptions cmds = + [ (name, description) + | Command name description _ NormalCommand <- cmds ] + +helpCommandUI :: CommandUI () +helpCommandUI = mkCommandUI + "help" + "Help about commands." + ["[FLAGS]", "COMMAND [FLAGS]"] + () + (const []) diff --git a/Distribution/Simple/Compiler.hs b/Distribution/Simple/Compiler.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Compiler.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Compiler +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This should be a much more sophisticated abstraction than it is. Currently +-- it's just a bit of data about the compiler, like it's flavour and name and +-- version. The reason it's just data is because currently it has to be in +-- 'Read' and 'Show' so it can be saved along with the 'LocalBuildInfo'. The +-- only interesting bit of info it contains is a mapping between language +-- extensions and compiler command line flags. This module also defines a +-- 'PackageDB' type which is used to refer to package databases. Most compilers +-- only know about a single global package collection but GHC has a global and +-- per-user one and it lets you create arbitrary other package databases. We do +-- not yet fully support this latter feature. + +module Distribution.Simple.Compiler ( + -- * Haskell implementations + module Distribution.Compiler, + Compiler(..), + showCompilerId, showCompilerIdWithAbi, + compilerFlavor, compilerVersion, + compilerCompatVersion, + compilerInfo, + + -- * Support for package databases + PackageDB(..), + PackageDBStack, + registrationPackageDB, + absolutePackageDBPaths, + absolutePackageDBPath, + + -- * Support for optimisation levels + OptimisationLevel(..), + flagToOptimisationLevel, + + -- * Support for debug info levels + DebugInfoLevel(..), + flagToDebugInfoLevel, + + -- * Support for language extensions + Flag, + languageToFlags, + unsupportedLanguages, + extensionsToFlags, + unsupportedExtensions, + parmakeSupported, + reexportedModulesSupported, + renamingPackageFlagsSupported, + packageKeySupported + ) where + +import Distribution.Compiler +import Distribution.Version (Version(..)) +import Distribution.Text (display) +import Language.Haskell.Extension (Language(Haskell98), Extension) + +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) +import GHC.Generics (Generic) +import System.Directory (canonicalizePath) + +data Compiler = Compiler { + compilerId :: CompilerId, + -- ^ Compiler flavour and version. + compilerAbiTag :: AbiTag, + -- ^ Tag for distinguishing incompatible ABI's on the same architecture/os. + compilerCompat :: [CompilerId], + -- ^ Other implementations that this compiler claims to be compatible with. + compilerLanguages :: [(Language, Flag)], + -- ^ Supported language standards. + compilerExtensions :: [(Extension, Flag)], + -- ^ Supported extensions. + compilerProperties :: M.Map String String + -- ^ A key-value map for properties not covered by the above fields. + } + deriving (Generic, Show, Read) + +instance Binary Compiler + +showCompilerId :: Compiler -> String +showCompilerId = display . compilerId + +showCompilerIdWithAbi :: Compiler -> String +showCompilerIdWithAbi comp = + display (compilerId comp) ++ + case compilerAbiTag comp of + NoAbiTag -> [] + AbiTag xs -> '-':xs + +compilerFlavor :: Compiler -> CompilerFlavor +compilerFlavor = (\(CompilerId f _) -> f) . compilerId + +compilerVersion :: Compiler -> Version +compilerVersion = (\(CompilerId _ v) -> v) . compilerId + +compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version +compilerCompatVersion flavor comp + | compilerFlavor comp == flavor = Just (compilerVersion comp) + | otherwise = + listToMaybe [ v | CompilerId fl v <- compilerCompat comp, fl == flavor ] + +compilerInfo :: Compiler -> CompilerInfo +compilerInfo c = CompilerInfo (compilerId c) + (compilerAbiTag c) + (Just . compilerCompat $ c) + (Just . map fst . compilerLanguages $ c) + (Just . map fst . compilerExtensions $ c) + +-- ------------------------------------------------------------ +-- * Package databases +-- ------------------------------------------------------------ + +-- |Some compilers have a notion of a database of available packages. +-- For some there is just one global db of packages, other compilers +-- support a per-user or an arbitrary db specified at some location in +-- the file system. This can be used to build isloated environments of +-- packages, for example to build a collection of related packages +-- without installing them globally. +-- +data PackageDB = GlobalPackageDB + | UserPackageDB + | SpecificPackageDB FilePath + deriving (Eq, Generic, Ord, Show, Read) + +instance Binary PackageDB + +-- | We typically get packages from several databases, and stack them +-- together. This type lets us be explicit about that stacking. For example +-- typical stacks include: +-- +-- > [GlobalPackageDB] +-- > [GlobalPackageDB, UserPackageDB] +-- > [GlobalPackageDB, SpecificPackageDB "package.conf.inplace"] +-- +-- Note that the 'GlobalPackageDB' is invariably at the bottom since it +-- contains the rts, base and other special compiler-specific packages. +-- +-- We are not restricted to using just the above combinations. In particular +-- we can use several custom package dbs and the user package db together. +-- +-- When it comes to writing, the top most (last) package is used. +-- +type PackageDBStack = [PackageDB] + +-- | Return the package that we should register into. This is the package db at +-- the top of the stack. +-- +registrationPackageDB :: PackageDBStack -> PackageDB +registrationPackageDB [] = error "internal error: empty package db set" +registrationPackageDB dbs = last dbs + +-- | Make package paths absolute + + +absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack +absolutePackageDBPaths = mapM absolutePackageDBPath + +absolutePackageDBPath :: PackageDB -> IO PackageDB +absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB +absolutePackageDBPath UserPackageDB = return UserPackageDB +absolutePackageDBPath (SpecificPackageDB db) = + SpecificPackageDB `liftM` canonicalizePath db + +-- ------------------------------------------------------------ +-- * Optimisation levels +-- ------------------------------------------------------------ + +-- | Some compilers support optimising. Some have different levels. +-- For compilers that do not the level is just capped to the level +-- they do support. +-- +data OptimisationLevel = NoOptimisation + | NormalOptimisation + | MaximumOptimisation + deriving (Bounded, Enum, Eq, Generic, Read, Show) + +instance Binary OptimisationLevel + +flagToOptimisationLevel :: Maybe String -> OptimisationLevel +flagToOptimisationLevel Nothing = NormalOptimisation +flagToOptimisationLevel (Just s) = case reads s of + [(i, "")] + | i >= fromEnum (minBound :: OptimisationLevel) + && i <= fromEnum (maxBound :: OptimisationLevel) + -> toEnum i + | otherwise -> error $ "Bad optimisation level: " ++ show i + ++ ". Valid values are 0..2" + _ -> error $ "Can't parse optimisation level " ++ s + +-- ------------------------------------------------------------ +-- * Debug info levels +-- ------------------------------------------------------------ + +-- | Some compilers support emitting debug info. Some have different +-- levels. For compilers that do not the level is just capped to the +-- level they do support. +-- +data DebugInfoLevel = NoDebugInfo + | MinimalDebugInfo + | NormalDebugInfo + | MaximalDebugInfo + deriving (Bounded, Enum, Eq, Generic, Read, Show) + +instance Binary DebugInfoLevel + +flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel +flagToDebugInfoLevel Nothing = NormalDebugInfo +flagToDebugInfoLevel (Just s) = case reads s of + [(i, "")] + | i >= fromEnum (minBound :: DebugInfoLevel) + && i <= fromEnum (maxBound :: DebugInfoLevel) + -> toEnum i + | otherwise -> error $ "Bad debug info level: " ++ show i + ++ ". Valid values are 0..3" + _ -> error $ "Can't parse debug info level " ++ s + +-- ------------------------------------------------------------ +-- * Languages and Extensions +-- ------------------------------------------------------------ + +unsupportedLanguages :: Compiler -> [Language] -> [Language] +unsupportedLanguages comp langs = + [ lang | lang <- langs + , isNothing (languageToFlag comp lang) ] + +languageToFlags :: Compiler -> Maybe Language -> [Flag] +languageToFlags comp = filter (not . null) + . catMaybes . map (languageToFlag comp) + . maybe [Haskell98] (\x->[x]) + +languageToFlag :: Compiler -> Language -> Maybe Flag +languageToFlag comp ext = lookup ext (compilerLanguages comp) + + +-- |For the given compiler, return the extensions it does not support. +unsupportedExtensions :: Compiler -> [Extension] -> [Extension] +unsupportedExtensions comp exts = + [ ext | ext <- exts + , isNothing (extensionToFlag comp ext) ] + +type Flag = String + +-- |For the given compiler, return the flags for the supported extensions. +extensionsToFlags :: Compiler -> [Extension] -> [Flag] +extensionsToFlags comp = nub . filter (not . null) + . catMaybes . map (extensionToFlag comp) + +extensionToFlag :: Compiler -> Extension -> Maybe Flag +extensionToFlag comp ext = lookup ext (compilerExtensions comp) + +-- | Does this compiler support parallel --make mode? +parmakeSupported :: Compiler -> Bool +parmakeSupported = ghcSupported "Support parallel --make" + +-- | Does this compiler support reexported-modules? +reexportedModulesSupported :: Compiler -> Bool +reexportedModulesSupported = ghcSupported "Support reexported-modules" + +-- | Does this compiler support thinning/renaming on package flags? +renamingPackageFlagsSupported :: Compiler -> Bool +renamingPackageFlagsSupported = ghcSupported "Support thinning and renaming package flags" + +-- | Does this compiler support package keys? +packageKeySupported :: Compiler -> Bool +packageKeySupported = ghcSupported "Uses package keys" + +-- | Utility function for GHC only features +ghcSupported :: String -> Compiler -> Bool +ghcSupported key comp = + case compilerFlavor comp of + GHC -> checkProp + GHCJS -> checkProp + _ -> False + where checkProp = + case M.lookup key (compilerProperties comp) of + Just "YES" -> True + _ -> False diff --git a/Distribution/Simple/Configure.hs b/Distribution/Simple/Configure.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Configure.hs @@ -0,0 +1,1702 @@ +{-# 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 ) + +-- | 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) + +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 + +-- | 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 +-- ----------------------------------------------------------------------------- + +-- |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 (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.") + + 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 withProf_ = fromFlagOrDefault False (configProf cfg) + withProfExe_ = fromFlagOrDefault withProf_ $ 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" + +-- | 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 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 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. + +reportModuleReexportProblems :: [(ModuleReexport, String)] -> IO a +reportModuleReexportProblems reexportProblems = + die $ unlines + [ "Problem with the module re-export '" ++ display reexport ++ "': " ++ msg + | (reexport, msg) <- reexportProblems ] + +-- ----------------------------------------------------------------------------- +-- Testing C lib and header dependencies + +-- Try to build a test C program which includes every header and links every +-- lib. If that fails, try to narrow it down by preprocessing (only) and linking +-- with individual headers and libs. If none is the obvious culprit then give a +-- generic error message. +-- TODO: produce a log file from the compiler errors, if any. +checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () +checkForeignDeps pkg lbi verbosity = do + ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling + -- lucky + (return ()) + (do missingLibs <- findMissingLibs + missingHdr <- findOffendingHdr + explainErrors missingHdr missingLibs) + where + allHeaders = collectField PD.includes + allLibs = collectField PD.extraLibs + + ifBuildsWith headers args success failure = do + ok <- builds (makeProgram headers) args + if ok then success else failure + + findOffendingHdr = + ifBuildsWith allHeaders ccArgs + (return Nothing) + (go . tail . inits $ allHeaders) + where + go [] = return Nothing -- cannot happen + go (hdrs:hdrsInits) = + -- Try just preprocessing first + ifBuildsWith hdrs cppArgs + -- If that works, try compiling too + (ifBuildsWith hdrs ccArgs + (go hdrsInits) + (return . Just . Right . last $ hdrs)) + (return . Just . Left . last $ hdrs) + + cppArgs = "-E":commonCppArgs -- preprocess only + ccArgs = "-c":commonCcArgs -- don't try to link + + findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs) + (return []) + (filterM (fmap not . libExists) allLibs) + + libExists lib = builds (makeProgram []) (makeLdArgs [lib]) + + commonCppArgs = platformDefines lbi + ++ [ "-I" ++ autogenModulesDir lbi ] + ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ] + ++ ["-I."] + ++ collectField PD.cppOptions + ++ collectField PD.ccOptions + ++ [ "-I" ++ dir + | dep <- deps + , dir <- Installed.includeDirs dep ] + ++ [ opt + | dep <- deps + , opt <- Installed.ccOptions dep ] + + commonCcArgs = commonCppArgs + ++ collectField PD.ccOptions + ++ [ opt + | dep <- deps + , opt <- Installed.ccOptions dep ] + + commonLdArgs = [ "-L" ++ dir | dir <- collectField PD.extraLibDirs ] + ++ collectField PD.ldOptions + ++ [ "-L" ++ dir + | dep <- deps + , dir <- Installed.libraryDirs dep ] + --TODO: do we also need dependent packages' ld options? + makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs + + makeProgram hdrs = unlines $ + [ "#include \"" ++ hdr ++ "\"" | hdr <- hdrs ] ++ + ["int main(int argc, char** argv) { return 0; }"] + + collectField f = concatMap f allBi + allBi = allBuildInfo pkg + deps = PackageIndex.topologicalOrder (installedPkgs lbi) + + builds program args = do + tempDir <- getTemporaryDirectory + withTempFile tempDir ".c" $ \cName cHnd -> + withTempFile tempDir "" $ \oNname oHnd -> do + hPutStrLn cHnd program + hClose cHnd + hClose oHnd + _ <- rawSystemProgramStdoutConf verbosity + gccProgram (withPrograms lbi) (cName:"-o":oNname:args) + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + + explainErrors Nothing [] = return () -- should be impossible! + explainErrors _ _ + | isNothing . lookupProgram gccProgram . withPrograms $ lbi + + = die $ unlines $ + [ "No working gcc", + "This package depends on foreign library but we cannot " + ++ "find a working C compiler. If you have it in a " + ++ "non-standard location you can use the --with-gcc " + ++ "flag to specify it." ] + + explainErrors hdr libs = die $ unlines $ + [ if plural + then "Missing dependencies on foreign libraries:" + else "Missing dependency on a foreign library:" + | missing ] + ++ case hdr of + Just (Left h) -> ["* Missing (or bad) header file: " ++ h ] + _ -> [] + ++ case libs of + [] -> [] + [lib] -> ["* Missing C library: " ++ lib] + _ -> ["* Missing C libraries: " ++ intercalate ", " libs] + ++ [if plural then messagePlural else messageSingular | missing] + ++ case hdr of + Just (Left _) -> [ headerCppMessage ] + Just (Right h) -> [ (if missing then "* " else "") + ++ "Bad header file: " ++ h + , headerCcMessage ] + _ -> [] + + where + plural = length libs >= 2 + -- Is there something missing? (as opposed to broken) + missing = not (null libs) + || case hdr of Just (Left _) -> True; _ -> False + + messageSingular = + "This problem can usually be solved by installing the system " + ++ "package that provides this library (you may need the " + ++ "\"-dev\" version). If the library is already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where it is." + messagePlural = + "This problem can usually be solved by installing the system " + ++ "packages that provide these libraries (you may need the " + ++ "\"-dev\" versions). If the libraries are already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where they are." + headerCppMessage = + "If the header file does exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." + headerCcMessage = + "The header file contains a compile error. " + ++ "You can re-run configure with the verbosity flag " + ++ "-v3 to see the error messages from the C compiler." + +-- | Output package check warnings and errors. Exit if any errors. +checkPackageProblems :: Verbosity + -> GenericPackageDescription + -> PackageDescription + -> IO () +checkPackageProblems verbosity gpkg pkg = do + ioChecks <- checkPackageFiles pkg "." + let pureChecks = checkPackage gpkg (Just pkg) + errors = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ] + warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ] + if null errors + then mapM_ (warn verbosity) warnings + else die (intercalate "\n\n" errors) + +-- | Preform checks if a relocatable build is allowed +checkRelocatable :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> IO () +checkRelocatable verbosity pkg lbi + = sequence_ [ checkOS + , checkCompiler + , packagePrefixRelative + , depsPrefixRelative + ] + where + -- Check if the OS support relocatable builds. + -- + -- If you add new OS' to this list, and your OS supports dynamic libraries + -- and RPATH, make sure you add your OS to RPATH-support list of: + -- Distribution.Simple.GHC.getRPaths + checkOS + = unless (os `elem` [ OSX, Linux ]) + $ die $ "Operating system: " ++ display os ++ + ", does not support relocatable builds" + where + (Platform _ os) = hostPlatform lbi + + -- Check if the Compiler support relocatable builds + checkCompiler + = unless (compilerFlavor comp `elem` [ GHC ]) + $ die $ "Compiler: " ++ show comp ++ + ", does not support relocatable builds" + where + comp = compiler lbi + + -- Check if all the install dirs are relative to same prefix + packagePrefixRelative + = unless (relativeInstallDirs installDirs) + $ die $ "Installation directories are not prefix_relative:\n" ++ + show installDirs + where + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + p = prefix installDirs + relativeInstallDirs (InstallDirs {..}) = + all isJust + (fmap (stripPrefix p) + [ bindir, libdir, dynlibdir, libexecdir, includedir, datadir + , docdir, mandir, htmldir, haddockdir, sysconfdir] ) + + -- Check if the library dirs of the dependencies that are in the package + -- database to which the package is installed are relative to the + -- prefix of the package + depsPrefixRelative = do + pkgr <- GHC.pkgRoot verbosity lbi (last (withPackageDB lbi)) + mapM_ (doCheck pkgr) ipkgs + where + doCheck pkgr ipkg + | maybe False (== pkgr) (Installed.pkgRoot ipkg) + = mapM_ (\l -> when (isNothing $ stripPrefix p l) (die (msg l))) + (Installed.libraryDirs ipkg) + | otherwise + = return () + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + p = prefix installDirs + ipkgs = PackageIndex.allPackages (installedPkgs lbi) + msg l = "Library directory of a dependency: " ++ show l ++ + "\nis not relative to the installation prefix:\n" ++ + show p diff --git a/Distribution/Simple/GHC.hs b/Distribution/Simple/GHC.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/GHC.hs @@ -0,0 +1,1126 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC +-- Copyright : Isaac Jones 2003-2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is a fairly large module. It contains most of the GHC-specific code for +-- configuring, building and installing packages. It also exports a function +-- for finding out what packages are already installed. Configuring involves +-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions +-- this version of ghc supports and returning a 'Compiler' value. +-- +-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out +-- what packages are installed. +-- +-- Building is somewhat complex as there is quite a bit of information to take +-- into account. We have to build libs and programs, possibly for profiling and +-- shared libs. We have to support building libraries that will be usable by +-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files +-- using ghc. Linking, especially for @split-objs@ is remarkably complex, +-- partly because there tend to be 1,000's of @.o@ files and this can often be +-- more than we can pass to the @ld@ or @ar@ programs in one go. +-- +-- Installing for libs and exes involves finding the right files and copying +-- them to the right places. One of the more tricky things about this module is +-- remembering the layout of files in the build directory (which is not +-- explicitly documented) and thus what search dirs are used for various kinds +-- of files. + +module Distribution.Simple.GHC ( + getGhcInfo, + configure, getInstalledPackages, getPackageDBContents, + buildLib, buildExe, + replLib, replExe, + startInterpreter, + installLib, installExe, + libAbiHash, + hcPkgInfo, + registerPackage, + componentGhcOptions, + componentCcGhcOptions, + getLibDir, + isDynamic, + getGlobalPackageDB, + pkgRoot + ) where + +import qualified Distribution.Simple.GHC.IPI641 as IPI641 +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 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, haddockProgram, 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, configCoverage, configDistPref ) +import qualified Distribution.Simple.Setup as Cabal + ( Flag(..) ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion + , PackageDB(..), PackageDBStack, AbiTag(..) ) +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 Control.Monad ( unless, when ) +import Data.Char ( isDigit, isSpace ) +import Data.List +import qualified Data.Map as M ( fromList ) +import Data.Maybe ( catMaybes ) +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid ( Monoid(..) ) +#endif +import Data.Version ( showVersion ) +import System.Directory + ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing ) +import System.FilePath ( (), (<.>), takeExtension, + takeDirectory, replaceExtension, + splitExtension, isRelative ) +import qualified System.Info + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration + -> IO (Compiler, Maybe Platform, ProgramConfiguration) +configure verbosity hcPath hcPkgPath conf0 = do + + (ghcProg, ghcVersion, conf1) <- + requireProgramVersion verbosity ghcProgram + (orLaterVersion (Version [6,4] [])) + (userMaybeSpecifyPath "ghc" hcPath conf0) + let implInfo = ghcVersionImplInfo ghcVersion + + -- This is slightly tricky, we have to configure ghc first, then we use the + -- location of ghc to help find ghc-pkg in the case that the user did not + -- specify the location of ghc-pkg directly: + (ghcPkgProg, ghcPkgVersion, conf2) <- + requireProgramVersion verbosity ghcPkgProgram { + programFindLocation = guessGhcPkgFromGhcPath ghcProg + } + anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath conf1) + + when (ghcVersion /= ghcPkgVersion) $ die $ + "Version mismatch between ghc and ghc-pkg: " + ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " " + ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion + + -- Likewise we try to find the matching hsc2hs and haddock programs. + let hsc2hsProgram' = hsc2hsProgram { + programFindLocation = guessHsc2hsFromGhcPath ghcProg + } + haddockProgram' = haddockProgram { + programFindLocation = guessHaddockFromGhcPath ghcProg + } + conf3 = addKnownProgram haddockProgram' $ + addKnownProgram hsc2hsProgram' conf2 + + languages <- Internal.getLanguages verbosity implInfo ghcProg + extensions <- Internal.getExtensions verbosity implInfo ghcProg + + ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg + let ghcInfoMap = M.fromList ghcInfo + + let comp = Compiler { + compilerId = CompilerId GHC ghcVersion, + compilerAbiTag = NoAbiTag, + compilerCompat = [], + compilerLanguages = languages, + compilerExtensions = extensions, + compilerProperties = ghcInfoMap + } + compPlatform = Internal.targetPlatform ghcInfo + -- 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 +-- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking +-- for a versioned or unversioned ghc-pkg in the same dir, that is: +-- +-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg(.exe) +-- +guessToolFromGhcPath :: Program -> ConfiguredProgram + -> Verbosity -> ProgramSearchPath + -> IO (Maybe 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] + info verbosity $ "looking for tool " ++ toolname + ++ " near compiler in " ++ dir + 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) + + where takeVersionSuffix :: FilePath -> String + takeVersionSuffix = takeWhileEndLE isSuffixChar + + 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: +-- +-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg(.exe) +-- +guessGhcPkgFromGhcPath :: ConfiguredProgram + -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) +guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding hsc2hs, we try looking for both a versioned and unversioned +-- hsc2hs in the same dir, that is: +-- +-- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe) +-- > /usr/local/bin/hsc2hs-6.6.1(.exe) +-- > /usr/local/bin/hsc2hs(.exe) +-- +guessHsc2hsFromGhcPath :: ConfiguredProgram + -> Verbosity -> ProgramSearchPath -> IO (Maybe 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) +guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram + +getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] +getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg + where + Just version = programVersion ghcProg + implInfo = ghcVersionImplInfo version + +-- | Given a single package DB, return all installed packages. +getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration + -> IO InstalledPackageIndex +getPackageDBContents verbosity packagedb conf = do + pkgss <- getInstalledPackages' verbosity [packagedb] conf + toPackageIndex verbosity pkgss conf + +-- | Given a package DB stack, return all installed packages. +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO InstalledPackageIndex +getInstalledPackages verbosity packagedbs conf = do + checkPackageDbEnvVar + checkPackageDbStack packagedbs + pkgss <- getInstalledPackages' verbosity packagedbs conf + index <- toPackageIndex verbosity pkgss conf + return $! hackRtsPackage index + + where + hackRtsPackage index = + case PackageIndex.lookupPackageName index (PackageName "rts") of + [(_,[rts])] + -> PackageIndex.insert (removeMingwIncludeDir rts) index + _ -> index -- No (or multiple) ghc rts package is registered!! + -- Feh, whatever, the ghc test suite does some crazy stuff. + +-- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a +-- @PackageIndex@. Helper function used by 'getPackageDBContents' and +-- 'getInstalledPackages'. +toPackageIndex :: Verbosity + -> [(PackageDB, [InstalledPackageInfo])] + -> ProgramConfiguration + -> IO InstalledPackageIndex +toPackageIndex verbosity pkgss conf = do + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it. + topDir <- getLibDir' verbosity ghcProg + let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss ] + return $! (mconcat indices) + + where + Just ghcProg = lookupProgram ghcProgram conf + +getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath +getLibDir verbosity lbi = + dropWhileEndLE isSpace `fmap` + rawSystemProgramStdoutConf verbosity ghcProgram + (withPrograms lbi) ["--print-libdir"] + +getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath +getLibDir' verbosity ghcProg = + dropWhileEndLE isSpace `fmap` + rawSystemProgramStdout verbosity ghcProg ["--print-libdir"] + + +-- | Return the 'FilePath' to the global GHC package database. +getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath +getGlobalPackageDB verbosity ghcProg = + dropWhileEndLE isSpace `fmap` + rawSystemProgramStdout verbosity ghcProg ["--print-global-package-db"] + +checkPackageDbEnvVar :: IO () +checkPackageDbEnvVar = + Internal.checkPackageDbEnvVar "GHC" "GHC_PACKAGE_PATH" + +checkPackageDbStack :: PackageDBStack -> IO () +checkPackageDbStack (GlobalPackageDB:rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStack rest + | GlobalPackageDB `notElem` rest = + die $ "With current ghc versions the global package db is always used " + ++ "and must be listed first. This ghc limitation may be lifted in " + ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977" +checkPackageDbStack _ = + die $ "If the global package db is specified, it must be " + ++ "specified first and cannot be specified multiple times" + +-- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This +-- breaks when you want to use a different gcc, so we need to filter +-- it out. +removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo +removeMingwIncludeDir pkg = + let ids = InstalledPackageInfo.includeDirs pkg + ids' = filter (not . ("mingw" `isSuffixOf`)) ids + in pkg { InstalledPackageInfo.includeDirs = ids' } + +-- | Get the packages from specific PackageDBs, not cumulative. +-- +getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration + -> IO [(PackageDB, [InstalledPackageInfo])] +getInstalledPackages' verbosity packagedbs conf + | ghcVersion >= Version [6,9] [] = + sequence + [ do pkgs <- HcPkg.dump (hcPkgInfo conf) verbosity packagedb + return (packagedb, pkgs) + | packagedb <- packagedbs ] + + where + Just ghcProg = lookupProgram ghcProgram conf + Just ghcVersion = programVersion ghcProg + +getInstalledPackages' verbosity packagedbs conf = do + str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf ["list"] + let pkgFiles = [ init line | line <- lines str, last line == ':' ] + dbFile packagedb = case (packagedb, pkgFiles) of + (GlobalPackageDB, global:_) -> return $ Just global + (UserPackageDB, _global:user:_) -> return $ Just user + (UserPackageDB, _global:_) -> return $ Nothing + (SpecificPackageDB specific, _) -> return $ Just specific + _ -> die "cannot read ghc-pkg package listing" + pkgFiles' <- mapM dbFile packagedbs + sequence [ withFileContents file $ \content -> do + pkgs <- readPackages file content + return (db, pkgs) + | (db , Just file) <- zip packagedbs pkgFiles' ] + where + -- Depending on the version of ghc we use a different type's Read + -- instance to parse the package file and then convert. + -- It's a bit yuck. But that's what we get for using Read/Show. + readPackages + | ghcVersion >= Version [6,4,2] [] + = \file content -> case reads content of + [(pkgs, _)] -> return (map IPI642.toCurrent pkgs) + _ -> failToRead file + | otherwise + = \file content -> case reads content of + [(pkgs, _)] -> return (map IPI641.toCurrent pkgs) + _ -> failToRead file + Just ghcProg = lookupProgram ghcProgram conf + Just ghcVersion = programVersion ghcProg + failToRead file = die $ "cannot read ghc package database " ++ file + +-- ----------------------------------------------------------------------------- +-- Building + +-- | Build a library with GHC. +-- +buildLib, replLib :: Verbosity -> Cabal.Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib = buildOrReplLib False +replLib = buildOrReplLib True + +buildOrReplLib :: Bool -> Verbosity -> Cabal.Flag (Maybe Int) + -> 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 + whenVanillaLib forceVanilla = + when (forceVanilla || withVanillaLib lbi) + whenProfLib = when (withProfLib lbi) + whenSharedLib forceShared = + when (forceShared || withSharedLib lbi) + whenGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) + ifReplLib = when forRepl + 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) + + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) + let runGhcProg = runGHC verbosity ghcProg comp + + libBi <- hackThreadedFlag verbosity + comp (withProfLib lbi) (libBuildInfo lib) + + let isGhcDynamic = isDynamic comp + dynamicTooSupported = supportsDynamicToo comp + doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi + forceVanillaLib = doingTH && not isGhcDynamic + forceSharedLib = doingTH && isGhcDynamic + -- TH always needs default libs, even when building for profiling + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi + -- Component name. Not 'libName' because that has the "HS" prefix + -- that GHC gives Haskell libraries. + cname = display $ PD.package $ localPkgDescr lbi + distPref = fromFlag $ configDistPref $ configFlags lbi + hpcdir way + | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname + | otherwise = mempty + + createDirectoryIfMissingVerbose verbosity True libTargetDir + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? + let cObjs = map (`replaceExtension` objExtension) (cSources libBi) + baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir + vanillaOpts = baseOpts `mappend` mempty { + ghcOptMode = toFlag GhcModeMake, + ghcOptNumJobs = numJobs, + ghcOptPackageKey = toFlag (pkgKey lbi), + ghcOptSigOf = hole_insts, + ghcOptInputModules = toNubListR $ libModules lib, + ghcOptHPCDir = hpcdir Hpc.Vanilla + } + + profOpts = vanillaOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptHiSuffix = toFlag "p_hi", + ghcOptObjSuffix = toFlag "p_o", + ghcOptExtra = toNubListR $ hcProfOptions GHC libBi, + ghcOptHPCDir = hpcdir Hpc.Prof + } + + sharedOpts = vanillaOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptFPic = toFlag True, + ghcOptHiSuffix = toFlag "dyn_hi", + ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = toNubListR $ hcSharedOptions GHC libBi, + ghcOptHPCDir = hpcdir Hpc.Dyn + } + linkerOpts = mempty { + ghcOptLinkOptions = toNubListR $ PD.ldOptions libBi, + ghcOptLinkLibs = toNubListR $ extraLibs libBi, + ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, + ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, + ghcOptInputFiles = toNubListR + [libTargetDir x | x <- cObjs] + } + replOpts = vanillaOpts { + ghcOptExtra = overNubListR + Internal.filterGhciFlags $ + (ghcOptExtra vanillaOpts), + ghcOptNumJobs = mempty + } + `mappend` linkerOpts + `mappend` mempty { + ghcOptMode = toFlag GhcModeInteractive, + ghcOptOptimisation = toFlag GhcNoOptimisation + } + + vanillaSharedOpts = vanillaOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, + ghcOptDynHiSuffix = toFlag "dyn_hi", + ghcOptDynObjSuffix = toFlag "dyn_o", + ghcOptHPCDir = hpcdir Hpc.Dyn + } + + unless (forRepl || null (libModules lib)) $ + do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts) + shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts) + useDynToo = dynamicTooSupported && + (forceVanillaLib || withVanillaLib lbi) && + (forceSharedLib || withSharedLib lbi) && + null (hcSharedOptions GHC libBi) + if useDynToo + then do + runGhcProg vanillaSharedOpts + case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of + (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> do + -- 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 + -- static and dynamically linked executables. We copy + -- the modules interfaces so they are available under + -- both ways. + copyDirectoryRecursive verbosity dynDir vanillaDir + _ -> return () + else if isGhcDynamic + then do shared; vanilla + else do vanilla; shared + whenProfLib (runGhcProg profOpts) + + -- build any C sources + unless (null (cSources libBi)) $ do + info verbosity "Building C Sources..." + sequence_ + [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo + lbi libBi clbi libTargetDir filename + vanillaCcOpts = if isGhcDynamic + -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + then baseCcOpts { ghcOptFPic = toFlag True } + else baseCcOpts + profCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCcOpts) + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg vanillaCcOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProg sharedCcOpts) + unless forRepl $ whenProfLib (runGhcProg profCcOpts) + | filename <- cSources libBi] + + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + + ifReplLib $ do + when (null (libModules lib)) $ warn verbosity "No exposed modules" + ifReplLib (runGhcProg replOpts) + + -- link: + unless forRepl $ do + info verbosity "Linking..." + let cProfObjs = map (`replaceExtension` ("p_" ++ objExtension)) + (cSources libBi) + cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) + (cSources libBi) + cid = compilerId (compiler lbi) + vanillaLibFilePath = libTargetDir mkLibName libName + profileLibFilePath = libTargetDir mkProfLibName libName + sharedLibFilePath = libTargetDir mkSharedLibName cid libName + ghciLibFilePath = libTargetDir Internal.mkGHCiLibName libName + libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest + sharedLibInstallPath = libInstallPath mkSharedLibName cid libName + + stubObjs <- fmap catMaybes $ sequence + [ findFileWithExtension [objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files + , x <- libModules lib ] + stubProfObjs <- fmap catMaybes $ sequence + [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files + , x <- libModules lib ] + stubSharedObjs <- fmap catMaybes $ sequence + [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files + , x <- libModules lib ] + + hObjs <- Internal.getHaskellObjects implInfo lib lbi + libTargetDir objExtension True + hProfObjs <- + if (withProfLib lbi) + then Internal.getHaskellObjects implInfo lib lbi + libTargetDir ("p_" ++ objExtension) True + else return [] + hSharedObjs <- + if (withSharedLib lbi) + then Internal.getHaskellObjects implInfo lib lbi + libTargetDir ("dyn_" ++ objExtension) False + else return [] + + unless (null hObjs && null cObjs && null stubObjs) $ do + rpaths <- getRPaths lbi clbi + + let staticObjectFiles = + hObjs + ++ map (libTargetDir ) cObjs + ++ stubObjs + profObjectFiles = + hProfObjs + ++ map (libTargetDir ) cProfObjs + ++ stubProfObjs + ghciObjFiles = + hObjs + ++ map (libTargetDir ) cObjs + ++ stubObjs + dynamicObjectFiles = + hSharedObjs + ++ map (libTargetDir ) cSharedObjs + ++ stubSharedObjs + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs = + mempty { + ghcOptShared = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptInputFiles = toNubListR dynamicObjectFiles, + ghcOptOutputFile = toFlag sharedLibFilePath, + -- 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] []) + then toFlag sharedLibInstallPath + else mempty, + ghcOptPackageKey = toFlag (pkgKey lbi), + ghcOptNoAutoLinkPackages = toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptPackages = toNubListR $ + Internal.mkGhcOptPackages clbi , + ghcOptLinkLibs = toNubListR $ extraLibs libBi, + ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, + ghcOptRPaths = rpaths + } + + info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) + + whenVanillaLib False $ do + Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles + + whenProfLib $ do + Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles + + whenGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity ldProg + ghciLibFilePath ghciObjFiles + + whenSharedLib False $ + runGhcProg ghcSharedLinkArgs + +-- | Start a REPL without loading any source files. +startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler + -> PackageDBStack -> IO () +startInterpreter verbosity conf comp packageDBs = do + let replOpts = mempty { + ghcOptMode = toFlag GhcModeInteractive, + ghcOptPackageDBs = packageDBs + } + checkPackageDbStack packageDBs + (ghcProg, _) <- requireProgram verbosity ghcProgram conf + runGHC verbosity ghcProg comp replOpts + +-- | Build an executable with GHC. +-- +buildExe, replExe :: Verbosity -> Cabal.Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe = buildOrReplExe False +replExe = buildOrReplExe True + +buildOrReplExe :: Bool -> Verbosity -> Cabal.Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi + exe@Executable { exeName = exeName', modulePath = modPath } clbi = do + + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) + let comp = compiler lbi + implInfo = getImplInfo comp + runGhcProg = runGHC verbosity ghcProg comp + + exeBi <- hackThreadedFlag verbosity + comp (withProfExe lbi) (buildInfo exe) + + -- exeNameReal, the name that GHC really uses (with .exe on Windows) + let exeNameReal = exeName' <.> + (if takeExtension exeName' /= ('.':exeExtension) + then exeExtension + else "") + + let targetDir = (buildDir lbi) exeName' + let exeDir = targetDir (exeName' ++ "-tmp") + createDirectoryIfMissingVerbose verbosity True targetDir + createDirectoryIfMissingVerbose verbosity True exeDir + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? FIX: what about exeName.hi-boot? + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi + distPref = fromFlag $ configDistPref $ configFlags lbi + hpcdir way + | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName' + | otherwise = mempty + + -- build executables + + srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath + rpaths <- getRPaths lbi clbi + + let isGhcDynamic = isDynamic comp + dynamicTooSupported = supportsDynamicToo comp + isHaskellMain = elem (takeExtension srcMainFile) [".hs", ".lhs"] + cSrcs = cSources exeBi ++ [srcMainFile | not isHaskellMain] + cObjs = map (`replaceExtension` objExtension) cSrcs + baseOpts = (componentGhcOptions verbosity lbi exeBi clbi exeDir) + `mappend` mempty { + ghcOptMode = toFlag GhcModeMake, + ghcOptInputFiles = toNubListR + [ srcMainFile | isHaskellMain], + ghcOptInputModules = toNubListR + [ m | not isHaskellMain, m <- exeModules exe] + } + staticOpts = baseOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcStaticOnly, + ghcOptHPCDir = hpcdir Hpc.Vanilla + } + profOpts = baseOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptHiSuffix = toFlag "p_hi", + ghcOptObjSuffix = toFlag "p_o", + ghcOptExtra = toNubListR $ + hcProfOptions GHC exeBi, + ghcOptHPCDir = hpcdir Hpc.Prof + } + dynOpts = baseOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptHiSuffix = toFlag "dyn_hi", + ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = toNubListR $ + hcSharedOptions GHC exeBi, + ghcOptHPCDir = hpcdir Hpc.Dyn + } + dynTooOpts = staticOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, + ghcOptDynHiSuffix = toFlag "dyn_hi", + ghcOptDynObjSuffix = toFlag "dyn_o", + ghcOptHPCDir = hpcdir Hpc.Dyn + } + linkerOpts = mempty { + ghcOptLinkOptions = toNubListR $ PD.ldOptions exeBi, + ghcOptLinkLibs = toNubListR $ extraLibs exeBi, + ghcOptLinkLibPath = toNubListR $ extraLibDirs exeBi, + ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi, + ghcOptInputFiles = toNubListR + [exeDir x | x <- cObjs], + ghcOptRPaths = rpaths + } + replOpts = baseOpts { + ghcOptExtra = overNubListR + Internal.filterGhciFlags + (ghcOptExtra baseOpts) + } + -- For a normal compile we do separate invocations of ghc for + -- compiling as for linking. But for repl we have to do just + -- the one invocation, so that one has to include all the + -- linker stuff too, like -l flags and any .o files from C + -- files etc. + `mappend` linkerOpts + `mappend` mempty { + ghcOptMode = toFlag GhcModeInteractive, + ghcOptOptimisation = toFlag GhcNoOptimisation + } + commonOpts | withProfExe lbi = profOpts + | withDynExe lbi = dynOpts + | otherwise = staticOpts + compileOpts | useDynToo = dynTooOpts + | otherwise = commonOpts + withStaticExe = (not $ withProfExe lbi) && (not $ withDynExe lbi) + + -- For building exe's that use TH with -prof or -dynamic we actually have + -- to build twice, once without -prof/-dynamic and then again with + -- -prof/-dynamic. This is because the code that TH needs to run at + -- compile time needs to be the vanilla ABI so it can be loaded up and run + -- by the compiler. + -- With dynamic-by-default GHC the TH object files loaded at compile-time + -- need to be .dyn_o instead of .o. + doingTH = EnableExtension TemplateHaskell `elem` allExtensions exeBi + -- Should we use -dynamic-too instead of compiling twice? + useDynToo = dynamicTooSupported && isGhcDynamic + && doingTH && withStaticExe + && null (hcSharedOptions GHC exeBi) + compileTHOpts | isGhcDynamic = dynOpts + | otherwise = staticOpts + compileForTH + | forRepl = False + | useDynToo = False + | isGhcDynamic = doingTH && (withProfExe lbi || withStaticExe) + | otherwise = doingTH && (withProfExe lbi || withDynExe lbi) + + linkOpts = commonOpts `mappend` + linkerOpts `mappend` mempty { + ghcOptLinkNoHsMain = toFlag (not isHaskellMain) + } + + -- Build static/dynamic object files for TH, if needed. + when compileForTH $ + runGhcProg compileTHOpts { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs } + + unless forRepl $ + runGhcProg compileOpts { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs } + + -- build any C sources + unless (null cSrcs) $ do + info verbosity "Building C Sources..." + sequence_ + [ do let opts = (Internal.componentCcGhcOptions verbosity implInfo lbi exeBi + clbi exeDir filename) `mappend` mempty { + ghcOptDynLinkMode = toFlag (if withDynExe lbi + then GhcDynamicOnly + else GhcStaticOnly), + ghcOptProfilingMode = toFlag (withProfExe lbi) + } + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg opts + | filename <- cSrcs ] + + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + when forRepl $ runGhcProg replOpts + + -- link: + unless forRepl $ do + info verbosity "Linking..." + runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir exeNameReal) } + +-- | Calculate the RPATHs for the component we are building. +-- +-- Calculates relative RPATHs when 'relocatable' is set. +getRPaths :: LocalBuildInfo + -> ComponentLocalBuildInfo -- ^ Component we are building + -> IO (NubListR FilePath) +getRPaths lbi clbi | supportRPaths hostOS = do + libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi + let hostPref = case hostOS of + OSX -> "@loader_path" + _ -> "$ORIGIN" + relPath p = if isRelative p then hostPref p else p + rpaths = toNubListR (map relPath libraryPaths) + return rpaths + where + (Platform _ hostOS) = hostPlatform lbi + + -- The list of RPath-supported operating systems below reflects the + -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ + -- reflect whether the OS supports RPATH. + + -- E.g. when this comment was written, the *BSD operating systems were + -- untested with regards to Cabal RPATH handling, and were hence set to + -- 'False', while those operating systems themselves do support RPATH. + supportRPaths Linux   = True + supportRPaths Windows = False + supportRPaths OSX   = True + supportRPaths FreeBSD   = False + supportRPaths OpenBSD   = False + supportRPaths NetBSD   = False + supportRPaths DragonFly = False + supportRPaths Solaris = False + supportRPaths AIX = False + supportRPaths HPUX = False + 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. + +getRPaths _ _ = return mempty + +-- | Filter the "-threaded" flag when profiling as it does not +-- work with ghc-6.8 and older. +hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo +hackThreadedFlag verbosity comp prof bi + | not mustFilterThreaded = return bi + | otherwise = do + warn verbosity $ "The ghc flag '-threaded' is not compatible with " + ++ "profiling in ghc-6.8 and older. It will be disabled." + return bi { options = filterHcOptions (/= "-threaded") (options bi) } + where + mustFilterThreaded = prof && compilerVersion comp < Version [6, 10] [] + && "-threaded" `elem` hcOptions GHC bi + filterHcOptions p hcoptss = + [ (hc, if hc == GHC then filter p opts else opts) + | (hc, opts) <- hcoptss ] + + +-- | Extracts a String representing a hash of the ABI of a built +-- library. It can fail if the library has not yet been built. +-- +libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO String +libAbiHash verbosity _pkg_descr lbi lib clbi = do + libBi <- hackThreadedFlag verbosity + (compiler lbi) (withProfLib lbi) (libBuildInfo lib) + let + comp = compiler 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 { + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptFPic = toFlag True, + ghcOptHiSuffix = toFlag "dyn_hi", + ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = toNubListR $ hcSharedOptions GHC libBi + } + profArgs = vanillaArgs `mappend` mempty { + ghcOptProfilingMode = toFlag True, + 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" + -- + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) + hash <- getProgramInvocationOutput verbosity + (ghcInvocation ghcProg comp ghcArgs) + return (takeWhile (not . isSpace) hash) + +componentGhcOptions :: Verbosity -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo -> FilePath + -> 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 + +-- |Install executables for GHC. +installExe :: Verbosity + -> LocalBuildInfo + -> InstallDirs FilePath -- ^Where to copy the files to + -> FilePath -- ^Build location + -> (FilePath, FilePath) -- ^Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe verbosity lbi installDirs buildPref + (progprefix, progsuffix) _pkg exe = do + let binDir = bindir installDirs + createDirectoryIfMissingVerbose verbosity True binDir + let exeFileName = exeName exe <.> exeExtension + fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix + installBinary dest = do + installExecutableFile verbosity + (buildPref exeName exe exeFileName) + (dest <.> exeExtension) + when (stripExes lbi) $ + Strip.stripExe verbosity (hostPlatform lbi) (withPrograms lbi) + (dest <.> exeExtension) + installBinary (binDir fixedExeBaseName) + +-- |Install for ghc, .hi, .a and, if --with-ghci given, .o +installLib :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^install location + -> FilePath -- ^install location for dynamic libraries + -> FilePath -- ^Build location + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do + -- copy .hi files over: + whenVanilla $ copyModuleFiles "hi" + whenProf $ copyModuleFiles "p_hi" + 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 + + 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 + else installOrdinaryFile verbosity src dst + + installOrdinary = install False + installShared = install True + + 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 + + hasLib = not $ null (libModules lib) + && null (cSources (libBuildInfo lib)) + whenVanilla = when (hasLib && withVanillaLib lbi) + whenProf = when (hasLib && withProfLib lbi) + whenGHCi = when (hasLib && withGHCiLib lbi) + whenShared = when (hasLib && withSharedLib lbi) + +-- ----------------------------------------------------------------------------- +-- Registering + +hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo +hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcPkgProg + , HcPkg.noPkgDbStack = v < [6,9] + , HcPkg.noVerboseFlag = v < [6,11] + , HcPkg.flagPackageConf = v < [7,5] + , HcPkg.useSingleFileDb = v < [7,9] + } + where + v = versionBranch ver + Just ghcPkgProg = lookupProgram ghcPkgProgram conf + Just ver = programVersion ghcPkgProg + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = + HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity + packageDbs (Right installedPkgInfo) + +pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath +pkgRoot verbosity lbi = pkgRoot' + where + pkgRoot' GlobalPackageDB = + let Just ghcProg = lookupProgram ghcProgram (withPrograms lbi) + in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg) + pkgRoot' UserPackageDB = do + appDir <- getAppUserDataDirectory "ghc" + let ver = compilerVersion (compiler lbi) + 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 + -- directory at the time of 'ghc-pkg register', and registration will + -- fail. + createDirectoryIfMissing True rootDir + return rootDir + pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp) + +-- ----------------------------------------------------------------------------- +-- Utils + +isDynamic :: Compiler -> Bool +isDynamic = Internal.ghcLookupProperty "GHC Dynamic" + +supportsDynamicToo :: Compiler -> Bool +supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" diff --git a/Distribution/Simple/GHC/IPI641.hs b/Distribution/Simple/GHC/IPI641.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/GHC/IPI641.hs @@ -0,0 +1,106 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Distribution/Simple/GHC/IPI642.hs @@ -0,0 +1,141 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC.IPI642 +-- Copyright : (c) The University of Glasgow 2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- + +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 + +-- | This is the InstalledPackageInfo type used by ghc-6.4.2 and later. +-- +-- It's here purely for the 'Read' instance so that we can read the package +-- database used by those ghc versions. It is a little hacky to read the +-- package db directly, but we do need the info and until ghc-6.9 there was +-- no better method. +-- +-- In ghc-6.4.1 and before the format was slightly different. +-- See "Distribution.Simple.GHC.IPI642" +-- +data InstalledPackageInfo = InstalledPackageInfo { + package :: PackageIdentifier, + license :: License, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + homepage :: String, + pkgUrl :: String, + description :: String, + category :: String, + exposed :: Bool, + exposedModules :: [String], + hiddenModules :: [String], + importDirs :: [FilePath], + libraryDirs :: [FilePath], + hsLibraries :: [String], + extraLibraries :: [String], + extraGHCiLibraries:: [String], + includeDirs :: [FilePath], + includes :: [String], + depends :: [PackageIdentifier], + hugsOptions :: [String], + ccOptions :: [String], + ldOptions :: [String], + frameworkDirs :: [FilePath], + frameworks :: [String], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath] + } + deriving Read + +data PackageIdentifier = PackageIdentifier { + pkgName :: String, + pkgVersion :: Version + } + deriving Read + +data License = GPL | LGPL | BSD3 | BSD4 + | PublicDomain | AllRightsReserved | OtherLicense + deriving Read + +convertPackageId :: PackageIdentifier -> Current.PackageIdentifier +convertPackageId PackageIdentifier { pkgName = n, pkgVersion = v } = + Current.PackageIdentifier (Current.PackageName n) v + +mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId +mkInstalledPackageId = Current.InstalledPackageId . display + +convertModuleName :: String -> ModuleName +convertModuleName s = fromJust $ simpleParse s + +convertLicense :: License -> Current.License +convertLicense GPL = Current.GPL Nothing +convertLicense LGPL = Current.LGPL Nothing +convertLicense BSD3 = Current.BSD3 +convertLicense BSD4 = Current.BSD4 +convertLicense PublicDomain = Current.PublicDomain +convertLicense AllRightsReserved = Current.AllRightsReserved +convertLicense OtherLicense = Current.OtherLicense + +toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo +toCurrent ipi@InstalledPackageInfo{} = + 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.hiddenModules = map convertModuleName (hiddenModules ipi), + Current.instantiatedWith = [], + 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 = extraGHCiLibraries ipi, + 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/ImplInfo.hs b/Distribution/Simple/GHC/ImplInfo.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/GHC/ImplInfo.hs @@ -0,0 +1,108 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC.ImplInfo +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains the data structure describing invocation +-- details for a GHC or GHC-derived compiler, such as supported flags +-- and workarounds for bugs. + +module Distribution.Simple.GHC.ImplInfo ( + GhcImplInfo(..), getImplInfo, + ghcVersionImplInfo, ghcjsVersionImplInfo, lhcVersionImplInfo + ) where + +import Distribution.Simple.Compiler + ( Compiler(..), CompilerFlavor(..) + , compilerFlavor, compilerVersion, compilerCompatVersion ) +import Distribution.Version ( Version(..) ) + +{- | + Information about features and quirks of a GHC-based implementation. + + Compiler flavors based on GHC behave similarly enough that some of + the support code for them is shared. Every implementation has its + own peculiarities, that may or may not be a direct result of the + underlying GHC version. This record keeps track of these differences. + + All shared code (i.e. everything not in the Distribution.Simple.FLAVOR + module) should use implementation info rather than version numbers + to test for supported features. +-} + +data GhcImplInfo = GhcImplInfo + { hasCcOdirBug :: Bool -- ^ bug in -odir handling for C compilations. + , flagInfoLanguages :: Bool -- ^ --info and --supported-languages flags + , fakeRecordPuns :: Bool -- ^ use -XRecordPuns for NamedFieldPuns + , flagStubdir :: Bool -- ^ -stubdir flag supported + , flagOutputDir :: Bool -- ^ -outputdir flag supported + , noExtInSplitSuffix :: Bool -- ^ split-obj suffix does not contain p_o ext + , flagFfiIncludes :: Bool -- ^ -#include on command line for FFI includes + , flagBuildingCabalPkg :: Bool -- ^ -fbuilding-cabal-package flag supported + , flagPackageId :: Bool -- ^ -package-id / -package flags supported + , separateGccMingw :: Bool -- ^ mingw and gcc are in separate directories + , supportsHaskell2010 :: Bool -- ^ -XHaskell2010 and -XHaskell98 flags + , reportsNoExt :: Bool -- ^ --supported-languages gives Ext and NoExt + , alwaysNondecIndent :: Bool -- ^ NondecreasingIndentation is always on + , flagGhciScript :: Bool -- ^ -ghci-script flag supported + , flagPackageConf :: Bool -- ^ use package-conf instead of package-db + , flagDebugInfo :: Bool -- ^ -g flag supported + } + +getImplInfo :: Compiler -> GhcImplInfo +getImplInfo comp = + case compilerFlavor comp of + GHC -> ghcVersionImplInfo (compilerVersion comp) + LHC -> lhcVersionImplInfo (compilerVersion comp) + GHCJS -> case compilerCompatVersion GHC comp of + Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer + _ -> error ("Distribution.Simple.GHC.Props.getImplProps: " ++ + "could not find GHC version for GHCJS compiler") + x -> error ("Distribution.Simple.GHC.Props.getImplProps only works" ++ + "for GHC-like compilers (GHC, GHCJS, LHC)" ++ + ", but found " ++ show x) + +ghcVersionImplInfo :: Version -> GhcImplInfo +ghcVersionImplInfo (Version v _) = GhcImplInfo + { hasCcOdirBug = v < [6,4,1] + , flagInfoLanguages = v >= [6,7] + , fakeRecordPuns = v >= [6,8] && v < [6,10] + , flagStubdir = v >= [6,8] + , flagOutputDir = v >= [6,10] + , noExtInSplitSuffix = v < [6,11] + , flagFfiIncludes = v < [6,11] + , flagBuildingCabalPkg = v >= [6,11] + , flagPackageId = v > [6,11] + , separateGccMingw = v < [6,12] + , supportsHaskell2010 = v >= [7] + , reportsNoExt = v >= [7] + , alwaysNondecIndent = v < [7,1] + , flagGhciScript = v >= [7,2] + , flagPackageConf = v < [7,5] + , flagDebugInfo = v >= [7,10] + } + +ghcjsVersionImplInfo :: Version -> Version -> GhcImplInfo +ghcjsVersionImplInfo _ghcjsVer _ghcVer = GhcImplInfo + { hasCcOdirBug = False + , flagInfoLanguages = True + , fakeRecordPuns = False + , flagStubdir = True + , flagOutputDir = True + , noExtInSplitSuffix = False + , flagFfiIncludes = False + , flagBuildingCabalPkg = True + , flagPackageId = True + , separateGccMingw = False + , supportsHaskell2010 = True + , reportsNoExt = True + , alwaysNondecIndent = False + , flagGhciScript = True + , flagPackageConf = False + , flagDebugInfo = False + } + +lhcVersionImplInfo :: Version -> GhcImplInfo +lhcVersionImplInfo = ghcVersionImplInfo diff --git a/Distribution/Simple/GHC/Internal.hs b/Distribution/Simple/GHC/Internal.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/GHC/Internal.hs @@ -0,0 +1,492 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC.Internal +-- Copyright : Isaac Jones 2003-2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains functions shared by GHC (Distribution.Simple.GHC) +-- and GHC-derived compilers. + +module Distribution.Simple.GHC.Internal ( + configureToolchain, + getLanguages, + getExtensions, + targetPlatform, + getGhcInfo, + componentCcGhcOptions, + componentGhcOptions, + mkGHCiLibName, + filterGhciFlags, + ghcLookupProperty, + getHaskellObjects, + mkGhcOptPackages, + substTopDir, + checkPackageDbEnvVar + ) where + +import Distribution.Simple.GHC.ImplInfo ( GhcImplInfo (..) ) +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.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.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 System.Directory ( getDirectoryContents, getTemporaryDirectory ) +import System.Environment ( getEnv ) +import System.FilePath ( (), (<.>), takeExtension, takeDirectory ) +import System.IO ( hClose, hPutStrLn ) + +targetPlatform :: [(String, String)] -> Maybe Platform +targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo + +-- | Adjust the way we find and configure gcc and ld +-- +configureToolchain :: GhcImplInfo + -> ConfiguredProgram + -> M.Map String String + -> ProgramConfiguration + -> ProgramConfiguration +configureToolchain implInfo ghcProg ghcInfo = + addKnownProgram gccProgram { + programFindLocation = findProg gccProgram extraGccPath, + programPostConf = configureGcc + } + . addKnownProgram ldProgram { + programFindLocation = findProg ldProgram extraLdPath, + programPostConf = configureLd + } + . addKnownProgram arProgram { + programFindLocation = findProg arProgram extraArPath + } + . addKnownProgram stripProgram { + programFindLocation = findProg stripProgram extraStripPath + } + where + compilerDir = takeDirectory (programPath ghcProg) + baseDir = takeDirectory compilerDir + mingwBinDir = baseDir "mingw" "bin" + libDir = baseDir "gcc-lib" + includeDir = baseDir "include" "mingw" + isWindows = case buildOS of Windows -> True; _ -> False + binPrefix = "" + + mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath] + mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath] + | otherwise = mbDir + where + mbDir = maybeToList . fmap takeDirectory $ mbPath + + extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir + extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir + extraArPath = mkExtraPath mbArLocation windowsExtraArDir + extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir + + -- on Windows finding and configuring ghc's gcc & binutils is a bit special + (windowsExtraGccDir, windowsExtraLdDir, + windowsExtraArDir, windowsExtraStripDir) + | separateGccMingw implInfo = (baseDir, libDir, libDir, libDir) + | otherwise = -- GHC >= 6.12 + 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' + where + searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath + + -- Read tool locations from the 'ghc --info' output. Useful when + -- cross-compiling. + mbGccLocation = M.lookup "C compiler command" ghcInfo + mbLdLocation = M.lookup "ld command" ghcInfo + mbArLocation = M.lookup "ar command" ghcInfo + mbStripLocation = M.lookup "strip command" ghcInfo + + ccFlags = getFlags "C compiler flags" + 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 + + configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureGcc v gccProg = do + gccProg' <- configureGcc' v gccProg + return gccProg' { + programDefaultArgs = programDefaultArgs gccProg' + ++ ccFlags ++ gccLinkerFlags + } + + configureGcc' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureGcc' + | isWindows = \_ gccProg -> case programLocation gccProg of + -- if it's found on system then it means we're using the result + -- of programFindLocation above rather than a user-supplied path + -- Pre GHC 6.12, that meant we should add these flags to tell + -- ghc's gcc where it lives and thus where gcc can find its + -- various files: + FoundOnSystem {} + | separateGccMingw implInfo -> + return gccProg { programDefaultArgs = ["-B" ++ libDir, + "-I" ++ includeDir] } + _ -> return gccProg + | otherwise = \_ gccProg -> return gccProg + + configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd v ldProg = do + ldProg' <- configureLd' v ldProg + return ldProg' { + programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags + } + + -- we need to find out if ld supports the -x flag + configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd' verbosity ldProg = do + tempDir <- getTemporaryDirectory + ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> + withTempFile tempDir ".o" $ \testofile testohnd -> do + hPutStrLn testchnd "int foo() { return 0; }" + hClose testchnd; hClose testohnd + rawSystemProgram verbosity ghcProg ["-c", testcfile, + "-o", testofile] + withTempFile tempDir ".o" $ \testofile' testohnd' -> + do + hClose testohnd' + _ <- rawSystemProgramStdout verbosity ldProg + ["-x", "-r", testofile, "-o", testofile'] + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + if ldx + then return ldProg { programDefaultArgs = ["-x"] } + else return ldProg + +getLanguages :: Verbosity -> GhcImplInfo -> ConfiguredProgram + -> IO [(Language, String)] +getLanguages _ implInfo _ + -- TODO: should be using --supported-languages rather than hard coding + | supportsHaskell2010 implInfo = return [(Haskell98, "-XHaskell98") + ,(Haskell2010, "-XHaskell2010")] + | otherwise = return [(Haskell98, "")] + +getGhcInfo :: Verbosity -> GhcImplInfo -> ConfiguredProgram + -> IO [(String, String)] +getGhcInfo verbosity implInfo ghcProg + | flagInfoLanguages implInfo = do + xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg) + ["--info"] + case reads xs of + [(i, ss)] + | all isSpace ss -> + return i + _ -> + die "Can't parse --info output of GHC" + | otherwise = + return [] + +getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram + -> IO [(Extension, String)] +getExtensions verbosity implInfo ghcProg + | flagInfoLanguages implInfo = do + str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg) + ["--supported-languages"] + let extStrs = if reportsNoExt implInfo + then lines str + else -- Older GHCs only gave us either Foo or NoFoo, + -- so we have to work out the other one ourselves + [ extStr'' + | extStr <- lines str + , let extStr' = case extStr of + 'N' : 'o' : xs -> xs + _ -> "No" ++ extStr + , extStr'' <- [extStr, extStr'] + ] + let extensions0 = [ (ext, "-X" ++ display ext) + | Just ext <- map simpleParse extStrs ] + extensions1 = if fakeRecordPuns implInfo + then -- ghc-6.8 introduced RecordPuns however it + -- should have been NamedFieldPuns. We now + -- encourage packages to use NamedFieldPuns + -- so for compatibility we fake support for + -- it in ghc-6.8 by making it an alias for + -- the old RecordPuns extension. + (EnableExtension NamedFieldPuns, "-XRecordPuns") : + (DisableExtension NamedFieldPuns, "-XNoRecordPuns") : + extensions0 + else extensions0 + extensions2 = if alwaysNondecIndent implInfo + then -- ghc-7.2 split NondecreasingIndentation off + -- into a proper extension. Before that it + -- was always on. + (EnableExtension NondecreasingIndentation, "") : + (DisableExtension NondecreasingIndentation, "") : + extensions1 + else extensions1 + return extensions2 + + | otherwise = return oldLanguageExtensions + +-- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags +oldLanguageExtensions :: [(Extension, String)] +oldLanguageExtensions = + let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), + (DisableExtension f, disable)] + fglasgowExts = ("-fglasgow-exts", + "") -- This is wrong, but we don't want to turn + -- all the extensions off when asked to just + -- turn one off + fFlag flag = ("-f" ++ flag, "-fno-" ++ flag) + in concatMap doFlag + [(OverlappingInstances , fFlag "allow-overlapping-instances") + ,(TypeSynonymInstances , fglasgowExts) + ,(TemplateHaskell , fFlag "th") + ,(ForeignFunctionInterface , fFlag "ffi") + ,(MonomorphismRestriction , fFlag "monomorphism-restriction") + ,(MonoPatBinds , fFlag "mono-pat-binds") + ,(UndecidableInstances , fFlag "allow-undecidable-instances") + ,(IncoherentInstances , fFlag "allow-incoherent-instances") + ,(Arrows , fFlag "arrows") + ,(Generics , fFlag "generics") + ,(ImplicitPrelude , fFlag "implicit-prelude") + ,(ImplicitParams , fFlag "implicit-params") + ,(CPP , ("-cpp", ""{- Wrong -})) + ,(BangPatterns , fFlag "bang-patterns") + ,(KindSignatures , fglasgowExts) + ,(RecursiveDo , fglasgowExts) + ,(ParallelListComp , fglasgowExts) + ,(MultiParamTypeClasses , fglasgowExts) + ,(FunctionalDependencies , fglasgowExts) + ,(Rank2Types , fglasgowExts) + ,(RankNTypes , fglasgowExts) + ,(PolymorphicComponents , fglasgowExts) + ,(ExistentialQuantification , fglasgowExts) + ,(ScopedTypeVariables , fFlag "scoped-type-variables") + ,(FlexibleContexts , fglasgowExts) + ,(FlexibleInstances , fglasgowExts) + ,(EmptyDataDecls , fglasgowExts) + ,(PatternGuards , fglasgowExts) + ,(GeneralizedNewtypeDeriving , fglasgowExts) + ,(MagicHash , fglasgowExts) + ,(UnicodeSyntax , fglasgowExts) + ,(PatternSignatures , fglasgowExts) + ,(UnliftedFFITypes , fglasgowExts) + ,(LiberalTypeSynonyms , fglasgowExts) + ,(TypeOperators , fglasgowExts) + ,(GADTs , fglasgowExts) + ,(RelaxedPolyRec , fglasgowExts) + ,(ExtendedDefaultRules , fFlag "extended-default-rules") + ,(UnboxedTuples , fglasgowExts) + ,(DeriveDataTypeable , fglasgowExts) + ,(ConstrainedClassMethods , fglasgowExts) + ] + +componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath + -> GhcOptions +componentCcGhcOptions verbosity implInfo lbi bi clbi pref filename = + mempty { + ghcOptVerbosity = toFlag verbosity, + ghcOptMode = toFlag GhcModeCompile, + ghcOptInputFiles = toNubListR [filename], + + ghcOptCppIncludePath = toNubListR $ [autogenModulesDir lbi, odir] + ++ PD.includeDirs bi, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptCcOptions = toNubListR $ + (case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"]) ++ + (case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"]) ++ + PD.ccOptions bi, + ghcOptObjDir = toFlag odir + } + where + odir | hasCcOdirBug implInfo = pref takeDirectory filename + | otherwise = pref + -- ghc 6.4.0 had a bug in -odir handling for C compilations. + +componentGhcOptions :: Verbosity -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo -> FilePath + -> GhcOptions +componentGhcOptions verbosity lbi bi clbi odir = + mempty { + ghcOptVerbosity = toFlag verbosity, + ghcOptHideAllPackages = toFlag True, + ghcOptCabal = toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptSplitObjs = toFlag (splitObjs lbi), + ghcOptSourcePathClear = toFlag True, + ghcOptSourcePath = toNubListR $ [odir] ++ (hsSourceDirs bi) + ++ [autogenModulesDir lbi], + ghcOptCppIncludePath = toNubListR $ [autogenModulesDir lbi, odir] + ++ PD.includeDirs bi, + ghcOptCppOptions = toNubListR $ cppOptions bi, + ghcOptCppIncludes = toNubListR $ + [autogenModulesDir lbi cppHeaderName], + ghcOptFfiIncludes = toNubListR $ PD.includes bi, + ghcOptObjDir = toFlag odir, + ghcOptHiDir = toFlag odir, + ghcOptStubDir = toFlag odir, + ghcOptOutputDir = toFlag odir, + ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), + ghcOptDebugInfo = toGhcDebugInfo (withDebugInfo lbi), + ghcOptExtra = toNubListR $ hcOptions GHC bi, + ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)), + -- Unsupported extensions have already been checked by configure + ghcOptExtensions = toNubListR $ usedExtensions bi, + ghcOptExtensionMap = M.fromList . compilerExtensions $ (compiler lbi) + } + where + toGhcOptimisation NoOptimisation = mempty --TODO perhaps override? + toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation + toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation + + -- GHC doesn't support debug info levels yet. + toGhcDebugInfo NoDebugInfo = mempty + toGhcDebugInfo MinimalDebugInfo = toFlag True + toGhcDebugInfo NormalDebugInfo = toFlag True + toGhcDebugInfo MaximalDebugInfo = toFlag True + +-- | Strip out flags that are not supported in ghci +filterGhciFlags :: [String] -> [String] +filterGhciFlags = filter supported + where + supported ('-':'O':_) = False + supported "-debug" = False + supported "-threaded" = False + supported "-ticky" = False + supported "-eventlog" = False + supported "-prof" = False + supported "-unreg" = False + supported _ = True + +mkGHCiLibName :: LibraryName -> String +mkGHCiLibName (LibraryName lib) = lib <.> "o" + +ghcLookupProperty :: String -> Compiler -> Bool +ghcLookupProperty prop comp = + case M.lookup prop (compilerProperties comp) of + Just "YES" -> True + _ -> False + +-- when using -split-objs, we need to search for object files in the +-- Module_split directory for each module. +getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo + -> FilePath -> String -> Bool -> IO [FilePath] +getHaskellObjects implInfo lib lbi pref wanted_obj_ext allow_split_objs + | splitObjs lbi && allow_split_objs = do + let splitSuffix = if noExtInSplitSuffix implInfo + then "_split" + else "_" ++ wanted_obj_ext ++ "_split" + dirs = [ pref (ModuleName.toFilePath x ++ splitSuffix) + | x <- libModules lib ] + objss <- mapM getDirectoryContents dirs + let objs = [ dir obj + | (objs',dir) <- zip objss dirs, obj <- objs', + let obj_ext = takeExtension obj, + '.':wanted_obj_ext == obj_ext ] + return objs + | otherwise = + return [ pref ModuleName.toFilePath x <.> wanted_obj_ext + | x <- libModules lib ] + +mkGhcOptPackages :: ComponentLocalBuildInfo + -> [(InstalledPackageId, PackageId, ModuleRenaming)] +mkGhcOptPackages clbi = + map (\(i,p) -> (i,p,lookupRenaming p (componentPackageRenaming clbi))) + (componentPackageDeps clbi) + +substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo +substTopDir topDir ipo + = ipo { + InstalledPackageInfo.importDirs + = map f (InstalledPackageInfo.importDirs ipo), + InstalledPackageInfo.libraryDirs + = map f (InstalledPackageInfo.libraryDirs ipo), + InstalledPackageInfo.includeDirs + = map f (InstalledPackageInfo.includeDirs ipo), + InstalledPackageInfo.frameworkDirs + = map f (InstalledPackageInfo.frameworkDirs ipo), + InstalledPackageInfo.haddockInterfaces + = map f (InstalledPackageInfo.haddockInterfaces ipo), + InstalledPackageInfo.haddockHTMLs + = map f (InstalledPackageInfo.haddockHTMLs ipo) + } + where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest + f x = x + +-- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let +-- users know that this is the case. See ticket #335. Simply ignoring it is +-- not a good idea, since then ghc and cabal are looking at different sets +-- of package DBs and chaos is likely to ensue. +-- +-- An exception to this is when running cabal from within a `cabal exec` +-- environment. In this case, `cabal exec` will set the +-- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set +-- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow +-- GHC{,JS}_PACKAGE_PATH. +checkPackageDbEnvVar :: String -> String -> IO () +checkPackageDbEnvVar compilerName packagePathEnvVar = do + mPP <- lookupEnv packagePathEnvVar + when (isJust mPP) $ do + mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH" + unless (mPP == mcsPP) abort + where + lookupEnv :: String -> IO (Maybe String) + 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)." diff --git a/Distribution/Simple/GHCJS.hs b/Distribution/Simple/GHCJS.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/GHCJS.hs @@ -0,0 +1,903 @@ +{-# LANGUAGE CPP #-} +module Distribution.Simple.GHCJS ( + configure, getInstalledPackages, getPackageDBContents, + buildLib, buildExe, + replLib, replExe, + startInterpreter, + installLib, installExe, + libAbiHash, + hcPkgInfo, + registerPackage, + componentGhcOptions, + getLibDir, + isDynamic, + getGlobalPackageDB, + runCmd + ) where + +import Distribution.Simple.GHC.ImplInfo ( getImplInfo, ghcjsVersionImplInfo ) +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.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 qualified Distribution.Simple.Setup as Cabal + ( Flag(..) ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), CompilerId(..), Compiler(..) + , PackageDB(..), PackageDBStack, AbiTag(..) ) +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 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 System.Directory ( doesFileExist ) +import System.FilePath ( (), (<.>), takeExtension, + takeDirectory, replaceExtension, + splitExtension ) + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration + -> IO (Compiler, Maybe Platform, ProgramConfiguration) +configure verbosity hcPath hcPkgPath conf0 = do + (ghcjsProg, ghcjsVersion, conf1) <- + requireProgramVersion verbosity ghcjsProgram + (orLaterVersion (Version [0,1] [])) + (userMaybeSpecifyPath "ghcjs" hcPath conf0) + Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg) + let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion + + -- This is slightly tricky, we have to configure ghcjs first, then we use the + -- location of ghcjs to help find ghcjs-pkg in the case that the user did not + -- specify the location of ghc-pkg directly: + (ghcjsPkgProg, ghcjsPkgVersion, conf2) <- + requireProgramVersion verbosity ghcjsPkgProgram { + programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg + } + anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath conf1) + + Just ghcjsPkgGhcVersion <- findGhcjsPkgGhcVersion + verbosity (programPath ghcjsPkgProg) + + when (ghcjsVersion /= ghcjsPkgVersion) $ die $ + "Version mismatch between ghcjs and ghcjs-pkg: " + ++ programPath ghcjsProg ++ " is version " ++ display ghcjsVersion ++ " " + ++ programPath ghcjsPkgProg ++ " is version " ++ display ghcjsPkgVersion + + when (ghcjsGhcVersion /= ghcjsPkgGhcVersion) $ die $ + "Version mismatch between ghcjs and ghcjs-pkg: " + ++ programPath ghcjsProg + ++ " was built with GHC version " ++ display ghcjsGhcVersion ++ " " + ++ programPath ghcjsPkgProg + ++ " was built with GHC version " ++ display ghcjsPkgGhcVersion + + -- be sure to use our versions of hsc2hs, c2hs, haddock and ghc + let hsc2hsProgram' = + hsc2hsProgram { programFindLocation = + guessHsc2hsFromGhcjsPath ghcjsProg } + c2hsProgram' = + c2hsProgram { programFindLocation = + guessC2hsFromGhcjsPath ghcjsProg } + + haddockProgram' = + haddockProgram { programFindLocation = + guessHaddockFromGhcjsPath ghcjsProg } + conf3 = addKnownPrograms [ hsc2hsProgram', c2hsProgram', haddockProgram' ] conf2 + + languages <- Internal.getLanguages verbosity implInfo ghcjsProg + extensions <- Internal.getExtensions verbosity implInfo ghcjsProg + + ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg + let ghcInfoMap = M.fromList ghcInfo + + let comp = Compiler { + compilerId = CompilerId GHCJS ghcjsVersion, + compilerAbiTag = AbiTag $ + "ghc" ++ intercalate "_" (map show . versionBranch $ ghcjsGhcVersion), + compilerCompat = [CompilerId GHC ghcjsGhcVersion], + compilerLanguages = languages, + compilerExtensions = extensions, + compilerProperties = ghcInfoMap + } + compPlatform = Internal.targetPlatform ghcInfo + -- configure gcc and ld + let conf4 = if ghcjsNativeToo comp + then Internal.configureToolchain implInfo + ghcjsProg ghcInfoMap conf3 + else conf3 + return (comp, compPlatform, conf4) + +ghcjsNativeToo :: Compiler -> Bool +ghcjsNativeToo = Internal.ghcLookupProperty "Native Too" + +guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity + -> ProgramSearchPath -> IO (Maybe FilePath) +guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram + +guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity + -> ProgramSearchPath -> IO (Maybe FilePath) +guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram + +guessC2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity + -> ProgramSearchPath -> IO (Maybe FilePath) +guessC2hsFromGhcjsPath = guessToolFromGhcjsPath c2hsProgram + +guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity + -> ProgramSearchPath -> IO (Maybe FilePath) +guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram + +guessToolFromGhcjsPath :: Program -> ConfiguredProgram + -> Verbosity -> ProgramSearchPath + -> IO (Maybe FilePath) +guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath + = do let toolname = programName tool + path = programPath ghcjsProg + dir = takeDirectory path + versionSuffix = takeVersionSuffix (dropExeExtension path) + guessNormal = dir toolname <.> exeExtension + guessGhcjsVersioned = dir (toolname ++ "-ghcjs" ++ versionSuffix) + <.> exeExtension + guessGhcjs = dir (toolname ++ "-ghcjs") + <.> exeExtension + guessVersioned = dir (toolname ++ versionSuffix) <.> exeExtension + guesses | null versionSuffix = [guessGhcjs, guessNormal] + | otherwise = [guessGhcjsVersioned, + guessGhcjs, + guessVersioned, + guessNormal] + info verbosity $ "looking for tool " ++ toolname + ++ " near compiler in " ++ dir + 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) + + 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 +getPackageDBContents verbosity packagedb conf = do + pkgss <- getInstalledPackages' verbosity [packagedb] conf + toPackageIndex verbosity pkgss conf + +-- | Given a package DB stack, return all installed packages. +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO InstalledPackageIndex +getInstalledPackages verbosity packagedbs conf = do + checkPackageDbEnvVar + checkPackageDbStack packagedbs + pkgss <- getInstalledPackages' verbosity packagedbs conf + index <- toPackageIndex verbosity pkgss conf + return $! index + +toPackageIndex :: Verbosity + -> [(PackageDB, [InstalledPackageInfo])] + -> ProgramConfiguration + -> IO InstalledPackageIndex +toPackageIndex verbosity pkgss conf = do + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it. + topDir <- getLibDir' verbosity ghcjsProg + let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss ] + return $! (mconcat indices) + + where + Just ghcjsProg = lookupProgram ghcjsProgram conf + +checkPackageDbEnvVar :: IO () +checkPackageDbEnvVar = + Internal.checkPackageDbEnvVar "GHCJS" "GHCJS_PACKAGE_PATH" + +checkPackageDbStack :: PackageDBStack -> IO () +checkPackageDbStack (GlobalPackageDB:rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStack rest + | GlobalPackageDB `notElem` rest = + die $ "With current ghc versions the global package db is always used " + ++ "and must be listed first. This ghc limitation may be lifted in " + ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977" +checkPackageDbStack _ = + die $ "If the global package db is specified, it must be " + ++ "specified first and cannot be specified multiple times" + +getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration + -> IO [(PackageDB, [InstalledPackageInfo])] +getInstalledPackages' verbosity packagedbs conf = + sequence + [ do pkgs <- HcPkg.dump (hcPkgInfo conf) verbosity packagedb + return (packagedb, pkgs) + | packagedb <- packagedbs ] + +getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath +getLibDir verbosity lbi = + (reverse . dropWhile isSpace . reverse) `fmap` + rawSystemProgramStdoutConf verbosity ghcjsProgram + (withPrograms lbi) ["--print-libdir"] + +getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath +getLibDir' verbosity ghcjsProg = + (reverse . dropWhile isSpace . reverse) `fmap` + rawSystemProgramStdout verbosity ghcjsProg ["--print-libdir"] + +-- | Return the 'FilePath' to the global GHC package database. +getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath +getGlobalPackageDB verbosity ghcjsProg = + (reverse . dropWhile isSpace . reverse) `fmap` + rawSystemProgramStdout verbosity ghcjsProg ["--print-global-package-db"] + +toJSLibName :: String -> String +toJSLibName lib + | takeExtension lib `elem` [".dll",".dylib",".so"] + = replaceExtension lib "js_so" + | takeExtension lib == ".a" = replaceExtension lib "js_a" + | otherwise = lib <.> "js_a" + +buildLib, replLib :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription + -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo + -> IO () +buildLib = buildOrReplLib False +replLib = buildOrReplLib True + +buildOrReplLib :: Bool -> Verbosity -> Cabal.Flag (Maybe Int) + -> 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 + whenVanillaLib forceVanilla = + when (not forRepl && (forceVanilla || withVanillaLib lbi)) + whenProfLib = when (not forRepl && withProfLib lbi) + whenSharedLib forceShared = + when (not forRepl && (forceShared || withSharedLib lbi)) + whenGHCiLib = when (not forRepl && withGHCiLib lbi && withVanillaLib lbi) + ifReplLib = when forRepl + comp = compiler lbi + implInfo = getImplInfo comp + hole_insts = map (\(k,(p,n)) -> (k,(InstalledPackageInfo.packageKey p,n))) + (instantiatedWith lbi) + nativeToo = ghcjsNativeToo comp + + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) + let runGhcjsProg = runGHC verbosity ghcjsProg comp + libBi = libBuildInfo lib + isGhcjsDynamic = isDynamic comp + dynamicTooSupported = supportsDynamicToo comp + doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi + forceVanillaLib = doingTH && not isGhcjsDynamic + forceSharedLib = doingTH && isGhcjsDynamic + -- TH always needs default libs, even when building for profiling + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi + -- Component name. Not 'libName' because that has the "HS" prefix + -- that GHC gives Haskell libraries. + cname = display $ PD.package $ localPkgDescr lbi + distPref = fromFlag $ configDistPref $ configFlags lbi + hpcdir way + | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname + | otherwise = mempty + + createDirectoryIfMissingVerbose verbosity True libTargetDir + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? + let cObjs = map (`replaceExtension` objExtension) (cSources libBi) + jsSrcs = jsSources libBi + baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir + linkJsLibOpts = mempty { + ghcOptExtra = toNubListR $ + [ "-link-js-lib" , (\(LibraryName l) -> l) 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 + } + vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts + + profOpts = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptExtra = toNubListR $ + ghcjsProfOptions libBi, + ghcOptHPCDir = hpcdir Hpc.Prof + } + sharedOpts = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptFPic = toFlag True, + ghcOptExtra = toNubListR $ + ghcjsSharedOptions libBi, + ghcOptHPCDir = hpcdir Hpc.Dyn + } + linkerOpts = mempty { + ghcOptLinkOptions = toNubListR $ PD.ldOptions libBi, + ghcOptLinkLibs = toNubListR $ extraLibs libBi, + ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, + ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, + ghcOptInputFiles = + toNubListR $ [libTargetDir x | x <- cObjs] ++ jsSrcs + } + replOpts = vanillaOptsNoJsLib { + ghcOptExtra = overNubListR + Internal.filterGhciFlags + (ghcOptExtra vanillaOpts), + ghcOptNumJobs = mempty + } + `mappend` linkerOpts + `mappend` mempty { + ghcOptMode = toFlag GhcModeInteractive, + ghcOptOptimisation = toFlag GhcNoOptimisation + } + + vanillaSharedOpts = vanillaOpts `mappend` + mempty { + ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, + ghcOptDynHiSuffix = toFlag "dyn_hi", + ghcOptDynObjSuffix = toFlag "dyn_o", + ghcOptHPCDir = hpcdir Hpc.Dyn + } + + unless (forRepl || (null (libModules lib) && null jsSrcs && null cObjs)) $ + do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts) + shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts) + useDynToo = dynamicTooSupported && + (forceVanillaLib || withVanillaLib lbi) && + (forceSharedLib || withSharedLib lbi) && + null (ghcjsSharedOptions libBi) + if useDynToo + then do + runGhcjsProg vanillaSharedOpts + case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of + (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> do + -- 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 + -- static and dynamically linked executables. We copy + -- the modules interfaces so they are available under + -- both ways. + copyDirectoryRecursive verbosity dynDir vanillaDir + _ -> return () + else if isGhcjsDynamic + then do shared; vanilla + else do vanilla; shared + whenProfLib (runGhcjsProg profOpts) + + -- build any C sources + unless (null (cSources libBi) || not nativeToo) $ do + info verbosity "Building C Sources..." + sequence_ + [ do let vanillaCcOpts = + (Internal.componentCcGhcOptions verbosity implInfo + lbi libBi clbi libTargetDir filename) + profCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCcOpts) + createDirectoryIfMissingVerbose verbosity True odir + runGhcjsProg vanillaCcOpts + whenSharedLib forceSharedLib (runGhcjsProg sharedCcOpts) + whenProfLib (runGhcjsProg profCcOpts) + | filename <- cSources libBi] + + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + unless (null (libModules lib)) $ + ifReplLib (runGhcjsProg replOpts) + + -- link: + when (nativeToo && not forRepl) $ do + info verbosity "Linking..." + let cProfObjs = map (`replaceExtension` ("p_" ++ objExtension)) + (cSources libBi) + cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) + (cSources libBi) + cid = compilerId (compiler lbi) + vanillaLibFilePath = libTargetDir mkLibName libName + profileLibFilePath = libTargetDir mkProfLibName libName + sharedLibFilePath = libTargetDir mkSharedLibName cid libName + ghciLibFilePath = libTargetDir Internal.mkGHCiLibName libName + + hObjs <- Internal.getHaskellObjects implInfo lib lbi + libTargetDir objExtension True + hProfObjs <- + if (withProfLib lbi) + then Internal.getHaskellObjects implInfo lib lbi + libTargetDir ("p_" ++ objExtension) True + else return [] + hSharedObjs <- + if (withSharedLib lbi) + then Internal.getHaskellObjects implInfo lib lbi + libTargetDir ("dyn_" ++ objExtension) False + else return [] + + unless (null hObjs && null cObjs) $ do + + let staticObjectFiles = + hObjs + ++ map (libTargetDir ) cObjs + profObjectFiles = + hProfObjs + ++ map (libTargetDir ) cProfObjs + ghciObjFiles = + hObjs + ++ map (libTargetDir ) cObjs + dynamicObjectFiles = + hSharedObjs + ++ map (libTargetDir ) cSharedObjs + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs = + mempty { + ghcOptShared = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptInputFiles = toNubListR dynamicObjectFiles, + ghcOptOutputFile = toFlag sharedLibFilePath, + ghcOptPackageKey = toFlag (pkgKey lbi), + ghcOptNoAutoLinkPackages = toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptPackages = toNubListR $ + Internal.mkGhcOptPackages clbi, + ghcOptLinkLibs = toNubListR $ extraLibs libBi, + ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi + } + + whenVanillaLib False $ do + Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles + + whenProfLib $ do + Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles + + whenGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity ldProg + ghciLibFilePath ghciObjFiles + + whenSharedLib False $ + runGhcjsProg ghcSharedLinkArgs + +-- | Start a REPL without loading any source files. +startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler + -> PackageDBStack -> IO () +startInterpreter verbosity conf comp packageDBs = do + let replOpts = mempty { + ghcOptMode = toFlag GhcModeInteractive, + ghcOptPackageDBs = packageDBs + } + checkPackageDbStack packageDBs + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram conf + runGHC verbosity ghcjsProg comp replOpts + +buildExe, replExe :: Verbosity -> Cabal.Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe = buildOrReplExe False +replExe = buildOrReplExe True + +buildOrReplExe :: Bool -> Verbosity -> Cabal.Flag (Maybe Int) + -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi + exe@Executable { exeName = exeName', modulePath = modPath } clbi = do + + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) + let comp = compiler lbi + implInfo = getImplInfo comp + runGhcjsProg = runGHC verbosity ghcjsProg comp + exeBi = buildInfo exe + + -- exeNameReal, the name that GHC really uses (with .exe on Windows) + let exeNameReal = exeName' <.> + (if takeExtension exeName' /= ('.':exeExtension) + then exeExtension + else "") + + let targetDir = (buildDir lbi) exeName' + let exeDir = targetDir (exeName' ++ "-tmp") + createDirectoryIfMissingVerbose verbosity True targetDir + createDirectoryIfMissingVerbose verbosity True exeDir + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? FIX: what about exeName.hi-boot? + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi + distPref = fromFlag $ configDistPref $ configFlags lbi + hpcdir way + | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName' + | otherwise = mempty + + -- build executables + + srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath + let isGhcjsDynamic = isDynamic comp + dynamicTooSupported = supportsDynamicToo comp + buildRunner = case clbi of + ExeComponentLocalBuildInfo {} -> False + _ -> True + isHaskellMain = elem (takeExtension srcMainFile) [".hs", ".lhs"] + jsSrcs = jsSources exeBi + cSrcs = cSources exeBi ++ [srcMainFile | not isHaskellMain] + cObjs = map (`replaceExtension` objExtension) cSrcs + nativeToo = ghcjsNativeToo comp + baseOpts = (componentGhcOptions verbosity lbi exeBi clbi exeDir) + `mappend` mempty { + ghcOptMode = toFlag GhcModeMake, + ghcOptInputFiles = toNubListR $ + [ srcMainFile | isHaskellMain], + ghcOptInputModules = toNubListR $ + [ m | not isHaskellMain, m <- exeModules exe], + ghcOptExtra = + if buildRunner then toNubListR ["-build-runner"] + else mempty + } + staticOpts = baseOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcStaticOnly, + ghcOptHPCDir = hpcdir Hpc.Vanilla + } + profOpts = adjustExts "p_hi" "p_o" baseOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptExtra = toNubListR $ ghcjsProfOptions exeBi, + ghcOptHPCDir = hpcdir Hpc.Prof + } + dynOpts = adjustExts "dyn_hi" "dyn_o" baseOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptExtra = toNubListR $ + ghcjsSharedOptions exeBi, + ghcOptHPCDir = hpcdir Hpc.Dyn + } + dynTooOpts = adjustExts "dyn_hi" "dyn_o" staticOpts `mappend` mempty { + ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, + ghcOptHPCDir = hpcdir Hpc.Dyn + } + linkerOpts = mempty { + ghcOptLinkOptions = toNubListR $ PD.ldOptions exeBi, + ghcOptLinkLibs = toNubListR $ extraLibs exeBi, + ghcOptLinkLibPath = toNubListR $ extraLibDirs exeBi, + ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi, + ghcOptInputFiles = toNubListR $ + [exeDir x | x <- cObjs] ++ jsSrcs + } + replOpts = baseOpts { + ghcOptExtra = overNubListR + Internal.filterGhciFlags + (ghcOptExtra baseOpts) + } + -- For a normal compile we do separate invocations of ghc for + -- compiling as for linking. But for repl we have to do just + -- the one invocation, so that one has to include all the + -- linker stuff too, like -l flags and any .o files from C + -- files etc. + `mappend` linkerOpts + `mappend` mempty { + ghcOptMode = toFlag GhcModeInteractive, + ghcOptOptimisation = toFlag GhcNoOptimisation + } + commonOpts | withProfExe lbi = profOpts + | withDynExe lbi = dynOpts + | otherwise = staticOpts + compileOpts | useDynToo = dynTooOpts + | otherwise = commonOpts + withStaticExe = (not $ withProfExe lbi) && (not $ withDynExe lbi) + + -- For building exe's that use TH with -prof or -dynamic we actually have + -- to build twice, once without -prof/-dynamic and then again with + -- -prof/-dynamic. This is because the code that TH needs to run at + -- compile time needs to be the vanilla ABI so it can be loaded up and run + -- by the compiler. + -- With dynamic-by-default GHC the TH object files loaded at compile-time + -- need to be .dyn_o instead of .o. + doingTH = EnableExtension TemplateHaskell `elem` allExtensions exeBi + -- Should we use -dynamic-too instead of compiling twice? + useDynToo = dynamicTooSupported && isGhcjsDynamic + && doingTH && withStaticExe && null (ghcjsSharedOptions exeBi) + compileTHOpts | isGhcjsDynamic = dynOpts + | otherwise = staticOpts + compileForTH + | forRepl = False + | useDynToo = False + | isGhcjsDynamic = doingTH && (withProfExe lbi || withStaticExe) + | otherwise = doingTH && (withProfExe lbi || withDynExe lbi) + + linkOpts = commonOpts `mappend` + linkerOpts `mappend` mempty { + ghcOptLinkNoHsMain = toFlag (not isHaskellMain) + } + + -- Build static/dynamic object files for TH, if needed. + when compileForTH $ + runGhcjsProg compileTHOpts { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs } + + unless forRepl $ + runGhcjsProg compileOpts { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs } + + -- build any C sources + unless (null cSrcs || not nativeToo) $ do + info verbosity "Building C Sources..." + sequence_ + [ do let opts = (Internal.componentCcGhcOptions verbosity implInfo lbi exeBi + clbi exeDir filename) `mappend` mempty { + ghcOptDynLinkMode = toFlag (if withDynExe lbi + then GhcDynamicOnly + else GhcStaticOnly), + ghcOptProfilingMode = toFlag (withProfExe lbi) + } + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True odir + runGhcjsProg opts + | filename <- cSrcs ] + + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + when forRepl $ runGhcjsProg replOpts + + -- link: + unless forRepl $ do + info verbosity "Linking..." + runGhcjsProg linkOpts { ghcOptOutputFile = toFlag (targetDir exeNameReal) } + +-- |Install for ghc, .hi, .a and, if --with-ghci given, .o +installLib :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^install location + -> FilePath -- ^install location for dynamic libraries + -> FilePath -- ^Build location + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do + whenVanilla $ copyModuleFiles "js_hi" + 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 + + when (ghcjsNativeToo $ compiler lbi) $ do + -- copy .hi files over: + whenVanilla $ copyModuleFiles "hi" + whenProf $ copyModuleFiles "p_hi" + 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 + + 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 + else installOrdinaryFile verbosity src dst + + installOrdinary = install False + installShared = install True + + 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 + + hasLib = not $ null (libModules lib) + && null (cSources (libBuildInfo lib)) + whenVanilla = when (hasLib && withVanillaLib lbi) + whenProf = when (hasLib && withProfLib lbi) + whenGHCi = when (hasLib && withGHCiLib lbi) + whenShared = when (hasLib && withSharedLib lbi) + +installExe :: Verbosity + -> LocalBuildInfo + -> InstallDirs FilePath -- ^Where to copy the files to + -> FilePath -- ^Build location + -> (FilePath, FilePath) -- ^Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe verbosity lbi installDirs buildPref + (progprefix, progsuffix) _pkg exe = do + let binDir = bindir installDirs + createDirectoryIfMissingVerbose verbosity True binDir + let exeFileName = exeName exe + fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix + installBinary dest = do + rawSystemProgramConf verbosity ghcjsProgram (withPrograms lbi) $ + [ "--install-executable" + , buildPref exeName exe exeFileName + , "-o", dest + ] ++ + case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of + (True, Just strip) -> ["-strip-program", programPath strip] + _ -> [] + installBinary (binDir fixedExeBaseName) + +libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO String +libAbiHash verbosity _pkg_descr lbi lib clbi = do + let + libBi = libBuildInfo lib + comp = compiler lbi + vanillaArgs = + (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi)) + `mappend` mempty { + ghcOptMode = toFlag GhcModeAbiHash, + ghcOptPackageKey = toFlag (pkgKey lbi), + ghcOptInputModules = toNubListR $ exposedModules lib + } + profArgs = adjustExts "js_p_hi" "js_p_o" vanillaArgs `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptExtra = toNubListR (ghcjsProfOptions libBi) + } + ghcArgs = if withVanillaLib lbi then vanillaArgs + else if withProfLib lbi then profArgs + else error "libAbiHash: Can't find an enabled library way" + -- + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) + getProgramInvocationOutput verbosity (ghcInvocation ghcjsProg comp ghcArgs) + +adjustExts :: String -> String -> GhcOptions -> GhcOptions +adjustExts hiSuf objSuf opts = + opts `mappend` mempty { + ghcOptHiSuffix = toFlag hiSuf, + ghcOptObjSuffix = toFlag objSuf + } + +registerPackage :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = + HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity packageDbs + (Right installedPkgInfo) + +componentGhcOptions :: Verbosity -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo -> FilePath + -> GhcOptions +componentGhcOptions verbosity lbi bi clbi odir = + let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir + in opts { ghcOptExtra = ghcOptExtra opts `mappend` toNubListR + (hcOptions GHCJS bi) + } + +ghcjsProfOptions :: BuildInfo -> [String] +ghcjsProfOptions bi = + hcProfOptions GHC bi `mappend` hcProfOptions GHCJS bi + +ghcjsSharedOptions :: BuildInfo -> [String] +ghcjsSharedOptions bi = + hcSharedOptions GHC bi `mappend` hcSharedOptions GHCJS bi + +isDynamic :: Compiler -> Bool +isDynamic = Internal.ghcLookupProperty "GHC Dynamic" + +supportsDynamicToo :: Compiler -> Bool +supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" + +findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version) +findGhcjsGhcVersion verbosity pgm = + findProgramVersion "--numeric-ghc-version" id verbosity pgm + +findGhcjsPkgGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version) +findGhcjsPkgGhcVersion verbosity pgm = + findProgramVersion "--numeric-ghc-version" id verbosity pgm + +-- ----------------------------------------------------------------------------- +-- Registering + +hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo +hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcjsPkgProg + , HcPkg.noPkgDbStack = False + , HcPkg.noVerboseFlag = False + , HcPkg.flagPackageConf = False + , HcPkg.useSingleFileDb = v < [7,9] + } + where + v = versionBranch ver + Just ghcjsPkgProg = lookupProgram ghcjsPkgProgram conf + Just ver = programVersion ghcjsPkgProg + +-- | Get the JavaScript file name and command and arguments to run a +-- program compiled by GHCJS +-- the exe should be the base program name without exe extension +runCmd :: ProgramConfiguration -> FilePath + -> (FilePath, FilePath, [String]) +runCmd conf exe = + ( script + , programPath ghcjsProg + , programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"] + ) + where + script = exe <.> "jsexe" "all" <.> "js" + Just ghcjsProg = lookupProgram ghcjsProgram conf diff --git a/Distribution/Simple/Haddock.hs b/Distribution/Simple/Haddock.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Haddock.hs @@ -0,0 +1,791 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Haddock +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module deals with the @haddock@ and @hscolour@ commands. +-- It uses information about installed packages (from @ghc-pkg@) to find the +-- locations of documentation for dependent packages, so it can create links. +-- +-- The @hscolour@ support allows generating HTML versions of the original +-- source, with coloured syntax highlighting. + +module Distribution.Simple.Haddock ( + haddock, hscolour, + + haddockPackagePaths + ) where + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS + +-- local +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.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.InstallDirs + ( InstallDirs(..) + , PathTemplateEnv, PathTemplate, PathTemplateVariable(..) + , toPathTemplate, fromPathTemplate + , substPathTemplate, initialPathTemplateEnv ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..) + , withAllComponentsInBuildOrder ) +import Distribution.Simple.BuildPaths + ( haddockName, hscolourPref, autogenModulesDir) +import Distribution.Simple.PackageIndex (dependencyClosure) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo_(..) ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.Simple.Utils + ( die, copyFileTo, warn, notice, intercalate, setupMessage + , createDirectoryIfMissingVerbose + , TempFileOptions(..), defaultTempFileOptions + , withTempFileEx, copyFileVerbose + , withTempDirectoryEx, matchFileGlob + , findFileWithExtension, findFile ) +import Distribution.Text + ( display, simpleParse ) +import Distribution.Utils.NubList + ( toNubListR ) + +import Distribution.Verbosity +import Language.Haskell.Extension + + +import Control.Monad ( when, forM_ ) +import Data.Either ( rights ) +import Data.Monoid +import Data.Maybe ( fromMaybe, listToMaybe ) + +import System.Directory (doesFileExist) +import System.FilePath ( (), (<.>) + , normalise, splitPath, joinPath, isAbsolute ) +import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) +import Distribution.Version + +-- ------------------------------------------------------------------------------ +-- Types + +-- | A record that represents the arguments to the haddock executable, a product +-- monoid. +data HaddockArgs = HaddockArgs { + argInterfaceFile :: Flag FilePath, + -- ^ Path to the interface file, relative to argOutputDir, required. + argPackageName :: Flag PackageIdentifier, + -- ^ Package name, required. + argHideModules :: (All,[ModuleName.ModuleName]), + -- ^ (Hide modules ?, modules to hide) + argIgnoreExports :: Any, + -- ^ Ignore export lists in modules? + argLinkSource :: Flag (Template,Template,Template), + -- ^ (Template for modules, template for symbols, template for lines). + argCssFile :: Flag FilePath, + -- ^ Optional custom CSS file. + argContents :: Flag String, + -- ^ Optional URL to contents page. + argVerbose :: Any, + argOutput :: Flag [Output], + -- ^ HTML or Hoogle doc or both? Required. + argInterfaces :: [(FilePath, Maybe String)], + -- ^ [(Interface file, URL to the HTML docs for links)]. + argOutputDir :: Directory, + -- ^ Where to generate the documentation. + argTitle :: Flag String, + -- ^ Page title, required. + argPrologue :: Flag String, + -- ^ Prologue text, required. + argGhcOptions :: Flag (GhcOptions, Version), + -- ^ Additional flags to pass to GHC. + argGhcLibDir :: Flag FilePath, + -- ^ To find the correct GHC, required. + argTargets :: [FilePath] + -- ^ Modules to process. +} + +-- | The FilePath of a directory, it's a monoid under '()'. +newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord) + +unDir :: Directory -> FilePath +unDir = joinPath . filter (\p -> p /="./" && p /= ".") . splitPath . unDir' + +type Template = String + +data Output = Html | Hoogle + +-- ------------------------------------------------------------------------------ +-- Haddock support + +haddock :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HaddockFlags + -> IO () +haddock pkg_descr _ _ haddockFlags + | not (hasLibs pkg_descr) + && not (fromFlag $ haddockExecutables haddockFlags) + && not (fromFlag $ haddockTestSuites haddockFlags) + && not (fromFlag $ haddockBenchmarks haddockFlags) = + warn (fromFlag $ haddockVerbosity haddockFlags) $ + "No documentation was generated as this package does not contain " + ++ "a library. Perhaps you want to use the --executables, --tests or" + ++ " --benchmarks flags." + +haddock pkg_descr lbi suffixes flags = do + setupMessage verbosity "Running Haddock for" (packageId pkg_descr) + (confHaddock, version, _) <- + requireProgramVersion verbosity haddockProgram + (orLaterVersion (Version [2,0] [])) (withPrograms lbi) + + -- various sanity checks + when ( flag haddockHoogle + && version < Version [2,2] []) $ + die "haddock 2.0 and 2.1 do not support the --hoogle flag." + + haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock + ["--ghc-version"] + case (simpleParse haddockGhcVersionStr, compilerCompatVersion GHC comp) of + (Nothing, _) -> die "Could not get GHC version from Haddock" + (_, Nothing) -> die "Could not get GHC version from compiler" + (Just haddockGhcVersion, Just ghcVersion) + | haddockGhcVersion == ghcVersion -> return () + | otherwise -> die $ + "Haddock's internal GHC version must match the configured " + ++ "GHC version.\n" + ++ "The GHC version is " ++ display ghcVersion ++ " but " + ++ "haddock is using GHC version " ++ display haddockGhcVersion + + -- the tools match the requests, we can proceed + + initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity + + when (flag haddockHscolour) $ + hscolour' (warn verbosity) pkg_descr lbi suffixes + (defaultHscolourFlags `mappend` haddockToHscolour flags) + + libdirArgs <- getGhcLibDir verbosity lbi + let commonArgs = mconcat + [ libdirArgs + , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags + , fromPackageDescription pkg_descr ] + + let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes + withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do + pre component + let + doExe com = case (compToExe com) of + Just exe -> do + withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ + \tmp -> do + exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate + version + let exeArgs' = commonArgs `mappend` exeArgs + runHaddock verbosity tmpFileOpts comp confHaddock exeArgs' + Nothing -> do + warn (fromFlag $ haddockVerbosity flags) + "Unsupported component, skipping..." + return () + case component of + CLib lib -> do + withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ + \tmp -> do + libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate + version + let libArgs' = commonArgs `mappend` libArgs + runHaddock verbosity tmpFileOpts comp confHaddock libArgs' + CExe _ -> when (flag haddockExecutables) $ doExe component + CTest _ -> when (flag haddockTestSuites) $ doExe component + CBench _ -> when (flag haddockBenchmarks) $ doExe component + + 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. + +fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs +fromFlags env flags = + mempty { + argHideModules = (maybe mempty (All . not) + $ flagToMaybe (haddockInternal flags), mempty), + argLinkSource = if fromFlag (haddockHscolour flags) + then Flag ("src/%{MODULE/./-}.html" + ,"src/%{MODULE/./-}.html#%{NAME}" + ,"src/%{MODULE/./-}.html#line-%{LINE}") + else NoFlag, + argCssFile = haddockCss flags, + argContents = fmap (fromPathTemplate . substPathTemplate env) + (haddockContents flags), + argVerbose = maybe mempty (Any . (>= deafening)) + . flagToMaybe $ haddockVerbosity flags, + argOutput = + Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++ + [ Hoogle | Flag True <- [haddockHoogle flags] ] + of [] -> [ Html ] + os -> os, + argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags + } + +fromPackageDescription :: PackageDescription -> HaddockArgs +fromPackageDescription pkg_descr = + mempty { argInterfaceFile = Flag $ haddockName pkg_descr, + argPackageName = Flag $ packageId $ pkg_descr, + argOutputDir = Dir $ "doc" "html" + display (packageName pkg_descr), + argPrologue = Flag $ if null desc then synopsis pkg_descr + else desc, + argTitle = Flag $ showPkg ++ subtitle + } + where + desc = PD.description pkg_descr + showPkg = display (packageId pkg_descr) + subtitle | null (synopsis pkg_descr) = "" + | otherwise = ": " ++ synopsis pkg_descr + +componentGhcOptions :: Verbosity -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo -> FilePath + -> GhcOptions +componentGhcOptions verbosity lbi bi clbi odir = + let f = case compilerFlavor (compiler lbi) of + GHC -> GHC.componentGhcOptions + GHCJS -> GHCJS.componentGhcOptions + _ -> error $ + "Distribution.Simple.Haddock.componentGhcOptions:" ++ + "haddock only supports GHC and GHCJS" + in f verbosity lbi bi clbi odir + +fromLibrary :: Verbosity + -> FilePath + -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo + -> Maybe PathTemplate -- ^ template for HTML location + -> Version + -> IO HaddockArgs +fromLibrary verbosity tmp lbi lib clbi htmlTemplate haddockVersion = do + inFiles <- map snd `fmap` getLibSourceFiles lbi lib + ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate + let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) { + -- Noooooooooo!!!!!111 + -- haddock stomps on our precious .hi + -- and .o files. Workaround by telling + -- haddock to write them elsewhere. + ghcOptObjDir = toFlag tmp, + ghcOptHiDir = toFlag tmp, + ghcOptStubDir = toFlag tmp, + ghcOptPackageKey = toFlag $ pkgKey lbi + } `mappend` getGhcCppOpts haddockVersion bi + sharedOpts = vanillaOpts { + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptFPic = toFlag True, + ghcOptHiSuffix = toFlag "dyn_hi", + ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = + toNubListR $ hcSharedOptions GHC bi + + } + opts <- if withVanillaLib lbi + then return vanillaOpts + else if withSharedLib lbi + then return sharedOpts + else die $ "Must have vanilla or shared libraries " + ++ "enabled in order to run haddock" + ghcVersion <- maybe (die "Compiler has no GHC version") + return + (compilerCompatVersion GHC (compiler lbi)) + + return ifaceArgs { + argHideModules = (mempty,otherModules $ bi), + argGhcOptions = toFlag (opts, ghcVersion), + argTargets = inFiles + } + where + bi = libBuildInfo lib + +fromExecutable :: Verbosity + -> FilePath + -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo + -> Maybe PathTemplate -- ^ template for HTML location + -> Version + -> IO HaddockArgs +fromExecutable verbosity tmp lbi exe clbi htmlTemplate haddockVersion = do + inFiles <- map snd `fmap` getExeSourceFiles lbi exe + ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate + let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) { + -- Noooooooooo!!!!!111 + -- haddock stomps on our precious .hi + -- and .o files. Workaround by telling + -- haddock to write them elsewhere. + ghcOptObjDir = toFlag tmp, + ghcOptHiDir = toFlag tmp, + ghcOptStubDir = toFlag tmp + } `mappend` getGhcCppOpts haddockVersion bi + sharedOpts = vanillaOpts { + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptFPic = toFlag True, + ghcOptHiSuffix = toFlag "dyn_hi", + ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = + toNubListR $ hcSharedOptions GHC bi + } + opts <- if withVanillaLib lbi + then return vanillaOpts + else if withSharedLib lbi + then return sharedOpts + else die $ "Must have vanilla or shared libraries " + ++ "enabled in order to run haddock" + ghcVersion <- maybe (die "Compiler has no GHC version") + return + (compilerCompatVersion GHC (compiler lbi)) + + return ifaceArgs { + argGhcOptions = toFlag (opts, ghcVersion), + argOutputDir = Dir (exeName exe), + argTitle = Flag (exeName exe), + argTargets = inFiles + } + where + bi = buildInfo exe + +compToExe :: Component -> Maybe Executable +compToExe comp = + case comp of + CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } -> + Just Executable { + exeName = testName test, + modulePath = f, + buildInfo = testBuildInfo test + } + CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } -> + Just Executable { + exeName = benchmarkName bench, + modulePath = f, + buildInfo = benchmarkBuildInfo bench + } + CExe exe -> Just exe + _ -> Nothing + +getInterfaces :: Verbosity + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate -- ^ template for HTML location + -> IO HaddockArgs +getInterfaces verbosity lbi clbi htmlTemplate = do + (packageFlags, warnings) <- haddockPackageFlags lbi clbi htmlTemplate + maybe (return ()) (warn verbosity) warnings + return $ mempty { + argInterfaces = packageFlags + } + +getGhcCppOpts :: Version + -> BuildInfo + -> GhcOptions +getGhcCppOpts haddockVersion bi = + mempty { + ghcOptExtensions = toNubListR [EnableExtension CPP | needsCpp], + ghcOptCppOptions = toNubListR defines + } + where + needsCpp = EnableExtension CPP `elem` usedExtensions bi + defines = [haddockVersionMacro] + haddockVersionMacro = "-D__HADDOCK_VERSION__=" + ++ show (v1 * 1000 + v2 * 10 + v3) + where + [v1, v2, v3] = take 3 $ versionBranch haddockVersion ++ [0,0] + +getGhcLibDir :: Verbosity -> LocalBuildInfo + -> IO HaddockArgs +getGhcLibDir verbosity lbi = do + l <- case compilerFlavor (compiler lbi) of + GHC -> GHC.getLibDir verbosity lbi + GHCJS -> GHCJS.getLibDir verbosity lbi + _ -> error "haddock only supports GHC and GHCJS" + return $ mempty { argGhcLibDir = Flag l } + +-- ------------------------------------------------------------------------------ +-- | Call haddock with the specified arguments. +runHaddock :: Verbosity + -> TempFileOptions + -> Compiler + -> ConfiguredProgram + -> HaddockArgs + -> IO () +runHaddock verbosity tmpFileOpts comp confHaddock args = do + let haddockVersion = fromMaybe (error "unable to determine haddock version") + (programVersion confHaddock) + renderArgs verbosity tmpFileOpts haddockVersion comp args $ + \(flags,result)-> do + + rawSystemProgram verbosity confHaddock flags + + notice verbosity $ "Documentation created: " ++ result + + +renderArgs :: Verbosity + -> TempFileOptions + -> Version + -> Compiler + -> HaddockArgs + -> (([String], FilePath) -> IO a) + -> IO a +renderArgs verbosity tmpFileOpts version comp args k = do + createDirectoryIfMissingVerbose verbosity True outputDir + withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $ + \prologueFileName h -> do + do + when (version >= Version [2,14,4] []) (hSetEncoding h utf8) + hPutStrLn h $ fromFlag $ argPrologue args + hClose h + let pflag = "--prologue=" ++ prologueFileName + k (pflag : renderPureArgs version comp args, result) + where + outputDir = (unDir $ argOutputDir args) + result = intercalate ", " + . map (\o -> outputDir + case o of + Html -> "index.html" + Hoogle -> pkgstr <.> "txt") + $ arg argOutput + where + pkgstr = display $ packageName pkgid + pkgid = arg argPackageName + arg f = fromFlag $ f args + +renderPureArgs :: Version -> Compiler -> HaddockArgs -> [String] +renderPureArgs version comp args = concat + [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) f) + . fromFlag . argInterfaceFile $ args + + , if isVersion 2 16 + then (\pkg -> [ "--package-name=" ++ display (pkgName pkg) + , "--package-version="++display (pkgVersion pkg) + ]) + . fromFlag . argPackageName $ args + else [] + + , (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) + . argHideModules $ args + + , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args + + , maybe [] (\(m,e,l) -> + ["--source-module=" ++ m + ,"--source-entity=" ++ e] + ++ if isVersion 2 14 then ["--source-entity-line=" ++ l] + else [] + ) . flagToMaybe . argLinkSource $ args + + , maybe [] ((:[]) . ("--css="++)) . flagToMaybe . argCssFile $ args + + , maybe [] ((:[]) . ("--use-contents="++)) . flagToMaybe . argContents $ args + + , bool [] [verbosityFlag] . getAny . argVerbose $ args + + , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") + . fromFlag . argOutput $ args + + , renderInterfaces . argInterfaces $ args + + , (:[]) . ("--odir="++) . unDir . argOutputDir $ args + + , (:[]) . ("--title="++) + . (bool (++" (internal documentation)") + id (getAny $ argIgnoreExports args)) + . fromFlag . argTitle $ args + + , [ "--optghc=" ++ opt | (opts, _ghcVer) <- flagToList (argGhcOptions args) + , opt <- renderGhcOptions comp opts ] + + , maybe [] (\l -> ["-B"++l]) $ + flagToMaybe (argGhcLibDir args) -- error if Nothing? + + , argTargets $ args + ] + where + renderInterfaces = + map (\(i,mh) -> "--read-interface=" ++ + maybe "" (++",") mh ++ i) + bool a b c = if c then a else b + isVersion major minor = version >= Version [major,minor] [] + verbosityFlag + | isVersion 2 5 = "--verbosity=1" + | otherwise = "--verbose" + +--------------------------------------------------------------------------------- + +-- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and +-- HTML paths, and an optional warning for packages with missing documentation. +haddockPackagePaths :: [InstalledPackageInfo] + -> Maybe (InstalledPackageInfo -> FilePath) + -> IO ([(FilePath, Maybe FilePath)], Maybe String) +haddockPackagePaths ipkgs mkHtmlPath = do + interfaces <- sequence + [ case interfaceAndHtmlPath ipkg of + Nothing -> return (Left (packageId ipkg)) + Just (interface, html) -> do + exists <- doesFileExist interface + if exists + then return (Right (interface, html)) + else return (Left pkgid) + | ipkg <- ipkgs, let pkgid = packageId ipkg + , pkgName pkgid `notElem` noHaddockWhitelist + ] + + let missing = [ pkgid | Left pkgid <- interfaces ] + warning = "The documentation for the following packages are not " + ++ "installed. No links will be generated to these packages: " + ++ intercalate ", " (map display missing) + flags = rights interfaces + + return (flags, if null missing then Nothing else Just warning) + + where + -- Don't warn about missing documentation for these packages. See #1231. + noHaddockWhitelist = map PackageName [ "rts" ] + + -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'. + interfaceAndHtmlPath :: InstalledPackageInfo + -> Maybe (FilePath, Maybe FilePath) + interfaceAndHtmlPath pkg = do + interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) + html <- case mkHtmlPath of + Nothing -> fmap fixFileUrl + (listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)) + Just mkPath -> Just (mkPath pkg) + return (interface, if null html then Nothing else Just html) + where + -- The 'haddock-html' field in the hc-pkg output is often set as a + -- native path, but we need it as a URL. See #1064. + fixFileUrl f | isAbsolute f = "file://" ++ f + | otherwise = f + +haddockPackageFlags :: LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -> IO ([(FilePath, Maybe FilePath)], Maybe String) +haddockPackageFlags lbi clbi htmlTemplate = do + let allPkgs = installedPkgs lbi + directDeps = map fst (componentPackageDeps clbi) + transitiveDeps <- case dependencyClosure allPkgs directDeps of + Left x -> return x + Right inf -> die $ "internal error when calculating transitive " + ++ "package dependencies.\nDebug info: " ++ show inf + haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath + where + mkHtmlPath = fmap expandTemplateVars htmlTemplate + expandTemplateVars tmpl pkg = + fromPathTemplate . substPathTemplate (env pkg) $ tmpl + env pkg = haddockTemplateEnv lbi (packageId pkg) + + +haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv +haddockTemplateEnv lbi pkg_id = + (PrefixVar, prefix (installDirTemplates lbi)) + : initialPathTemplateEnv pkg_id (pkgKey lbi) (compilerInfo (compiler lbi)) + (hostPlatform lbi) + +-- ------------------------------------------------------------------------------ +-- hscolour support. + +hscolour :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour pkg_descr lbi suffixes flags = do + -- we preprocess even if hscolour won't be found on the machine + -- will this upset someone? + initialBuildSteps distPref pkg_descr lbi verbosity + hscolour' die pkg_descr lbi suffixes flags + where + verbosity = fromFlag (hscolourVerbosity flags) + distPref = fromFlag $ hscolourDistPref flags + +hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour' onNoHsColour pkg_descr lbi suffixes flags = + either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<< + lookupProgramVersion verbosity hscolourProgram + (orLaterVersion (Version [1,8] [])) (withPrograms lbi) + where + go :: ConfiguredProgram -> IO () + go hscolourProg = do + setupMessage verbosity "Running hscolour for" (packageId pkg_descr) + createDirectoryIfMissingVerbose verbosity True $ + hscolourPref distPref pkg_descr + + let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes + withAllComponentsInBuildOrder pkg_descr lbi $ \comp _ -> do + pre comp + let + doExe com = case (compToExe com) of + Just exe -> do + let outputDir = hscolourPref distPref pkg_descr + exeName exe "src" + runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe + Nothing -> do + warn (fromFlag $ hscolourVerbosity flags) + "Unsupported component, skipping..." + return () + case comp of + CLib lib -> do + let outputDir = hscolourPref distPref pkg_descr "src" + runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib + CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp + CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp + CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp + + stylesheet = flagToMaybe (hscolourCSS flags) + + verbosity = fromFlag (hscolourVerbosity flags) + distPref = fromFlag (hscolourDistPref flags) + + runHsColour prog outputDir moduleFiles = do + createDirectoryIfMissingVerbose verbosity True outputDir + + case stylesheet of -- copy the CSS file + Nothing | programVersion prog >= Just (Version [1,9] []) -> + rawSystemProgram verbosity prog + ["-print-css", "-o" ++ outputDir "hscolour.css"] + | otherwise -> return () + Just s -> copyFileVerbose verbosity s (outputDir "hscolour.css") + + forM_ moduleFiles $ \(m, inFile) -> + rawSystemProgram verbosity prog + ["-css", "-anchor", "-o" ++ outFile m, inFile] + where + outFile m = outputDir + intercalate "-" (ModuleName.components m) <.> "html" + +haddockToHscolour :: HaddockFlags -> HscolourFlags +haddockToHscolour flags = + HscolourFlags { + hscolourCSS = haddockHscolourCss flags, + hscolourExecutables = haddockExecutables flags, + hscolourTestSuites = haddockTestSuites flags, + hscolourBenchmarks = haddockBenchmarks flags, + hscolourVerbosity = haddockVerbosity flags, + hscolourDistPref = haddockDistPref flags + } +--------------------------------------------------------------------------------- +-- TODO these should be moved elsewhere. + +getLibSourceFiles :: LocalBuildInfo + -> Library + -> IO [(ModuleName.ModuleName, FilePath)] +getLibSourceFiles lbi lib = getSourceFiles searchpaths modules + where + bi = libBuildInfo lib + modules = PD.exposedModules lib ++ otherModules bi + searchpaths = autogenModulesDir lbi : buildDir lbi : hsSourceDirs bi + +getExeSourceFiles :: LocalBuildInfo + -> Executable + -> IO [(ModuleName.ModuleName, FilePath)] +getExeSourceFiles lbi exe = do + moduleFiles <- getSourceFiles searchpaths modules + srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe) + return ((ModuleName.main, srcMainPath) : moduleFiles) + where + bi = buildInfo exe + modules = otherModules bi + searchpaths = autogenModulesDir lbi : exeBuildDir lbi exe : hsSourceDirs bi + +getSourceFiles :: [FilePath] + -> [ModuleName.ModuleName] + -> IO [(ModuleName.ModuleName, FilePath)] +getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $ + findFileWithExtension ["hs", "lhs"] dirs (ModuleName.toFilePath m) + >>= maybe (notFound m) (return . normalise) + where + notFound module_ = die $ "can't find source for module " ++ display module_ + +-- | The directory where we put build results for an executable +exeBuildDir :: LocalBuildInfo -> Executable -> FilePath +exeBuildDir lbi exe = buildDir lbi exeName exe exeName exe ++ "-tmp" + +-- ------------------------------------------------------------------------------ +-- Boilerplate Monoid instance. +instance Monoid HaddockArgs where + mempty = HaddockArgs { + argInterfaceFile = mempty, + argPackageName = mempty, + argHideModules = mempty, + argIgnoreExports = mempty, + argLinkSource = mempty, + argCssFile = mempty, + argContents = mempty, + argVerbose = mempty, + argOutput = mempty, + argInterfaces = mempty, + argOutputDir = mempty, + argTitle = mempty, + argPrologue = mempty, + argGhcOptions = mempty, + argGhcLibDir = mempty, + argTargets = mempty + } + mappend a b = HaddockArgs { + argInterfaceFile = mult argInterfaceFile, + argPackageName = mult argPackageName, + argHideModules = mult argHideModules, + argIgnoreExports = mult argIgnoreExports, + argLinkSource = mult argLinkSource, + argCssFile = mult argCssFile, + argContents = mult argContents, + argVerbose = mult argVerbose, + argOutput = mult argOutput, + argInterfaces = mult argInterfaces, + argOutputDir = mult argOutputDir, + argTitle = mult argTitle, + argPrologue = mult argPrologue, + argGhcOptions = mult argGhcOptions, + argGhcLibDir = mult argGhcLibDir, + argTargets = mult argTargets + } + where mult f = f a `mappend` f b + +instance Monoid Directory where + mempty = Dir "." + mappend (Dir m) (Dir n) = Dir $ m n diff --git a/Distribution/Simple/HaskellSuite.hs b/Distribution/Simple/HaskellSuite.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/HaskellSuite.hs @@ -0,0 +1,228 @@ +{-# 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) + +import Distribution.Simple.Program +import Distribution.Simple.Compiler as Compiler +import Distribution.Simple.Utils +import Distribution.Simple.BuildPaths +import Distribution.Verbosity +import Distribution.Text +import Distribution.Package +import Distribution.InstalledPackageInfo hiding (includeDirs) +import Distribution.Simple.PackageIndex as PackageIndex +import Distribution.PackageDescription +import Distribution.Simple.LocalBuildInfo +import Distribution.System (Platform) +import Distribution.Compat.Exception +import Language.Haskell.Extension +import Distribution.Simple.Program.Builtin + (haskellSuiteProgram, haskellSuitePkgProgram) + +configure + :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) +configure verbosity mbHcPath hcPkgPath conf0 = do + + -- We have no idea how a haskell-suite tool is named, so we require at + -- least some information from the user. + hcPath <- + let msg = "You have to provide name or path of a haskell-suite tool (-w PATH)" + in maybe (die msg) return mbHcPath + + when (isJust hcPkgPath) $ + warn verbosity "--with-hc-pkg option is ignored for haskell-suite" + + (comp, confdCompiler, conf1) <- configureCompiler hcPath conf0 + + -- Update our pkg tool. It uses the same executable as the compiler, but + -- all command start with "pkg" + (confdPkg, _) <- requireProgram verbosity haskellSuitePkgProgram conf1 + let conf2 = + updateProgram + confdPkg + { programLocation = programLocation confdCompiler + , programDefaultArgs = ["pkg"] + } + conf1 + + return (comp, Nothing, conf2) + + where + configureCompiler hcPath conf0' = do + let + haskellSuiteProgram' = + haskellSuiteProgram + { programFindLocation = \v _p -> findProgramLocation v hcPath } + + -- NB: cannot call requireProgram right away — it'd think that + -- the program is already configured and won't reconfigure it again. + -- Instead, call configureProgram directly first. + conf1 <- configureProgram verbosity haskellSuiteProgram' conf0' + (confdCompiler, conf2) <- requireProgram verbosity haskellSuiteProgram' conf1 + + extensions <- getExtensions verbosity confdCompiler + languages <- getLanguages verbosity confdCompiler + (compName, compVersion) <- + getCompilerVersion verbosity confdCompiler + + let + comp = Compiler { + compilerId = CompilerId (HaskellSuite compName) compVersion, + compilerAbiTag = Compiler.NoAbiTag, + compilerCompat = [], + compilerLanguages = languages, + compilerExtensions = extensions, + compilerProperties = M.empty + } + + return (comp, confdCompiler, conf2) + +hstoolVersion :: Verbosity -> FilePath -> IO (Maybe Version) +hstoolVersion = findProgramVersion "--hspkg-version" id + +numericVersion :: Verbosity -> FilePath -> IO (Maybe Version) +numericVersion = findProgramVersion "--compiler-version" (last . words) + +getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version) +getCompilerVersion verbosity prog = do + output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"] + let + parts = words output + name = concat $ init parts -- there shouldn't be any spaces in the name anyway + versionStr = last parts + version <- + maybe (die "haskell-suite: couldn't determine compiler version") return $ + simpleParse versionStr + return (name, version) + +getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Compiler.Flag)] +getExtensions verbosity prog = do + extStrs <- + lines <$> + rawSystemStdout verbosity (programPath prog) ["--supported-extensions"] + return + [ (ext, "-X" ++ display ext) | Just ext <- map simpleParse extStrs ] + +getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Compiler.Flag)] +getLanguages verbosity prog = do + langStrs <- + lines <$> + rawSystemStdout verbosity (programPath prog) ["--supported-languages"] + return + [ (ext, "-G" ++ display ext) | Just ext <- map simpleParse langStrs ] + +-- Other compilers do some kind of a packagedb stack check here. Not sure +-- if we need something like that as well. +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO InstalledPackageIndex +getInstalledPackages verbosity packagedbs conf = + liftM (PackageIndex.fromList . concat) $ forM packagedbs $ \packagedb -> + do str <- + getDbProgramOutput verbosity haskellSuitePkgProgram conf + ["dump", packageDbOpt packagedb] + `catchExit` \_ -> die $ "pkg dump failed" + case parsePackages str of + Right ok -> return ok + _ -> die "failed to parse output of 'pkg dump'" + + where + parsePackages str = + let parsed = map parseInstalledPackageInfo (splitPkgs str) + in case [ msg | ParseFailed msg <- parsed ] of + [] -> Right [ pkg | ParseOk _ pkg <- parsed ] + msgs -> Left msgs + + splitPkgs :: String -> [String] + splitPkgs = map unlines . splitWith ("---" ==) . lines + where + splitWith :: (a -> Bool) -> [a] -> [[a]] + splitWith p xs = ys : case zs of + [] -> [] + _:ws -> splitWith p ws + where (ys,zs) = break p xs + +buildLib + :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + -- In future, there should be a mechanism for the compiler to request any + -- number of the above parameters (or their parts) — in particular, + -- pieces of PackageDescription. + -- + -- For now, we only pass those that we know are used. + + let odir = buildDir lbi + bi = libBuildInfo lib + srcDirs = hsSourceDirs bi ++ [odir] + dbStack = withPackageDB lbi + language = fromMaybe Haskell98 (defaultLanguage bi) + conf = withPrograms lbi + pkgid = packageId pkg_descr + + runDbProgram verbosity haskellSuiteProgram conf $ + [ "compile", "--build-dir", odir ] ++ + concat [ ["-i", d] | d <- srcDirs ] ++ + concat [ ["-I", d] | d <- [autogenModulesDir lbi, odir] ++ includeDirs bi ] ++ + [ packageDbOpt pkgDb | pkgDb <- dbStack ] ++ + [ "--package-name", display pkgid ] ++ + concat [ ["--package-id", display ipkgid ] + | (ipkgid, _) <- componentPackageDeps clbi ] ++ + ["-G", display language] ++ + concat [ ["-X", display ex] | ex <- usedExtensions bi ] ++ + cppOptions (libBuildInfo lib) ++ + [ display modu | modu <- libModules lib ] + + + +installLib + :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^install location + -> FilePath -- ^install location for dynamic libraries + -> FilePath -- ^Build location + -> PackageDescription + -> Library + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do + let conf = withPrograms lbi + runDbProgram verbosity haskellSuitePkgProgram conf $ + [ "install-library" + , "--build-dir", builtDir + , "--target-dir", targetDir + , "--dynlib-target-dir", dynlibTargetDir + , "--package-id", display $ packageId pkg + ] ++ map display (libModules lib) + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do + (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram (withPrograms lbi) + + runProgramInvocation verbosity $ + (programInvocation hspkg + ["update", packageDbOpt $ last packageDbs]) + { progInvokeInput = Just $ showInstalledPackageInfo installedPkgInfo } + +initPackageDB :: Verbosity -> ProgramConfiguration -> FilePath -> IO () +initPackageDB verbosity conf dbPath = + runDbProgram verbosity haskellSuitePkgProgram conf + ["init", dbPath] + +packageDbOpt :: PackageDB -> String +packageDbOpt GlobalPackageDB = "--global" +packageDbOpt UserPackageDB = "--user" +packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ db diff --git a/Distribution/Simple/Hpc.hs b/Distribution/Simple/Hpc.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Hpc.hs @@ -0,0 +1,141 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Hpc +-- Copyright : Thomas Tuegel 2011 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides functions for locating various HPC-related paths and +-- a function for adding the necessary options to a PackageDescription to +-- build test suites with HPC enabled. + +module Distribution.Simple.Hpc + ( Way(..), guessWay + , htmlDir + , mixDir + , tixDir + , tixFilePath + , markupPackage + , markupTest + ) where + +import Control.Monad ( when ) +import Distribution.ModuleName ( main ) +import Distribution.PackageDescription + ( TestSuite(..) + , testModules + ) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.Program + ( hpcProgram + , requireProgramVersion + ) +import Distribution.Simple.Program.Hpc ( markup, union ) +import Distribution.Simple.Utils ( notice ) +import Distribution.Version ( anyVersion ) +import Distribution.Verbosity ( Verbosity() ) +import System.Directory ( createDirectoryIfMissing, doesFileExist ) +import System.FilePath + +-- ------------------------------------------------------------------------- +-- Haskell Program Coverage + +data Way = Vanilla | Prof | Dyn + deriving (Bounded, Enum, Eq, Read, Show) + +hpcDir :: FilePath -- ^ \"dist/\" prefix + -> Way + -> FilePath -- ^ Directory containing component's HPC .mix files +hpcDir distPref way = distPref "hpc" wayDir + where + wayDir = case way of + Vanilla -> "vanilla" + Prof -> "prof" + Dyn -> "dyn" + +mixDir :: FilePath -- ^ \"dist/\" prefix + -> Way + -> FilePath -- ^ Component name + -> FilePath -- ^ Directory containing test suite's .mix files +mixDir distPref way name = hpcDir distPref way "mix" name + +tixDir :: FilePath -- ^ \"dist/\" prefix + -> Way + -> FilePath -- ^ Component name + -> FilePath -- ^ Directory containing test suite's .tix files +tixDir distPref way name = hpcDir distPref way "tix" name + +-- | Path to the .tix file containing a test suite's sum statistics. +tixFilePath :: FilePath -- ^ \"dist/\" prefix + -> Way + -> FilePath -- ^ Component name + -> FilePath -- ^ Path to test suite's .tix file +tixFilePath distPref way name = tixDir distPref way name name <.> "tix" + +htmlDir :: FilePath -- ^ \"dist/\" prefix + -> Way + -> FilePath -- ^ Component name + -> FilePath -- ^ Path to test suite's HTML markup directory +htmlDir distPref way name = hpcDir distPref way "html" name + +-- | Attempt to guess the way the test suites in this package were compiled +-- and linked with the library so the correct module interfaces are found. +guessWay :: LocalBuildInfo -> Way +guessWay lbi + | withProfExe lbi = Prof + | withDynExe lbi = Dyn + | otherwise = Vanilla + +-- | Generate the HTML markup for a test suite. +markupTest :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^ \"dist/\" prefix + -> String -- ^ Library name + -> TestSuite + -> IO () +markupTest verbosity lbi distPref libName suite = do + tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName suite + when tixFileExists $ do + -- behaviour of 'markup' depends on version, so we need *a* version + -- but no particular one + (hpc, hpcVer, _) <- requireProgramVersion verbosity + hpcProgram anyVersion (withPrograms lbi) + let htmlDir_ = htmlDir distPref way $ testName suite + markup hpc hpcVer verbosity + (tixFilePath distPref way $ testName suite) mixDirs + htmlDir_ + (testModules suite ++ [ main ]) + notice verbosity $ "Test coverage report written to " + ++ htmlDir_ "hpc_index" <.> "html" + where + way = guessWay lbi + mixDirs = map (mixDir distPref way) [ testName suite, libName ] + +-- | Generate the HTML markup for all of a package's test suites. +markupPackage :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^ \"dist/\" prefix + -> String -- ^ Library name + -> [TestSuite] + -> IO () +markupPackage verbosity lbi distPref libName suites = do + let tixFiles = map (tixFilePath distPref way . testName) suites + tixFilesExist <- mapM doesFileExist tixFiles + when (and tixFilesExist) $ do + -- behaviour of 'markup' depends on version, so we need *a* version + -- but no particular one + (hpc, hpcVer, _) <- requireProgramVersion verbosity + hpcProgram anyVersion (withPrograms lbi) + let outFile = tixFilePath distPref way libName + htmlDir' = htmlDir distPref way libName + excluded = concatMap testModules suites ++ [ main ] + createDirectoryIfMissing True $ takeDirectory outFile + union hpc verbosity tixFiles outFile excluded + markup hpc hpcVer verbosity outFile mixDirs htmlDir' excluded + notice verbosity $ "Package coverage report written to " + ++ htmlDir' "hpc_index.html" + where + way = guessWay lbi + mixDirs = map (mixDir distPref way) $ libName : map testName suites diff --git a/Distribution/Simple/Install.hs b/Distribution/Simple/Install.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Install.hs @@ -0,0 +1,190 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Install +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into installing a built package. Performs the +-- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into +-- place based on the prefix argument. It does the generic bits and then calls +-- compiler-specific functions to do the rest. + +module Distribution.Simple.Install ( + install, + ) where + +import Distribution.PackageDescription ( + PackageDescription(..), BuildInfo(..), Library(..), + hasLibs, withLib, hasExes, withExe ) +import Distribution.Package (Package(..)) +import Distribution.Simple.LocalBuildInfo ( + LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs, + substPathTemplate, withLibLBI) +import Distribution.Simple.BuildPaths (haddockName, haddockPref) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose + , installDirectoryContents, installOrdinaryFile, isInSearchPath + , die, info, notice, warn, matchDirFileGlob ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), compilerFlavor ) +import Distribution.Simple.Setup (CopyFlags(..), fromFlag) + +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 + +import Control.Monad (when, unless) +import System.Directory + ( doesDirectoryExist, doesFileExist ) +import System.FilePath + ( takeFileName, takeDirectory, (), isAbsolute ) + +import Distribution.Verbosity +import Distribution.Text + ( display ) + +-- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" +-- actions. Move files into place based on the prefix argument. + +install :: PackageDescription -- ^information from the .cabal file + -> LocalBuildInfo -- ^information from the configure step + -> CopyFlags -- ^flags sent to copy or install + -> IO () +install pkg_descr lbi flags = do + let distPref = fromFlag (copyDistPref flags) + verbosity = fromFlag (copyVerbosity flags) + copydest = fromFlag (copyDest flags) + installDirs@(InstallDirs { + bindir = binPref, + libdir = libPref, +-- dynlibdir = dynlibPref, --see TODO below + datadir = dataPref, + docdir = docPref, + htmldir = htmlPref, + haddockdir = interfacePref, + includedir = incPref}) + = absoluteInstallDirs pkg_descr lbi copydest + + --TODO: decide if we need the user to be able to control the libdir + -- for shared libs independently of the one for static libs. If so + -- it should also have a flag in the command line UI + -- For the moment use dynlibdir = libdir + dynlibPref = libPref + progPrefixPref = substPathTemplate (packageId pkg_descr) lbi (progPrefix lbi) + progSuffixPref = substPathTemplate (packageId pkg_descr) lbi (progSuffix lbi) + + docExists <- doesDirectoryExist $ haddockPref distPref pkg_descr + info verbosity ("directory " ++ haddockPref distPref pkg_descr ++ + " does exist: " ++ show docExists) + + installDataFiles verbosity pkg_descr dataPref + + when docExists $ do + createDirectoryIfMissingVerbose verbosity True htmlPref + installDirectoryContents verbosity + (haddockPref distPref pkg_descr) htmlPref + -- setPermissionsRecursive [Read] htmlPref + -- The haddock interface file actually already got installed + -- in the recursive copy, but now we install it where we actually + -- want it to be (normally the same place). We could remove the + -- copy in htmlPref first. + let haddockInterfaceFileSrc = haddockPref distPref pkg_descr + haddockName pkg_descr + haddockInterfaceFileDest = interfacePref haddockName pkg_descr + -- We only generate the haddock interface file for libs, So if the + -- package consists only of executables there will not be one: + exists <- doesFileExist haddockInterfaceFileSrc + when exists $ do + createDirectoryIfMissingVerbose verbosity True interfacePref + installOrdinaryFile verbosity haddockInterfaceFileSrc + haddockInterfaceFileDest + + let lfiles = licenseFiles pkg_descr + unless (null lfiles) $ do + createDirectoryIfMissingVerbose verbosity True docPref + sequence_ + [ installOrdinaryFile verbosity lfile (docPref takeFileName lfile) + | lfile <- lfiles ] + + let buildPref = buildDir lbi + when (hasLibs pkg_descr) $ + notice verbosity ("Installing library in " ++ libPref) + when (hasExes pkg_descr) $ do + notice verbosity ("Installing executable(s) in " ++ binPref) + inPath <- isInSearchPath binPref + when (not inPath) $ + warn verbosity ("The directory " ++ binPref + ++ " is not in the system search path.") + + -- install include files for all compilers - they may be needed to compile + -- haskell files (using the CPP extension) + when (hasLibs pkg_descr) $ installIncludeFiles verbosity pkg_descr incPref + + case compilerFlavor (compiler lbi) of + GHC -> do 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" + -- register step should be performed by caller. + +-- | Install the files listed in data-files +-- +installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO () +installDataFiles verbosity pkg_descr destDataDir = + flip mapM_ (dataFiles pkg_descr) $ \ file -> do + let srcDataDir = dataDir pkg_descr + files <- matchDirFileGlob srcDataDir file + let dir = takeDirectory file + createDirectoryIfMissingVerbose verbosity True (destDataDir dir) + sequence_ [ installOrdinaryFile verbosity (srcDataDir file') + (destDataDir file') + | file' <- files ] + +-- | Install the files listed in install-includes +-- +installIncludeFiles :: Verbosity -> PackageDescription -> FilePath -> IO () +installIncludeFiles verbosity + PackageDescription { library = Just lib } destIncludeDir = do + + incs <- mapM (findInc relincdirs) (installIncludes lbi) + sequence_ + [ do createDirectoryIfMissingVerbose verbosity True destDir + installOrdinaryFile verbosity srcFile destFile + | (relFile, srcFile) <- incs + , let destFile = destIncludeDir relFile + destDir = takeDirectory destFile ] + where + relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) + lbi = libBuildInfo lib + + findInc [] file = die ("can't find include file " ++ file) + findInc (dir:dirs) file = do + let path = dir file + exists <- doesFileExist path + if exists then return (file, path) else findInc dirs file +installIncludeFiles _ _ _ = die "installIncludeFiles: Can't happen?" diff --git a/Distribution/Simple/InstallDirs.hs b/Distribution/Simple/InstallDirs.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/InstallDirs.hs @@ -0,0 +1,605 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.InstallDirs +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This manages everything to do with where files get installed (though does +-- not get involved with actually doing any installation). It provides an +-- 'InstallDirs' type which is a set of directories for where to install +-- things. It also handles the fact that we use templates in these install +-- dirs. For example most install dirs are relative to some @$prefix@ and by +-- changing the prefix all other dirs still end up changed appropriately. So it +-- provides a 'PathTemplate' type and functions for substituting for these +-- templates. + +module Distribution.Simple.InstallDirs ( + InstallDirs(..), + InstallDirTemplates, + defaultInstallDirs, + combineInstallDirs, + absoluteInstallDirs, + CopyDest(..), + prefixRelativeInstallDirs, + substituteInstallDirTemplates, + + PathTemplate, + PathTemplateVariable(..), + PathTemplateEnv, + toPathTemplate, + fromPathTemplate, + substPathTemplate, + initialPathTemplateEnv, + platformTemplateEnv, + compilerTemplateEnv, + packageTemplateEnv, + abiTemplateEnv, + installDirsTemplateEnv, + ) where + + +import Distribution.Compat.Binary (Binary) +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 ) +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 +#endif + +-- --------------------------------------------------------------------------- +-- Installation directories + + +-- | The directories where we will install files for packages. +-- +-- We have several different directories for different types of files since +-- many systems have conventions whereby different types of files in a package +-- are installed in different directories. This is particularly the case on +-- Unix style systems. +-- +data InstallDirs dir = InstallDirs { + prefix :: dir, + bindir :: dir, + libdir :: dir, + libsubdir :: dir, + dynlibdir :: dir, + libexecdir :: dir, + includedir :: dir, + datadir :: dir, + datasubdir :: dir, + docdir :: dir, + mandir :: dir, + htmldir :: dir, + haddockdir :: dir, + sysconfdir :: dir + } deriving (Generic, Read, Show) + +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 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 + +combineInstallDirs :: (a -> b -> c) + -> InstallDirs a + -> InstallDirs b + -> InstallDirs c +combineInstallDirs combine a b = InstallDirs { + prefix = prefix a `combine` prefix b, + bindir = bindir a `combine` bindir b, + libdir = libdir a `combine` libdir b, + libsubdir = libsubdir a `combine` libsubdir b, + dynlibdir = dynlibdir a `combine` dynlibdir b, + libexecdir = libexecdir a `combine` libexecdir b, + includedir = includedir a `combine` includedir b, + datadir = datadir a `combine` datadir b, + datasubdir = datasubdir a `combine` datasubdir b, + docdir = docdir a `combine` docdir b, + mandir = mandir a `combine` mandir b, + htmldir = htmldir a `combine` htmldir b, + haddockdir = haddockdir a `combine` haddockdir b, + sysconfdir = sysconfdir a `combine` sysconfdir b + } + +appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a +appendSubdirs append dirs = dirs { + libdir = libdir dirs `append` libsubdir dirs, + datadir = datadir dirs `append` datasubdir dirs, + libsubdir = error "internal error InstallDirs.libsubdir", + datasubdir = error "internal error InstallDirs.datasubdir" + } + +-- | The installation directories in terms of 'PathTemplate's that contain +-- variables. +-- +-- The defaults for most of the directories are relative to each other, in +-- particular they are all relative to a single prefix. This makes it +-- convenient for the user to override the default installation directory +-- by only having to specify --prefix=... rather than overriding each +-- individually. This is done by allowing $-style variables in the dirs. +-- These are expanded by textual substitution (see 'substPathTemplate'). +-- +-- A few of these installation directories are split into two components, the +-- dir and subdir. The full installation path is formed by combining the two +-- together with @\/@. The reason for this is compatibility with other Unix +-- build systems which also support @--libdir@ and @--datadir@. We would like +-- users to be able to configure @--libdir=\/usr\/lib64@ for example but +-- because by default we want to support installing multiple versions of +-- packages and building the same package for multiple compilers we append the +-- libsubdir to get: @\/usr\/lib64\/$pkgkey\/$compiler@. +-- +-- An additional complication is the need to support relocatable packages on +-- systems which support such things, like Windows. +-- +type InstallDirTemplates = InstallDirs PathTemplate + +-- --------------------------------------------------------------------------- +-- Default installation directories + +defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates +defaultInstallDirs comp userInstall _hasLibs = do + installPrefix <- + if userInstall + then getAppUserDataDirectory "cabal" + else case buildOS of + Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir + return (windowsProgramFilesDir "Haskell") + _ -> return "/usr/local" + installLibDir <- + case buildOS of + Windows -> return "$prefix" + _ -> case comp of + LHC | userInstall -> getAppUserDataDirectory "lhc" + _ -> return ("$prefix" "lib") + return $ fmap toPathTemplate $ InstallDirs { + prefix = installPrefix, + bindir = "$prefix" "bin", + libdir = installLibDir, + libsubdir = case comp of + JHC -> "$compiler" + LHC -> "$compiler" + UHC -> "$pkgid" + _other -> "$abi" "$pkgkey", + dynlibdir = "$libdir", + libexecdir = case buildOS of + Windows -> "$prefix" "$pkgkey" + _other -> "$prefix" "libexec", + includedir = "$libdir" "$libsubdir" "include", + datadir = case buildOS of + Windows -> "$prefix" + _other -> "$prefix" "share", + datasubdir = "$abi" "$pkgid", + docdir = "$datadir" "doc" "$abi" "$pkgid", + mandir = "$datadir" "man", + htmldir = "$docdir" "html", + haddockdir = "$htmldir", + sysconfdir = "$prefix" "etc" + } + +-- --------------------------------------------------------------------------- +-- Converting directories, absolute or prefix-relative + +-- | Substitute the install dir templates into each other. +-- +-- To prevent cyclic substitutions, only some variables are allowed in +-- particular dir templates. If out of scope vars are present, they are not +-- substituted for. Checking for any remaining unsubstituted vars can be done +-- as a subsequent operation. +-- +-- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we +-- can replace 'prefix' with the 'PrefixVar' and get resulting +-- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it +-- each to check which paths are relative to the $prefix. +-- +substituteInstallDirTemplates :: PathTemplateEnv + -> InstallDirTemplates -> InstallDirTemplates +substituteInstallDirTemplates env dirs = dirs' + where + dirs' = InstallDirs { + -- So this specifies exactly which vars are allowed in each template + prefix = subst prefix [], + bindir = subst bindir [prefixVar], + libdir = subst libdir [prefixVar, bindirVar], + libsubdir = subst libsubdir [], + dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar], + libexecdir = subst libexecdir prefixBinLibVars, + includedir = subst includedir prefixBinLibVars, + datadir = subst datadir prefixBinLibVars, + datasubdir = subst datasubdir [], + docdir = subst docdir prefixBinLibDataVars, + mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]), + htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]), + haddockdir = subst haddockdir (prefixBinLibDataVars ++ + [docdirVar, htmldirVar]), + sysconfdir = subst sysconfdir prefixBinLibVars + } + subst dir env' = substPathTemplate (env'++env) (dir dirs) + + prefixVar = (PrefixVar, prefix dirs') + bindirVar = (BindirVar, bindir dirs') + libdirVar = (LibdirVar, libdir dirs') + libsubdirVar = (LibsubdirVar, libsubdir dirs') + datadirVar = (DatadirVar, datadir dirs') + datasubdirVar = (DatasubdirVar, datasubdir dirs') + docdirVar = (DocdirVar, docdir dirs') + htmldirVar = (HtmldirVar, htmldir dirs') + prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar] + prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] + +-- | Convert from abstract install directories to actual absolute ones by +-- substituting for all the variables in the abstract paths, to get real +-- absolute path. +absoluteInstallDirs :: PackageIdentifier + -> PackageKey + -> CompilerInfo + -> CopyDest + -> Platform + -> InstallDirs PathTemplate + -> InstallDirs FilePath +absoluteInstallDirs pkgId pkg_key compilerId copydest platform dirs = + (case copydest of + CopyTo destdir -> fmap ((destdir ) . dropDrive) + _ -> id) + . appendSubdirs () + . fmap fromPathTemplate + $ substituteInstallDirTemplates env dirs + where + env = initialPathTemplateEnv pkgId pkg_key compilerId platform + + +-- |The location prefix for the /copy/ command. +data CopyDest + = NoCopyDest + | CopyTo FilePath + deriving (Eq, Show) + +-- | Check which of the paths are relative to the installation $prefix. +-- +-- If any of the paths are not relative, ie they are absolute paths, then it +-- prevents us from making a relocatable package (also known as a \"prefix +-- independent\" package). +-- +prefixRelativeInstallDirs :: PackageIdentifier + -> PackageKey + -> CompilerInfo + -> Platform + -> InstallDirTemplates + -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs pkgId pkg_key compilerId platform dirs = + fmap relative + . appendSubdirs combinePathTemplate + $ -- substitute the path template into each other, except that we map + -- \$prefix back to $prefix. We're trying to end up with templates that + -- mention no vars except $prefix. + substituteInstallDirTemplates env dirs { + prefix = PathTemplate [Variable PrefixVar] + } + where + env = initialPathTemplateEnv pkgId pkg_key compilerId platform + + -- If it starts with $prefix then it's relative and produce the relative + -- path by stripping off $prefix/ or $prefix + relative dir = case dir of + PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) + relative' (Variable PrefixVar : Ordinary (s:rest) : rest') + | isPathSeparator s = Just (Ordinary rest : rest') + relative' (Variable PrefixVar : rest) = Just rest + relative' _ = Nothing + +-- --------------------------------------------------------------------------- +-- Path templates + +-- | An abstract path, possibly containing variables that need to be +-- substituted for to get a real 'FilePath'. +-- +newtype PathTemplate = PathTemplate [PathComponent] deriving (Eq, Generic, Ord) + +instance Binary PathTemplate + +data PathComponent = + Ordinary FilePath + | Variable PathTemplateVariable + deriving (Eq, Ord, Generic) + +instance Binary PathComponent + +data PathTemplateVariable = + PrefixVar -- ^ The @$prefix@ path variable + | BindirVar -- ^ The @$bindir@ path variable + | LibdirVar -- ^ The @$libdir@ path variable + | LibsubdirVar -- ^ The @$libsubdir@ path variable + | DatadirVar -- ^ The @$datadir@ path variable + | DatasubdirVar -- ^ The @$datasubdir@ path variable + | DocdirVar -- ^ The @$docdir@ path variable + | HtmldirVar -- ^ The @$htmldir@ path variable + | PkgNameVar -- ^ The @$pkg@ package name path variable + | PkgVerVar -- ^ The @$version@ package version path variable + | PkgIdVar -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@ + | PkgKeyVar -- ^ The @$pkgkey@ package key 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@ + | AbiVar -- ^ The Compiler's ABI identifier, $arch-$os-$compiler-$abitag + | AbiTagVar -- ^ The optional ABI tag for the compiler + | ExecutableNameVar -- ^ The executable name; used in shell wrappers + | TestSuiteNameVar -- ^ The name of the test suite being run + | TestSuiteResultVar -- ^ The result of the test suite being run, eg + -- @pass@, @fail@, or @error@. + | BenchmarkNameVar -- ^ The name of the benchmark being run + deriving (Eq, Ord, Generic) + +instance Binary PathTemplateVariable + +type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] + +-- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. +-- +toPathTemplate :: FilePath -> PathTemplate +toPathTemplate = PathTemplate . read + +-- | Convert back to a path, any remaining vars are included +-- +fromPathTemplate :: PathTemplate -> FilePath +fromPathTemplate (PathTemplate template) = show template + +combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate +combinePathTemplate (PathTemplate t1) (PathTemplate t2) = + PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2) + +substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate +substPathTemplate environment (PathTemplate template) = + PathTemplate (concatMap subst template) + + where subst component@(Ordinary _) = [component] + subst component@(Variable variable) = + case lookup variable environment of + Just (PathTemplate components) -> components + Nothing -> [component] + +-- | The initial environment has all the static stuff but no paths +initialPathTemplateEnv :: PackageIdentifier + -> PackageKey + -> CompilerInfo + -> Platform + -> PathTemplateEnv +initialPathTemplateEnv pkgId pkg_key compiler platform = + packageTemplateEnv pkgId pkg_key + ++ compilerTemplateEnv compiler + ++ platformTemplateEnv platform + ++ abiTemplateEnv compiler platform + +packageTemplateEnv :: PackageIdentifier -> PackageKey -> PathTemplateEnv +packageTemplateEnv pkgId pkg_key = + [(PkgNameVar, PathTemplate [Ordinary $ display (packageName pkgId)]) + ,(PkgVerVar, PathTemplate [Ordinary $ display (packageVersion pkgId)]) + ,(PkgKeyVar, PathTemplate [Ordinary $ display pkg_key]) + ,(PkgIdVar, PathTemplate [Ordinary $ display pkgId]) + ] + +compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv +compilerTemplateEnv compiler = + [(CompilerVar, PathTemplate [Ordinary $ display (compilerInfoId compiler)]) + ] + +platformTemplateEnv :: Platform -> PathTemplateEnv +platformTemplateEnv (Platform arch os) = + [(OSVar, PathTemplate [Ordinary $ display os]) + ,(ArchVar, PathTemplate [Ordinary $ display arch]) + ] + +abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv +abiTemplateEnv compiler (Platform arch os) = + [(AbiVar, PathTemplate [Ordinary $ display arch ++ '-':display os ++ + '-':display (compilerInfoId compiler) ++ + case compilerInfoAbiTag compiler of + NoAbiTag -> "" + AbiTag tag -> '-':tag]) + ,(AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)]) + ] + +installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv +installDirsTemplateEnv dirs = + [(PrefixVar, prefix dirs) + ,(BindirVar, bindir dirs) + ,(LibdirVar, libdir dirs) + ,(LibsubdirVar, libsubdir dirs) + ,(DatadirVar, datadir dirs) + ,(DatasubdirVar, datasubdir dirs) + ,(DocdirVar, docdir dirs) + ,(HtmldirVar, htmldir dirs) + ] + + +-- --------------------------------------------------------------------------- +-- Parsing and showing path templates: + +-- The textual format is that of an ordinary Haskell String, eg +-- "$prefix/bin" +-- and this gets parsed to the internal representation as a sequence of path +-- spans which are either strings or variables, eg: +-- PathTemplate [Variable PrefixVar, Ordinary "/bin" ] + +instance Show PathTemplateVariable where + show PrefixVar = "prefix" + show PkgKeyVar = "pkgkey" + show BindirVar = "bindir" + show LibdirVar = "libdir" + show LibsubdirVar = "libsubdir" + show DatadirVar = "datadir" + show DatasubdirVar = "datasubdir" + show DocdirVar = "docdir" + show HtmldirVar = "htmldir" + show PkgNameVar = "pkg" + show PkgVerVar = "version" + show PkgIdVar = "pkgid" + show CompilerVar = "compiler" + show OSVar = "os" + show ArchVar = "arch" + show AbiTagVar = "abitag" + show AbiVar = "abi" + show ExecutableNameVar = "executablename" + show TestSuiteNameVar = "test-suite" + show TestSuiteResultVar = "result" + show BenchmarkNameVar = "benchmark" + +instance Read PathTemplateVariable where + readsPrec _ s = + take 1 + [ (var, drop (length varStr) s) + | (varStr, var) <- vars + , varStr `isPrefixOf` s ] + -- NB: order matters! Longer strings first + where vars = [("prefix", PrefixVar) + ,("bindir", BindirVar) + ,("libdir", LibdirVar) + ,("libsubdir", LibsubdirVar) + ,("datadir", DatadirVar) + ,("datasubdir", DatasubdirVar) + ,("docdir", DocdirVar) + ,("htmldir", HtmldirVar) + ,("pkgid", PkgIdVar) + ,("pkgkey", PkgKeyVar) + ,("pkg", PkgNameVar) + ,("version", PkgVerVar) + ,("compiler", CompilerVar) + ,("os", OSVar) + ,("arch", ArchVar) + ,("abitag", AbiTagVar) + ,("abi", AbiVar) + ,("executablename", ExecutableNameVar) + ,("test-suite", TestSuiteNameVar) + ,("result", TestSuiteResultVar) + ,("benchmark", BenchmarkNameVar)] + +instance Show PathComponent where + show (Ordinary path) = path + show (Variable var) = '$':show var + showList = foldr (\x -> (shows x .)) id + +instance Read PathComponent where + -- for some reason we collapse multiple $ symbols here + readsPrec _ = lex0 + where lex0 [] = [] + lex0 ('$':'$':s') = lex0 ('$':s') + lex0 ('$':s') = case [ (Variable var, s'') + | (var, s'') <- reads s' ] of + [] -> lex1 "$" s' + ok -> ok + lex0 s' = lex1 [] s' + lex1 "" "" = [] + lex1 acc "" = [(Ordinary (reverse acc), "")] + lex1 acc ('$':'$':s) = lex1 acc ('$':s) + lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)] + lex1 acc (c:s) = lex1 (c:acc) s + readList [] = [([],"")] + readList s = [ (component:components, s'') + | (component, s') <- reads s + , (components, s'') <- readList s' ] + +instance Show PathTemplate where + show (PathTemplate template) = show (show template) + +instance Read PathTemplate where + readsPrec p s = [ (PathTemplate template, s') + | (path, s') <- readsPrec p s + , (template, "") <- reads path ] + +-- --------------------------------------------------------------------------- +-- Internal utilities + +getWindowsProgramFilesDir :: IO FilePath +getWindowsProgramFilesDir = do +#if mingw32_HOST_OS + m <- shGetFolderPath csidl_PROGRAM_FILES +#else + let m = Nothing +#endif + return (fromMaybe "C:\\Program Files" m) + +#if mingw32_HOST_OS +shGetFolderPath :: CInt -> IO (Maybe FilePath) +shGetFolderPath n = + allocaArray long_path_size $ \pPath -> do + r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath + if (r /= 0) + then return Nothing + else do s <- peekCWString pPath; return (Just s) + where + long_path_size = 1024 -- MAX_PATH is 260, this should be plenty + +csidl_PROGRAM_FILES :: CInt +csidl_PROGRAM_FILES = 0x0026 +-- csidl_PROGRAM_FILES_COMMON :: CInt +-- csidl_PROGRAM_FILES_COMMON = 0x002b + +#ifdef x86_64_HOST_ARCH +#define CALLCONV ccall +#else +#define CALLCONV stdcall +#endif + +foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW" + c_SHGetFolderPath :: Ptr () + -> CInt + -> Ptr () + -> CInt + -> CWString + -> IO CInt +#endif diff --git a/Distribution/Simple/JHC.hs b/Distribution/Simple/JHC.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/JHC.hs @@ -0,0 +1,196 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.JHC +-- Copyright : Isaac Jones 2003-2006 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains most of the JHC-specific code for configuring, building +-- and installing packages. + +module Distribution.Simple.JHC ( + configure, getInstalledPackages, + buildLib, buildExe, + installLib, installExe + ) where + +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..), Executable(..) + , Library(..), libModules, hcOptions, usedExtensions ) +import Distribution.InstalledPackageInfo + ( emptyInstalledPackageInfo, ) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.Simple.PackageIndex (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 Distribution.Compat.ReadP + ( readP_to_S, string, skipSpaces ) +import Distribution.System ( Platform ) + +import Data.List ( nub ) +import Data.Char ( isSpace ) +import qualified Data.Map as M ( empty ) +import Data.Maybe ( fromMaybe ) + +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 + + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (jhcProg, _, conf') <- requireProgramVersion verbosity + jhcProgram (orLaterVersion (Version [0,7,2] [])) + (userMaybeSpecifyPath "jhc" hcPath conf) + + let Just version = programVersion jhcProg + comp = Compiler { + compilerId = CompilerId JHC version, + compilerAbiTag = NoAbiTag, + compilerCompat = [], + compilerLanguages = jhcLanguages, + compilerExtensions = jhcLanguageExtensions, + compilerProperties = M.empty + } + compPlatform = Nothing + return (comp, compPlatform, conf') + +jhcLanguages :: [(Language, Flag)] +jhcLanguages = [(Haskell98, "")] + +-- | The flags for the supported extensions +jhcLanguageExtensions :: [(Extension, Flag)] +jhcLanguageExtensions = + [(EnableExtension TypeSynonymInstances , "") + ,(DisableExtension TypeSynonymInstances , "") + ,(EnableExtension ForeignFunctionInterface , "") + ,(DisableExtension ForeignFunctionInterface , "") + ,(EnableExtension ImplicitPrelude , "") -- Wrong + ,(DisableExtension ImplicitPrelude , "--noprelude") + ,(EnableExtension CPP , "-fcpp") + ,(DisableExtension CPP , "-fno-cpp") + ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO InstalledPackageIndex +getInstalledPackages verbosity _packageDBs conf = do + -- jhc --list-libraries lists all available libraries. + -- How shall I find out, whether they are global or local + -- without checking all files and locations? + str <- rawSystemProgramStdoutConf verbosity jhcProgram conf ["--list-libraries"] + let pCheck :: [(a, String)] -> [a] + pCheck rs = [ r | (r,s) <- rs, all isSpace s ] + let parseLine ln = + pCheck (readP_to_S + (skipSpaces >> string "Name:" >> skipSpaces >> parse) ln) + return $ + PackageIndex.fromList $ + map (\p -> emptyInstalledPackageInfo { + InstalledPackageInfo.installedPackageId = + InstalledPackageId (display p), + InstalledPackageInfo.sourcePackageId = p + }) $ + concatMap parseLine $ + lines str + +-- ----------------------------------------------------------------------------- +-- Building + +-- | Building a package for JHC. +-- Currently C source files are not supported. +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) + let libBi = libBuildInfo lib + let args = constructJHCCmdLine lbi libBi clbi (buildDir lbi) verbosity + let pkgid = display (packageId pkg_descr) + pfile = buildDir lbi "jhc-pkg.conf" + hlfile= buildDir lbi (pkgid ++ ".hl") + writeFileAtomic pfile . BS.Char8.pack $ jhcPkgConf pkg_descr + rawSystemProgram verbosity jhcProg $ + ["--build-hl="++pfile, "-o", hlfile] ++ + args ++ map display (libModules lib) + +-- | Building an executable for JHC. +-- Currently C source files are not supported. +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi exe clbi = do + let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) + let exeBi = buildInfo exe + let out = buildDir lbi exeName exe + let args = constructJHCCmdLine lbi exeBi clbi (buildDir lbi) verbosity + rawSystemProgram verbosity jhcProg (["-o",out] ++ args ++ [modulePath exe]) + +constructJHCCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> Verbosity -> [String] +constructJHCCmdLine lbi bi clbi _odir verbosity = + (if verbosity >= deafening then ["-v"] else []) + ++ hcOptions JHC bi + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + ++ ["--noauto","-i-"] + ++ concat [["-i", l] | l <- nub (hsSourceDirs bi)] + ++ ["-i", autogenModulesDir lbi] + ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] + -- It would be better if JHC would accept package names with versions, + -- but JHC-0.7.2 doesn't accept this. + -- Thus, we have to strip the version with 'pkgName'. + ++ (concat [ ["-p", display (pkgName pkgid)] + | (_, pkgid) <- componentPackageDeps clbi ]) + +jhcPkgConf :: PackageDescription -> String +jhcPkgConf pd = + let sline name sel = name ++ ": "++sel pd + lib = fromMaybe (error "no library available") . library + comma = intercalate "," . map display + in unlines [sline "name" (display . pkgName . packageId) + ,sline "version" (display . pkgVersion . packageId) + ,sline "exposed-modules" (comma . PD.exposedModules . lib) + ,sline "hidden-modules" (comma . otherModules . libBuildInfo . lib) + ] + +installLib :: Verbosity -> FilePath -> FilePath -> PackageDescription -> Library -> IO () +installLib verb dest build_dir pkg_descr _ = do + let p = display (packageId pkg_descr)++".hl" + createDirectoryIfMissingVerbose verb True dest + installOrdinaryFile verb (build_dir p) (dest p) + +installExe :: Verbosity -> FilePath -> FilePath -> (FilePath,FilePath) -> PackageDescription -> Executable -> IO () +installExe verb dest build_dir (progprefix,progsuffix) _ exe = do + let exe_name = exeName exe + src = exe_name exeExtension + out = (progprefix ++ exe_name ++ progsuffix) exeExtension + createDirectoryIfMissingVerbose verb True dest + installExecutableFile verb (build_dir src) (dest out) diff --git a/Distribution/Simple/LHC.hs b/Distribution/Simple/LHC.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/LHC.hs @@ -0,0 +1,803 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.LHC +-- Copyright : Isaac Jones 2003-2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is a fairly large module. It contains most of the GHC-specific code for +-- configuring, building and installing packages. It also exports a function +-- for finding out what packages are already installed. Configuring involves +-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions +-- this version of ghc supports and returning a 'Compiler' value. +-- +-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out +-- what packages are installed. +-- +-- Building is somewhat complex as there is quite a bit of information to take +-- into account. We have to build libs and programs, possibly for profiling and +-- shared libs. We have to support building libraries that will be usable by +-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files +-- using ghc. Linking, especially for @split-objs@ is remarkably complex, +-- partly because there tend to be 1,000's of @.o@ files and this can often be +-- more than we can pass to the @ld@ or @ar@ programs in one go. +-- +-- Installing for libs and exes involves finding the right files and copying +-- them to the right places. One of the more tricky things about this module is +-- remembering the layout of files in the build directory (which is not +-- explicitly documented) and thus what search dirs are used for various kinds +-- of files. + +module Distribution.Simple.LHC ( + configure, getInstalledPackages, + buildLib, buildExe, + installLib, installExe, + registerPackage, + hcPkgInfo, + ghcOptions, + ghcVerbosityOptions + ) where + +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..), Executable(..) + , Library(..), libModules, hcOptions, hcProfOptions, hcSharedOptions + , usedExtensions, allExtensions ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo + , parseInstalledPackageInfo ) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo_(..) ) +import Distribution.Simple.PackageIndex +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.ParseUtils ( ParseResult(..) ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..), + 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 Language.Haskell.Extension + ( Language(Haskell98), Extension(..), KnownExtension(..) ) + +import Control.Monad ( unless, when ) +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 + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) +configure verbosity hcPath hcPkgPath conf = do + + (lhcProg, lhcVersion, conf') <- + requireProgramVersion verbosity lhcProgram + (orLaterVersion (Version [0,7] [])) + (userMaybeSpecifyPath "lhc" hcPath conf) + + (lhcPkgProg, lhcPkgVersion, conf'') <- + requireProgramVersion verbosity lhcPkgProgram + (orLaterVersion (Version [0,7] [])) + (userMaybeSpecifyPath "lhc-pkg" hcPkgPath conf') + + when (lhcVersion /= lhcPkgVersion) $ die $ + "Version mismatch between lhc and lhc-pkg: " + ++ programPath lhcProg ++ " is version " ++ display lhcVersion ++ " " + ++ programPath lhcPkgProg ++ " is version " ++ display lhcPkgVersion + + languages <- getLanguages verbosity lhcProg + extensions <- getExtensions verbosity lhcProg + + let comp = Compiler { + compilerId = CompilerId LHC lhcVersion, + compilerAbiTag = NoAbiTag, + compilerCompat = [], + compilerLanguages = languages, + compilerExtensions = extensions, + compilerProperties = M.empty + } + conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld + compPlatform = Nothing + return (comp, compPlatform, conf''') + +-- | Adjust the way we find and configure gcc and ld +-- +configureToolchain :: ConfiguredProgram -> ProgramConfiguration + -> ProgramConfiguration +configureToolchain lhcProg = + addKnownProgram gccProgram { + programFindLocation = findProg gccProgram (baseDir "gcc.exe"), + programPostConf = configureGcc + } + . addKnownProgram ldProgram { + programFindLocation = findProg ldProgram (libDir "ld.exe"), + programPostConf = configureLd + } + where + compilerDir = takeDirectory (programPath lhcProg) + baseDir = takeDirectory compilerDir + libDir = baseDir "gcc-lib" + includeDir = baseDir "include" "mingw" + isWindows = case buildOS of Windows -> True; _ -> False + + -- on Windows finding and configuring ghc's gcc and ld is a bit special + findProg :: Program -> FilePath + -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) + findProg prog location | isWindows = \verbosity searchpath -> do + exists <- doesFileExist location + if exists then return (Just location) + else do warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.") + programFindLocation prog verbosity searchpath + | otherwise = programFindLocation prog + + configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureGcc + | isWindows = \_ gccProg -> case programLocation gccProg of + -- if it's found on system then it means we're using the result + -- of programFindLocation above rather than a user-supplied path + -- that means we should add this extra flag to tell ghc's gcc + -- where it lives and thus where gcc can find its various files: + FoundOnSystem {} -> return gccProg { + programDefaultArgs = ["-B" ++ libDir, + "-I" ++ includeDir] + } + UserSpecified {} -> return gccProg + | otherwise = \_ gccProg -> return gccProg + + -- we need to find out if ld supports the -x flag + configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd verbosity ldProg = do + tempDir <- getTemporaryDirectory + ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> + withTempFile tempDir ".o" $ \testofile testohnd -> do + hPutStrLn testchnd "int foo() { return 0; }" + hClose testchnd; hClose testohnd + rawSystemProgram verbosity lhcProg ["-c", testcfile, + "-o", testofile] + withTempFile tempDir ".o" $ \testofile' testohnd' -> + do + hClose testohnd' + _ <- rawSystemProgramStdout verbosity ldProg + ["-x", "-r", testofile, "-o", testofile'] + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + if ldx + then return ldProg { programDefaultArgs = ["-x"] } + else return ldProg + +getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)] +getLanguages _ _ = return [(Haskell98, "")] +--FIXME: does lhc support -XHaskell98 flag? from what version? + +getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] +getExtensions verbosity lhcProg = do + exts <- rawSystemStdout verbosity (programPath lhcProg) + ["--supported-languages"] + -- GHC has the annoying habit of inverting some of the extensions + -- so we have to try parsing ("No" ++ ghcExtensionName) first + let readExtension str = do + ext <- simpleParse ("No" ++ str) + case ext of + UnknownExtension _ -> simpleParse str + _ -> return ext + return $ [ (ext, "-X" ++ display ext) + | Just ext <- map readExtension (lines exts) ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO InstalledPackageIndex +getInstalledPackages verbosity packagedbs conf = do + checkPackageDbStack packagedbs + pkgss <- getInstalledPackages' lhcPkg verbosity packagedbs conf + let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss ] + return $! (mconcat indexes) + + where + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it + Just ghcProg = lookupProgram lhcProgram conf + Just lhcPkg = lookupProgram lhcPkgProgram conf + compilerDir = takeDirectory (programPath ghcProg) + topDir = takeDirectory compilerDir + +checkPackageDbStack :: PackageDBStack -> IO () +checkPackageDbStack (GlobalPackageDB:rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStack _ = + die $ "GHC.getInstalledPackages: the global package db must be " + ++ "specified first and cannot be specified multiple times" + +-- | Get the packages from specific PackageDBs, not cumulative. +-- +getInstalledPackages' :: ConfiguredProgram -> Verbosity + -> [PackageDB] -> ProgramConfiguration + -> IO [(PackageDB, [InstalledPackageInfo])] +getInstalledPackages' lhcPkg verbosity packagedbs conf + = + sequence + [ do str <- rawSystemProgramStdoutConf verbosity lhcPkgProgram conf + ["dump", packageDbGhcPkgFlag packagedb] + `catchExit` \_ -> die $ "ghc-pkg dump failed" + case parsePackages str of + Left ok -> return (packagedb, ok) + _ -> die "failed to parse output of 'ghc-pkg dump'" + | packagedb <- packagedbs ] + + where + parsePackages str = + let parsed = map parseInstalledPackageInfo (splitPkgs str) + in case [ msg | ParseFailed msg <- parsed ] of + [] -> Left [ pkg | ParseOk _ pkg <- parsed ] + msgs -> Right msgs + + splitPkgs :: String -> [String] + splitPkgs = map unlines . splitWith ("---" ==) . lines + where + splitWith :: (a -> Bool) -> [a] -> [[a]] + splitWith p xs = ys : case zs of + [] -> [] + _:ws -> splitWith p ws + where (ys,zs) = break p xs + + packageDbGhcPkgFlag GlobalPackageDB = "--global" + packageDbGhcPkgFlag UserPackageDB = "--user" + packageDbGhcPkgFlag (SpecificPackageDB path) = "--" ++ packageDbFlag ++ "=" ++ path + + packageDbFlag + | programVersion lhcPkg < Just (Version [7,5] []) + = "package-conf" + | otherwise + = "package-db" + + +substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo +substTopDir topDir ipo + = ipo { + InstalledPackageInfo.importDirs + = map f (InstalledPackageInfo.importDirs ipo), + InstalledPackageInfo.libraryDirs + = map f (InstalledPackageInfo.libraryDirs ipo), + InstalledPackageInfo.includeDirs + = map f (InstalledPackageInfo.includeDirs ipo), + InstalledPackageInfo.frameworkDirs + = map f (InstalledPackageInfo.frameworkDirs ipo), + InstalledPackageInfo.haddockInterfaces + = map f (InstalledPackageInfo.haddockInterfaces ipo), + InstalledPackageInfo.haddockHTMLs + = map f (InstalledPackageInfo.haddockHTMLs ipo) + } + where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest + f x = x + +-- ----------------------------------------------------------------------------- +-- Building + +-- | Build a library with LHC. +-- +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + libName <- case componentLibraries clbi of + [libName] -> return libName + [] -> die "No library name found when building library" + _ -> die "Multiple library names found when building library" + + let pref = buildDir lbi + pkgid = packageId pkg_descr + runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) + ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) + ifProfLib = when (withProfLib lbi) + ifSharedLib = when (withSharedLib lbi) + ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) + + libBi <- hackThreadedFlag verbosity + (compiler lbi) (withProfLib lbi) (libBuildInfo lib) + + let libTargetDir = pref + forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi + -- TH always needs vanilla libs, even when building for profiling + + createDirectoryIfMissingVerbose verbosity True libTargetDir + -- TODO: do we need to put hs-boot files into place for mutually recursive modules? + let ghcArgs = + ["-package-name", display pkgid ] + ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity + ++ map display (libModules lib) + lhcWrap x = ["--build-library", "--ghc-opts=" ++ unwords x] + ghcArgsProf = ghcArgs + ++ ["-prof", + "-hisuf", "p_hi", + "-osuf", "p_o" + ] + ++ hcProfOptions GHC libBi + ghcArgsShared = ghcArgs + ++ ["-dynamic", + "-hisuf", "dyn_hi", + "-osuf", "dyn_o", "-fPIC" + ] + ++ hcSharedOptions GHC libBi + unless (null (libModules lib)) $ + do ifVanillaLib forceVanillaLib (runGhcProg $ lhcWrap ghcArgs) + ifProfLib (runGhcProg $ lhcWrap ghcArgsProf) + ifSharedLib (runGhcProg $ lhcWrap ghcArgsShared) + + -- build any C sources + unless (null (cSources libBi)) $ do + info verbosity "Building C Sources..." + sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref + filename verbosity + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg args + ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"])) + | filename <- cSources libBi] + + -- link: + info verbosity "Linking..." + let cObjs = map (`replaceExtension` objExtension) (cSources libBi) + cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) + cid = compilerId (compiler lbi) + vanillaLibFilePath = libTargetDir mkLibName libName + profileLibFilePath = libTargetDir mkProfLibName libName + sharedLibFilePath = libTargetDir mkSharedLibName cid libName + ghciLibFilePath = libTargetDir mkGHCiLibName libName + + stubObjs <- fmap catMaybes $ sequence + [ findFileWithExtension [objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + stubProfObjs <- fmap catMaybes $ sequence + [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + stubSharedObjs <- fmap catMaybes $ sequence + [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + + hObjs <- getHaskellObjects lib lbi + pref objExtension True + hProfObjs <- + if (withProfLib lbi) + then getHaskellObjects lib lbi + pref ("p_" ++ objExtension) True + else return [] + hSharedObjs <- + if (withSharedLib lbi) + then getHaskellObjects lib lbi + pref ("dyn_" ++ objExtension) False + else return [] + + unless (null hObjs && null cObjs && null stubObjs) $ do + -- first remove library files if they exists + sequence_ + [ removeFile libFilePath `catchIO` \_ -> return () + | libFilePath <- [vanillaLibFilePath, profileLibFilePath + ,sharedLibFilePath, ghciLibFilePath] ] + + let arVerbosity | verbosity >= deafening = "v" + | verbosity >= normal = "" + | otherwise = "c" + arArgs = ["q"++ arVerbosity] + ++ [vanillaLibFilePath] + arObjArgs = + hObjs + ++ map (pref ) cObjs + ++ stubObjs + arProfArgs = ["q"++ arVerbosity] + ++ [profileLibFilePath] + arProfObjArgs = + hProfObjs + ++ map (pref ) cObjs + ++ stubProfObjs + ldArgs = ["-r"] + ++ ["-o", ghciLibFilePath <.> "tmp"] + ldObjArgs = + hObjs + ++ map (pref ) cObjs + ++ stubObjs + ghcSharedObjArgs = + hSharedObjs + ++ map (pref ) cSharedObjs + ++ stubSharedObjs + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs = + [ "-no-auto-link-packages", + "-shared", + "-dynamic", + "-o", sharedLibFilePath ] + ++ ghcSharedObjArgs + ++ ["-package-name", display pkgid ] + ++ ghcPackageFlags lbi clbi + ++ ["-l"++extraLib | extraLib <- extraLibs libBi] + ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi] + + runLd ldLibName args = do + exists <- doesFileExist ldLibName + -- This method is called iteratively by xargs. The + -- output goes to .tmp, and any existing file + -- named is included when linking. The + -- output is renamed to . + rawSystemProgramConf verbosity ldProgram (withPrograms lbi) + (args ++ if exists then [ldLibName] else []) + renameFile (ldLibName <.> "tmp") ldLibName + + runAr = rawSystemProgramConf verbosity arProgram (withPrograms lbi) + + --TODO: discover this at configure time or runtime on Unix + -- The value is 32k on Windows and POSIX specifies a minimum of 4k + -- but all sensible Unixes use more than 4k. + -- we could use getSysVar ArgumentLimit but that's in the Unix lib + maxCommandLineSize = 30 * 1024 + + ifVanillaLib False $ xargs maxCommandLineSize + runAr arArgs arObjArgs + + ifProfLib $ xargs maxCommandLineSize + runAr arProfArgs arProfObjArgs + + ifGHCiLib $ xargs maxCommandLineSize + (runLd ghciLibFilePath) ldArgs ldObjArgs + + ifSharedLib $ runGhcProg ghcSharedLinkArgs + + +-- | Build an executable with LHC. +-- +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi + exe@Executable { exeName = exeName', modulePath = modPath } clbi = do + let pref = buildDir lbi + runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) + + exeBi <- hackThreadedFlag verbosity + (compiler lbi) (withProfExe lbi) (buildInfo exe) + + -- exeNameReal, the name that GHC really uses (with .exe on Windows) + let exeNameReal = exeName' <.> + (if null $ takeExtension exeName' then exeExtension else "") + + let targetDir = pref exeName' + let exeDir = targetDir (exeName' ++ "-tmp") + createDirectoryIfMissingVerbose verbosity True targetDir + createDirectoryIfMissingVerbose verbosity True exeDir + -- TODO: do we need to put hs-boot files into place for mutually recursive modules? + -- FIX: what about exeName.hi-boot? + + -- build executables + unless (null (cSources exeBi)) $ do + info verbosity "Building C Sources." + sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi + exeDir filename verbosity + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg args + | filename <- cSources exeBi] + + srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath + + let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) + let lhcWrap x = ("--ghc-opts\"":x) ++ ["\""] + let binArgs linkExe profExe = + (if linkExe + then ["-o", targetDir exeNameReal] + else ["-c"]) + ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity + ++ [exeDir x | x <- cObjs] + ++ [srcMainFile] + ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi] + ++ ["-l"++lib | lib <- extraLibs exeBi] + ++ ["-L"++libDir | libDir <- extraLibDirs exeBi] + ++ concat [["-framework", f] | f <- PD.frameworks exeBi] + ++ if profExe + then ["-prof", + "-hisuf", "p_hi", + "-osuf", "p_o" + ] ++ hcProfOptions GHC exeBi + else [] + + -- For building exe's for profiling that use TH we actually + -- have to build twice, once without profiling and the again + -- with profiling. This is because the code that TH needs to + -- run at compile time needs to be the vanilla ABI so it can + -- be loaded up and run by the compiler. + when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi) + (runGhcProg $ lhcWrap (binArgs False False)) + + runGhcProg (binArgs True (withProfExe lbi)) + +-- | Filter the "-threaded" flag when profiling as it does not +-- work with ghc-6.8 and older. +hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo +hackThreadedFlag verbosity comp prof bi + | not mustFilterThreaded = return bi + | otherwise = do + warn verbosity $ "The ghc flag '-threaded' is not compatible with " + ++ "profiling in ghc-6.8 and older. It will be disabled." + return bi { options = filterHcOptions (/= "-threaded") (options bi) } + where + mustFilterThreaded = prof && compilerVersion comp < Version [6, 10] [] + && "-threaded" `elem` hcOptions GHC bi + filterHcOptions p hcoptss = + [ (hc, if hc == GHC then filter p opts else opts) + | (hc, opts) <- hcoptss ] + +-- when using -split-objs, we need to search for object files in the +-- Module_split directory for each module. +getHaskellObjects :: Library -> LocalBuildInfo + -> FilePath -> String -> Bool -> IO [FilePath] +getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs + | splitObjs lbi && allow_split_objs = do + let dirs = [ pref (ModuleName.toFilePath x ++ "_split") + | x <- libModules lib ] + objss <- mapM getDirectoryContents dirs + let objs = [ dir obj + | (objs',dir) <- zip objss dirs, obj <- objs', + let obj_ext = takeExtension obj, + '.':wanted_obj_ext == obj_ext ] + return objs + | otherwise = + return [ pref ModuleName.toFilePath x <.> wanted_obj_ext + | x <- libModules lib ] + + +constructGHCCmdLine + :: LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> Verbosity + -> [String] +constructGHCCmdLine lbi bi clbi odir verbosity = + ["--make"] + ++ ghcVerbosityOptions verbosity + -- Unsupported extensions have already been checked by configure + ++ ghcOptions lbi bi clbi odir + +ghcVerbosityOptions :: Verbosity -> [String] +ghcVerbosityOptions verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-w", "-v0"] + +ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> [String] +ghcOptions lbi bi clbi odir + = ["-hide-all-packages"] + ++ ghcPackageDbOptions lbi + ++ (if splitObjs lbi then ["-split-objs"] else []) + ++ ["-i"] + ++ ["-i" ++ odir] + ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ autogenModulesDir lbi] + ++ ["-I" ++ autogenModulesDir lbi] + ++ ["-I" ++ odir] + ++ ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ ["-optP" ++ opt | opt <- cppOptions bi] + ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] + ++ [ "-#include \"" ++ inc ++ "\"" | inc <- PD.includes bi ] + ++ [ "-odir", odir, "-hidir", odir ] + ++ (if compilerVersion c >= Version [6,8] [] + then ["-stubdir", odir] else []) + ++ ghcPackageFlags lbi clbi + ++ (case withOptimization lbi of + NoOptimisation -> [] + NormalOptimisation -> ["-O"] + MaximumOptimisation -> ["-O2"]) + ++ hcOptions GHC bi + ++ languageToFlags c (defaultLanguage bi) + ++ extensionsToFlags c (usedExtensions bi) + where c = compiler lbi + +ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String] +ghcPackageFlags lbi clbi + | ghcVer >= Version [6,11] [] + = concat [ ["-package-id", display ipkgid] + | (ipkgid, _) <- componentPackageDeps clbi ] + + | otherwise = concat [ ["-package", display pkgid] + | (_, pkgid) <- componentPackageDeps clbi ] + where + ghcVer = compilerVersion (compiler lbi) + +ghcPackageDbOptions :: LocalBuildInfo -> [String] +ghcPackageDbOptions lbi = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> ("-no-user-" ++ packageDbFlag) + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ '-':packageDbFlag, db ] + specific _ = ierror + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + + dbstack = withPackageDB lbi + packageDbFlag + | compilerVersion (compiler lbi) < Version [7,5] [] + = "package-conf" + | otherwise + = "package-db" + +constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath -> Verbosity -> (FilePath,[String]) +constructCcCmdLine lbi bi clbi pref filename verbosity + = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref + | otherwise = pref takeDirectory filename + -- ghc 6.4.1 fixed a bug in -odir handling + -- for C compilations. + in + (odir, + ghcCcOptions lbi bi clbi odir + ++ (if verbosity >= deafening then ["-v"] else []) + ++ ["-c",filename]) + + +ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> [String] +ghcCcOptions lbi bi clbi odir + = ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ ghcPackageDbOptions lbi + ++ ghcPackageFlags lbi clbi + ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] + ++ (case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-optc-O2"]) + ++ ["-odir", odir] + +mkGHCiLibName :: LibraryName -> String +mkGHCiLibName (LibraryName lib) = lib <.> "o" + +-- ----------------------------------------------------------------------------- +-- Installing + +-- |Install executables for GHC. +installExe :: Verbosity + -> LocalBuildInfo + -> InstallDirs FilePath -- ^Where to copy the files to + -> FilePath -- ^Build location + -> (FilePath, FilePath) -- ^Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do + let binDir = bindir installDirs + createDirectoryIfMissingVerbose verbosity True binDir + let exeFileName = exeName exe <.> exeExtension + fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix + installBinary dest = do + installExecutableFile verbosity + (buildPref exeName exe exeFileName) + (dest <.> exeExtension) + stripExe verbosity lbi exeFileName (dest <.> exeExtension) + installBinary (binDir fixedExeBaseName) + +stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () +stripExe verbosity lbi name path = when (stripExes lbi) $ + case lookupProgram stripProgram (withPrograms lbi) of + Just strip -> rawSystemProgram verbosity strip args + Nothing -> unless (buildOS == Windows) $ + -- Don't bother warning on windows, we don't expect them to + -- have the strip program anyway. + warn verbosity $ "Unable to strip executable '" ++ name + ++ "' (missing the 'strip' program)" + where + args = path : case buildOS of + OSX -> ["-x"] -- By default, stripping the ghc binary on at least + -- some OS X installations causes: + -- HSbase-3.0.o: unknown symbol `_environ'" + -- The -x flag fixes that. + _ -> [] + +-- |Install for ghc, .hi, .a and, if --with-ghci given, .o +installLib :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^install location + -> FilePath -- ^install location for dynamic libraries + -> FilePath -- ^Build location + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do + -- copy .hi files over: + let copy src dst n = do + createDirectoryIfMissingVerbose verbosity True dst + installOrdinaryFile verbosity (src n) (dst n) + copyModuleFiles ext = + findModuleFiles [builtDir] [ext] (libModules lib) + >>= installOrdinaryFiles verbosity targetDir + ifVanilla $ copyModuleFiles "hi" + ifProf $ copyModuleFiles "p_hi" + hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (libModules lib) + flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase srcFile] + + -- copy the built library files over: + ifVanilla $ mapM_ (copy builtDir targetDir) vanillaLibNames + ifProf $ mapM_ (copy builtDir targetDir) profileLibNames + ifGHCi $ mapM_ (copy builtDir targetDir) ghciLibNames + ifShared $ mapM_ (copy builtDir dynlibTargetDir) sharedLibNames + + 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 + + hasLib = not $ null (libModules lib) + && null (cSources (libBuildInfo lib)) + ifVanilla = when (hasLib && withVanillaLib lbi) + ifProf = when (hasLib && withProfLib lbi) + ifGHCi = when (hasLib && withGHCiLib lbi) + ifShared = when (hasLib && withSharedLib lbi) + + runLhc = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = + HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity packageDbs + (Right installedPkgInfo) + +hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo +hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = lhcPkgProg + , HcPkg.noPkgDbStack = False + , HcPkg.noVerboseFlag = False + , HcPkg.flagPackageConf = False + , HcPkg.useSingleFileDb = True + } + where + Just lhcPkgProg = lookupProgram lhcPkgProgram conf diff --git a/Distribution/Simple/LocalBuildInfo.hs b/Distribution/Simple/LocalBuildInfo.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/LocalBuildInfo.hs @@ -0,0 +1,504 @@ +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.LocalBuildInfo +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Once a package has been configured we have resolved conditionals and +-- dependencies, configured the compiler and other needed external programs. +-- The 'LocalBuildInfo' is used to hold all this information. It holds the +-- install dirs, the compiler, the exact package dependencies, the configured +-- programs, the package database to use and a bunch of miscellaneous configure +-- flags. It gets saved and reloaded from a file (@dist\/setup-config@). It gets +-- passed in to very many subsequent build actions. + +module Distribution.Simple.LocalBuildInfo ( + LocalBuildInfo(..), + externalPackageDeps, + inplacePackageId, + + -- * Buildable package components + Component(..), + ComponentName(..), + showComponentName, + ComponentLocalBuildInfo(..), + LibraryName(..), + foldComponent, + componentName, + componentBuildInfo, + componentEnabled, + componentDisabledReason, + ComponentDisabledReason(..), + pkgComponents, + pkgEnabledComponents, + lookupComponent, + getComponent, + getComponentLocalBuildInfo, + allComponentsInBuildOrder, + componentsInBuildOrder, + checkComponentsCyclic, + depLibraryPaths, + + withAllComponentsInBuildOrder, + withComponentsInBuildOrder, + withComponentsLBI, + withLibLBI, + withExeLBI, + withTestLBI, + + -- * Installation directories + module Distribution.Simple.InstallDirs, + absoluteInstallDirs, prefixRelativeInstallDirs, + substPathTemplate + ) where + + +import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, + prefixRelativeInstallDirs, + substPathTemplate, ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.Program (ProgramConfiguration) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +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) +import Data.Graph +import Data.List (nub, find, stripPrefix) +import Data.Maybe +import Data.Tree (flatten) +import GHC.Generics (Generic) +import Data.Map (Map) + +import System.Directory (doesDirectoryExist, canonicalizePath) + +-- | Data cached after configuration step. See also +-- 'Distribution.Simple.Setup.ConfigFlags'. +data LocalBuildInfo = LocalBuildInfo { + configFlags :: ConfigFlags, + -- ^ Options passed to the configuration step. + -- Needed to re-run configuration when .cabal is out of date + extraConfigArgs :: [String], + -- ^ Extra args on the command line for the configuration step. + -- Needed to re-run configuration when .cabal is out of date + installDirTemplates :: InstallDirTemplates, + -- ^ The installation directories for the various different + -- kinds of files + --TODO: inplaceDirTemplates :: InstallDirs FilePath + compiler :: Compiler, + -- ^ The compiler we're building with + hostPlatform :: Platform, + -- ^ The platform we're building for + buildDir :: FilePath, + -- ^ Where to build the package. + componentsConfigs :: [(ComponentName, ComponentLocalBuildInfo, [ComponentName])], + -- ^ All the components to build, ordered by topological sort, and with their dependencies + -- over the intrapackage dependency graph + installedPkgs :: InstalledPackageIndex, + -- ^ All the info about the installed packages that the + -- current package depends on (directly or indirectly). + pkgDescrFile :: Maybe FilePath, + -- ^ the filename containing the .cabal file, if available + localPkgDescr :: PackageDescription, + -- ^ The resolved package description, that does not contain + -- any conditionals. + 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. + withProfLib :: Bool, -- ^Whether to build profiling versions of libs. + withSharedLib :: Bool, -- ^Whether to build shared versions of libs. + withDynExe :: Bool, -- ^Whether to link executables dynamically + withProfExe :: Bool, -- ^Whether to build executables for profiling. + withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). + withDebugInfo :: DebugInfoLevel, -- ^Whether to emit debug info (if available). + withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. + splitObjs :: Bool, -- ^Use -split-objs with GHC, if available + stripExes :: Bool, -- ^Whether to strip executables during install + stripLibs :: Bool, -- ^Whether to strip libraries during install + progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables + progSuffix :: PathTemplate, -- ^Suffix to be appended to installed executables + relocatable :: Bool -- ^Whether to build a relocatable package + } deriving (Generic, Read, Show) + +instance Binary LocalBuildInfo + +-- | External package dependencies for the package as a whole. This is the +-- union of the individual 'componentPackageDeps', less any internal deps. +externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)] +externalPackageDeps lbi = + -- TODO: what about non-buildable components? + nub [ (ipkgid, pkgid) + | (_,clbi,_) <- componentsConfigs lbi + , (ipkgid, pkgid) <- componentPackageDeps clbi + , not (internal pkgid) ] + where + -- True if this dependency is an internal one (depends on the library + -- defined in the same package). + internal pkgid = pkgid == packageId (localPkgDescr lbi) + +-- | The installed package Id we use for local packages registered in the local +-- package db. This is what is used for intra-package deps between components. +-- +inplacePackageId :: PackageId -> InstalledPackageId +inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace") + +-- ----------------------------------------------------------------------------- +-- Buildable components + +data Component = CLib Library + | CExe Executable + | CTest TestSuite + | CBench Benchmark + deriving (Show, Eq, Read) + +data ComponentName = CLibName -- currently only a single lib + | CExeName String + | CTestName String + | CBenchName String + deriving (Eq, Generic, Ord, Read, Show) + +instance Binary ComponentName + +showComponentName :: ComponentName -> String +showComponentName CLibName = "library" +showComponentName (CExeName name) = "executable '" ++ name ++ "'" +showComponentName (CTestName name) = "test suite '" ++ name ++ "'" +showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'" + +data ComponentLocalBuildInfo + = LibComponentLocalBuildInfo { + -- | Resolved internal and external package dependencies for this component. + -- The 'BuildInfo' specifies a set of build dependencies that must be + -- satisfied in terms of version ranges. This field fixes those dependencies + -- to the specific versions available on this machine for this compiler. + componentPackageDeps :: [(InstalledPackageId, PackageId)], + componentExposedModules :: [Installed.ExposedModule], + componentPackageRenaming :: Map PackageName ModuleRenaming, + componentLibraries :: [LibraryName] + } + | ExeComponentLocalBuildInfo { + componentPackageDeps :: [(InstalledPackageId, PackageId)], + componentPackageRenaming :: Map PackageName ModuleRenaming + } + | TestComponentLocalBuildInfo { + componentPackageDeps :: [(InstalledPackageId, PackageId)], + componentPackageRenaming :: Map PackageName ModuleRenaming + } + | BenchComponentLocalBuildInfo { + componentPackageDeps :: [(InstalledPackageId, PackageId)], + componentPackageRenaming :: Map PackageName ModuleRenaming + } + deriving (Generic, Read, Show) + +instance Binary ComponentLocalBuildInfo + +foldComponent :: (Library -> a) + -> (Executable -> a) + -> (TestSuite -> a) + -> (Benchmark -> a) + -> Component + -> a +foldComponent f _ _ _ (CLib lib) = f lib +foldComponent _ f _ _ (CExe exe) = f exe +foldComponent _ _ f _ (CTest tst) = f tst +foldComponent _ _ _ f (CBench bch) = f bch + +data LibraryName = LibraryName String + deriving (Generic, Read, Show) + +instance Binary LibraryName + +componentBuildInfo :: Component -> BuildInfo +componentBuildInfo = + foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo + +componentName :: Component -> ComponentName +componentName = + foldComponent (const CLibName) + (CExeName . exeName) + (CTestName . testName) + (CBenchName . benchmarkName) + +-- | All the components in the package (libs, exes, or test suites). +-- +pkgComponents :: PackageDescription -> [Component] +pkgComponents pkg = + [ CLib lib | Just lib <- [library pkg] ] + ++ [ CExe exe | exe <- executables pkg ] + ++ [ CTest tst | tst <- testSuites pkg ] + ++ [ CBench bm | bm <- benchmarks pkg ] + +-- | All the components in the package that are buildable and enabled. +-- Thus this excludes non-buildable components and test suites or benchmarks +-- that have been disabled. +-- +pkgEnabledComponents :: PackageDescription -> [Component] +pkgEnabledComponents = filter componentEnabled . pkgComponents + +componentEnabled :: Component -> Bool +componentEnabled = isNothing . componentDisabledReason + +data ComponentDisabledReason = DisabledComponent + | DisabledAllTests + | DisabledAllBenchmarks + +componentDisabledReason :: Component -> Maybe ComponentDisabledReason +componentDisabledReason (CLib lib) + | not (buildable (libBuildInfo lib)) = Just DisabledComponent +componentDisabledReason (CExe exe) + | not (buildable (buildInfo exe)) = Just DisabledComponent +componentDisabledReason (CTest tst) + | not (buildable (testBuildInfo tst)) = Just DisabledComponent + | not (testEnabled tst) = Just DisabledAllTests +componentDisabledReason (CBench bm) + | not (buildable (benchmarkBuildInfo bm)) = Just DisabledComponent + | not (benchmarkEnabled bm) = Just DisabledAllBenchmarks +componentDisabledReason _ = Nothing + +lookupComponent :: PackageDescription -> ComponentName -> Maybe Component +lookupComponent pkg CLibName = + fmap CLib $ library pkg +lookupComponent pkg (CExeName name) = + fmap CExe $ find ((name ==) . exeName) (executables pkg) +lookupComponent pkg (CTestName name) = + fmap CTest $ find ((name ==) . testName) (testSuites pkg) +lookupComponent pkg (CBenchName name) = + fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg) + +getComponent :: PackageDescription -> ComponentName -> Component +getComponent pkg cname = + case lookupComponent pkg cname of + Just cpnt -> cpnt + Nothing -> missingComponent + where + missingComponent = + error $ "internal error: the package description contains no " + ++ "component corresponding to " ++ show cname + + +getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo +getComponentLocalBuildInfo lbi cname = + case [ clbi + | (cname', clbi, _) <- componentsConfigs lbi + , cname == cname' ] of + [clbi] -> clbi + _ -> missingComponent + where + missingComponent = + error $ "internal error: there is no configuration data " + ++ "for component " ++ show cname + + +-- |If the package description has a library section, call the given +-- function with the library build info as argument. Extended version of +-- 'withLib' that also gives corresponding build info. +withLibLBI :: PackageDescription -> LocalBuildInfo + -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO () +withLibLBI pkg_descr lbi f = + withLib pkg_descr $ \lib -> + f lib (getComponentLocalBuildInfo lbi CLibName) + +-- | Perform the action on each buildable 'Executable' in the package +-- description. Extended version of 'withExe' that also gives corresponding +-- build info. +withExeLBI :: PackageDescription -> LocalBuildInfo + -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO () +withExeLBI pkg_descr lbi f = + withExe pkg_descr $ \exe -> + f exe (getComponentLocalBuildInfo lbi (CExeName (exeName exe))) + +withTestLBI :: PackageDescription -> LocalBuildInfo + -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO () +withTestLBI pkg_descr lbi f = + withTest pkg_descr $ \test -> + f test (getComponentLocalBuildInfo lbi (CTestName (testName test))) + +{-# DEPRECATED withComponentsLBI "Use withAllComponentsInBuildOrder" #-} +withComponentsLBI :: PackageDescription -> LocalBuildInfo + -> (Component -> ComponentLocalBuildInfo -> IO ()) + -> IO () +withComponentsLBI = withAllComponentsInBuildOrder + +-- | Perform the action on each buildable 'Library' or 'Executable' (Component) +-- in the PackageDescription, subject to the build order specified by the +-- 'compBuildOrder' field of the given 'LocalBuildInfo' +withAllComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo + -> (Component -> ComponentLocalBuildInfo -> IO ()) + -> IO () +withAllComponentsInBuildOrder pkg lbi f = + sequence_ + [ f (getComponent pkg cname) clbi + | (cname, clbi) <- allComponentsInBuildOrder lbi ] + +withComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo + -> [ComponentName] + -> (Component -> ComponentLocalBuildInfo -> IO ()) + -> IO () +withComponentsInBuildOrder pkg lbi cnames f = + sequence_ + [ f (getComponent pkg cname') clbi + | (cname', clbi) <- componentsInBuildOrder lbi cnames ] + +allComponentsInBuildOrder :: LocalBuildInfo + -> [(ComponentName, ComponentLocalBuildInfo)] +allComponentsInBuildOrder lbi = + componentsInBuildOrder lbi + [ cname | (cname, _, _) <- componentsConfigs lbi ] + +componentsInBuildOrder :: LocalBuildInfo -> [ComponentName] + -> [(ComponentName, ComponentLocalBuildInfo)] +componentsInBuildOrder lbi cnames = + map ((\(clbi,cname,_) -> (cname,clbi)) . vertexToNode) + . postOrder graph + . map (\cname -> fromMaybe (noSuchComp cname) (keyToVertex cname)) + $ cnames + where + (graph, vertexToNode, keyToVertex) = + graphFromEdges (map (\(a,b,c) -> (b,a,c)) (componentsConfigs lbi)) + + noSuchComp cname = error $ "internal error: componentsInBuildOrder: " + ++ "no such component: " ++ show cname + + postOrder :: Graph -> [Vertex] -> [Vertex] + postOrder g vs = postorderF (dfs g vs) [] + + postorderF :: Forest a -> [a] -> [a] + postorderF ts = foldr (.) id $ map postorderT ts + + postorderT :: Tree a -> [a] -> [a] + postorderT (Node a ts) = postorderF ts . (a :) + +checkComponentsCyclic :: Ord key => [(node, key, [key])] + -> Maybe [(node, key, [key])] +checkComponentsCyclic es = + let (graph, vertexToNode, _) = graphFromEdges es + cycles = [ flatten c | c <- scc graph, isCycle c ] + isCycle (Node v []) = selfCyclic v + isCycle _ = True + selfCyclic v = v `elem` graph ! v + in case cycles of + [] -> Nothing + (c:_) -> Just (map vertexToNode c) + +-- | Determine the directories containing the dynamic libraries of the +-- transitive dependencies of the component we are building. +-- +-- When wanted, and possible, returns paths relative to the installDirs 'prefix' +depLibraryPaths :: Bool -- ^ Building for inplace? + -> Bool -- ^ Generate prefix-relative library paths + -> LocalBuildInfo + -> ComponentLocalBuildInfo -- ^ Component that is being built + -> IO [FilePath] +depLibraryPaths inplace relative lbi clbi = do + let pkgDescr = localPkgDescr lbi + installDirs = absoluteInstallDirs pkgDescr lbi NoCopyDest + executable = case clbi of + ExeComponentLocalBuildInfo {} -> True + _ -> False + relDir | executable = bindir installDirs + | otherwise = libdir installDirs + + let hasInternalDeps = not $ null + $ [ pkgid + | (_,pkgid) <- componentPackageDeps clbi + , internal pkgid + ] + + let ipkgs = allPackages (installedPkgs lbi) + allDepLibDirs = concatMap Installed.libraryDirs ipkgs + internalLib + | inplace = buildDir lbi + | otherwise = libdir installDirs + allDepLibDirs' = if hasInternalDeps + then internalLib : allDepLibDirs + else allDepLibDirs + allDepLibDirsC <- mapM canonicalizePathNoFail allDepLibDirs' + + let p = prefix installDirs + prefixRelative l = isJust (stripPrefix p l) + libPaths + | relative && + prefixRelative relDir = map (\l -> + if prefixRelative l + then shortRelativePath relDir l + else l + ) allDepLibDirsC + | otherwise = allDepLibDirsC + + return libPaths + where + internal pkgid = pkgid == packageId (localPkgDescr lbi) + -- 'canonicalizePath' fails on UNIX when the directory does not exists. + -- So just don't canonicalize when it doesn't exist. + canonicalizePathNoFail p = do + exists <- doesDirectoryExist p + if exists + then canonicalizePath p + else return p + + +-- ----------------------------------------------------------------------------- +-- Wrappers for a couple functions from InstallDirs + +-- |See 'InstallDirs.absoluteInstallDirs' +absoluteInstallDirs :: PackageDescription -> LocalBuildInfo -> CopyDest + -> InstallDirs FilePath +absoluteInstallDirs pkg lbi copydest = + InstallDirs.absoluteInstallDirs + (packageId pkg) + (pkgKey lbi) + (compilerInfo (compiler lbi)) + copydest + (hostPlatform lbi) + (installDirTemplates lbi) + +-- |See 'InstallDirs.prefixRelativeInstallDirs' +prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo + -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs pkg_descr lbi = + InstallDirs.prefixRelativeInstallDirs + (packageId pkg_descr) + (pkgKey lbi) + (compilerInfo (compiler lbi)) + (hostPlatform lbi) + (installDirTemplates lbi) + +substPathTemplate :: PackageId -> LocalBuildInfo + -> PathTemplate -> FilePath +substPathTemplate pkgid lbi = fromPathTemplate + . ( InstallDirs.substPathTemplate env ) + where env = initialPathTemplateEnv + pkgid + (pkgKey lbi) + (compilerInfo (compiler lbi)) + (hostPlatform lbi) diff --git a/Distribution/Simple/PackageIndex.hs b/Distribution/Simple/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/PackageIndex.hs @@ -0,0 +1,695 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PackageIndex +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007, +-- Duncan Coutts 2008-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- An index of packages. +-- +module Distribution.Simple.PackageIndex ( + -- * Package index data type + InstalledPackageIndex, + PackageIndex, + FakeMap, + + -- * Creating an index + fromList, + + -- * Updates + merge, + + insert, + + deleteInstalledPackageId, + deleteSourcePackageId, + deletePackageName, +-- deleteDependency, + + -- * Queries + + -- ** Precise lookups + lookupInstalledPackageId, + lookupSourcePackageId, + lookupPackageId, + lookupPackageName, + lookupDependency, + + -- ** Case-insensitive searches + searchByName, + SearchResult(..), + searchByNameSubstring, + + -- ** Bulk queries + allPackages, + allPackagesByName, + allPackagesBySourcePackageId, + + -- ** Special queries + brokenPackages, + dependencyClosure, + reverseDependencyClosure, + topologicalOrder, + reverseTopologicalOrder, + dependencyInconsistencies, + dependencyCycles, + dependencyGraph, + moduleNameIndex, + + -- ** Variants of special queries supporting fake map + fakeLookupInstalledPackageId, + brokenPackages', + dependencyClosure', + reverseDependencyClosure', + dependencyInconsistencies', + dependencyCycles', + dependencyGraph', + ) where + +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 +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (isNothing, fromMaybe) +import qualified Data.Tree as Tree +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 +-- 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. + -- + !(Map InstalledPackageId a) + + -- This auxiliary index maps package names (case-sensitively) to all the + -- versions and instances of that package. This allows us to find all + -- versions satisfying a dependency. + -- + -- It is a three-level index. The first level is the package name, + -- the second is the package version and the final level is instances + -- of the same package version. These are unique by InstalledPackageId + -- and are kept in preference order. + -- + -- 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) + +instance Binary a => Binary (PackageIndex a) + +-- | The default package index which contains 'InstalledPackageInfo'. Normally +-- use this. +type InstalledPackageIndex = PackageIndex InstalledPackageInfo + +instance PackageInstalled a => Monoid (PackageIndex a) where + mempty = PackageIndex Map.empty Map.empty + mappend = merge + --save one mappend with empty in the common case: + mconcat [] = mempty + mconcat xs = foldr1 mappend xs + +invariant :: PackageInstalled a => PackageIndex a -> Bool +invariant (PackageIndex pids pnames) = + map installedPackageId (Map.elems pids) + == sort + [ assert pinstOk (installedPackageId pinst) + | (pname, pvers) <- Map.toList pnames + , let pversOk = not (Map.null pvers) + , (pver, pinsts) <- assert pversOk $ Map.toList pvers + , let pinsts' = sortBy (comparing installedPackageId) pinsts + pinstsOk = all (\g -> length g == 1) + (groupBy (equating installedPackageId) pinsts') + , pinst <- assert pinstsOk $ pinsts' + , let pinstOk = packageName pinst == pname + && packageVersion pinst == pver + ] + + +-- +-- * Internal helpers +-- + +mkPackageIndex :: PackageInstalled a + => Map InstalledPackageId a + -> Map PackageName (Map Version [a]) + -> PackageIndex a +mkPackageIndex pids pnames = assert (invariant index) index + where index = PackageIndex pids pnames + + +-- +-- * Construction +-- + +-- | Build an index out of a bunch of packages. +-- +-- If there are duplicates by 'InstalledPackageId' then later ones mask earlier +-- ones. +-- +fromList :: PackageInstalled a => [a] -> PackageIndex a +fromList pkgs = mkPackageIndex pids pnames + where + pids = Map.fromList [ (installedPackageId pkg, pkg) | pkg <- pkgs ] + pnames = + Map.fromList + [ (packageName (head pkgsN), pvers) + | pkgsN <- groupBy (equating packageName) + . sortBy (comparing packageId) + $ pkgs + , let pvers = + Map.fromList + [ (packageVersion (head pkgsNV), + nubBy (equating installedPackageId) (reverse pkgsNV)) + | pkgsNV <- groupBy (equating packageVersion) pkgsN + ] + ] + +-- +-- * Updates +-- + +-- | Merge two indexes. +-- +-- Packages from the second mask packages from the first if they have the exact +-- same 'InstalledPackageId'. +-- +-- For packages with the same source 'PackageId', packages from the second are +-- \"preferred\" over those from the first. Being preferred means they are top +-- result when we do a lookup by source 'PackageId'. This is the mechanism we +-- use to prefer user packages over global packages. +-- +merge :: PackageInstalled 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) + where + -- Packages in the second list mask those in the first, however preferred + -- packages go first in the list. + mergeBuckets xs ys = ys ++ (xs \\ ys) + (\\) = deleteFirstsBy (equating installedPackageId) + + +-- | Inserts a single package into the index. +-- +-- This is equivalent to (but slightly quicker than) using 'mappend' or +-- 'merge' with a singleton index. +-- +insert :: PackageInstalled a => a -> PackageIndex a -> PackageIndex a +insert pkg (PackageIndex pids pnames) = + mkPackageIndex pids' pnames' + + where + pids' = Map.insert (installedPackageId pkg) pkg pids + pnames' = insertPackageName pnames + insertPackageName = + Map.insertWith' (\_ -> insertPackageVersion) + (packageName pkg) + (Map.singleton (packageVersion pkg) [pkg]) + + insertPackageVersion = + Map.insertWith' (\_ -> insertPackageInstance) + (packageVersion pkg) [pkg] + + insertPackageInstance pkgs = + pkg : deleteBy (equating installedPackageId) pkg pkgs + + +-- | Removes a single installed package from the index. +-- +deleteInstalledPackageId :: PackageInstalled a => InstalledPackageId -> PackageIndex a -> PackageIndex a +deleteInstalledPackageId ipkgid original@(PackageIndex pids pnames) = + case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of + (Nothing, _) -> original + (Just spkgid, pids') -> mkPackageIndex pids' + (deletePkgName spkgid pnames) + + where + deletePkgName spkgid = + Map.update (deletePkgVersion spkgid) (packageName spkgid) + + deletePkgVersion spkgid = + (\m -> if Map.null m then Nothing else Just m) + . Map.update deletePkgInstance (packageVersion spkgid) + + deletePkgInstance = + (\xs -> if List.null xs then Nothing else Just xs) + . List.deleteBy (\_ pkg -> installedPackageId pkg == ipkgid) undefined + + +-- | Removes all packages with this source 'PackageId' from the index. +-- +deleteSourcePackageId :: PackageInstalled 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) + (deletePkgName pnames) + where + deletePkgName = + Map.update deletePkgVersion (packageName pkgid) + + deletePkgVersion = + (\m -> if Map.null m then Nothing else Just m) + . Map.delete (packageVersion pkgid) + + +-- | Removes all packages with this (case-sensitive) name from the index. +-- +deletePackageName :: PackageInstalled 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 + (concat (Map.elems pvers))) + (Map.delete name pnames) + +{- +-- | Removes all packages satisfying this dependency from the index. +-- +deleteDependency :: Dependency -> PackageIndex -> PackageIndex +deleteDependency (Dependency name verstionRange) = + delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange) +-} + +-- +-- * Bulk queries +-- + +-- | Get all the packages from the index. +-- +allPackages :: PackageIndex a -> [a] +allPackages (PackageIndex pids _) = Map.elems pids + +-- | Get all the packages from the index. +-- +-- They are grouped by package name (case-sensitively). +-- +allPackagesByName :: PackageIndex a -> [(PackageName, [a])] +allPackagesByName (PackageIndex _ pnames) = + [ (pkgname, concat (Map.elems pvers)) + | (pkgname, pvers) <- Map.toList pnames ] + +-- | Get all the packages from the index. +-- +-- They are grouped by source package id (package name and version). +-- +allPackagesBySourcePackageId :: PackageInstalled a => PackageIndex a -> [(PackageId, [a])] +allPackagesBySourcePackageId (PackageIndex _ pnames) = + [ (packageId ipkg, ipkgs) + | pvers <- Map.elems pnames + , ipkgs@(ipkg:_) <- Map.elems pvers ] + +-- +-- * Lookups +-- + +-- | Does a lookup by source package id (name & version). +-- +-- Since multiple package DBs mask each other by 'InstalledPackageId', +-- then we get back at most one package. +-- +lookupInstalledPackageId :: PackageIndex a -> InstalledPackageId + -> Maybe a +lookupInstalledPackageId (PackageIndex pids _) pid = Map.lookup pid pids + + +-- | Does a lookup by source package id (name & version). +-- +-- There can be multiple installed packages with the same source 'PackageId' +-- but different 'InstalledPackageId'. They are returned in order of +-- preference, with the most preferred first. +-- +lookupSourcePackageId :: PackageIndex a -> PackageId -> [a] +lookupSourcePackageId (PackageIndex _ pnames) pkgid = + case Map.lookup (packageName pkgid) pnames of + Nothing -> [] + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> [] + Just pkgs -> pkgs -- in preference order + +-- | Convenient alias of 'lookupSourcePackageId', but assuming only +-- one package per package ID. +lookupPackageId :: PackageIndex a -> PackageId -> Maybe a +lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of + [] -> Nothing + [pkg] -> Just pkg + _ -> error "Distribution.Simple.PackageIndex: multiple matches found" + +-- | Does a lookup by source package name. +-- +lookupPackageName :: PackageIndex a -> PackageName + -> [(Version, [a])] +lookupPackageName (PackageIndex _ pnames) name = + case Map.lookup name pnames of + Nothing -> [] + Just pvers -> Map.toList pvers + + +-- | Does a lookup by source package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +lookupDependency :: PackageIndex a -> Dependency + -> [(Version, [a])] +lookupDependency (PackageIndex _ pnames) (Dependency name versionRange) = + case Map.lookup name pnames of + Nothing -> [] + Just pvers -> [ entry + | entry@(ver, _) <- Map.toList pvers + , ver `withinRange` versionRange ] + +-- +-- * Case insensitive name lookups +-- + +-- | Does a case-insensitive search by package name. +-- +-- If there is only one package that compares case-insensitively to this name +-- then the search is unambiguous and we get back all versions of that package. +-- If several match case-insensitively but one matches exactly then it is also +-- unambiguous. +-- +-- If however several match case-insensitively and none match exactly then we +-- have an ambiguous result, and we get back all the versions of all the +-- packages. The list of ambiguous results is split by exact package name. So +-- it is a non-empty list of non-empty lists. +-- +searchByName :: PackageIndex a -> String -> SearchResult [a] +searchByName (PackageIndex _ pnames) name = + case [ pkgs | pkgs@(PackageName name',_) <- Map.toList pnames + , lowercase name' == lname ] of + [] -> None + [(_,pvers)] -> Unambiguous (concat (Map.elems pvers)) + pkgss -> case find ((PackageName name==) . fst) pkgss of + Just (_,pvers) -> Unambiguous (concat (Map.elems pvers)) + Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) + where lname = lowercase name + +data SearchResult a = None | Unambiguous a | Ambiguous [a] + +-- | Does a case-insensitive substring search by package name. +-- +-- That is, all packages that contain the given string in their name. +-- +searchByNameSubstring :: PackageIndex a -> String -> [a] +searchByNameSubstring (PackageIndex _ pnames) searchterm = + [ pkg + | (PackageName name, pvers) <- Map.toList pnames + , lsearchterm `isInfixOf` lowercase name + , pkgs <- Map.elems pvers + , pkg <- pkgs ] + where lsearchterm = lowercase searchterm + + +-- +-- * Special queries +-- + +-- None of the stuff below depends on the internal representation of the index. +-- + +-- | Find if there are any cycles in the dependency graph. If there are no +-- cycles the result is @[]@. +-- +-- This actually computes the strongly connected components. So it gives us a +-- list of groups of packages where within each group they all depend on each +-- other, directly or indirectly. +-- +dependencyCycles :: 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 = + [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] + where + adjacencyList = [ (pkg, installedPackageId pkg, fakeInstalledDepends fakeMap pkg) + | pkg <- allPackages index ] + + +-- | All packages that have immediate dependencies that are not in the index. +-- +-- Returns such packages along with the dependencies that they're missing. +-- +brokenPackages :: 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 = + [ (pkg, missing) + | pkg <- allPackages index + , let missing = [ pkg' | pkg' <- installedDepends pkg + , isNothing (fakeLookupInstalledPackageId fakeMap index pkg') ] + , not (null missing) ] + +-- | Variant of 'lookupInstalledPackageId' which accepts a 'FakeMap'. See Note [FakeMap]. +fakeLookupInstalledPackageId :: 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 +-- index. Otherwise it returns the broken packages as in 'brokenPackages'. +-- +-- * Note that if the result is @Right []@ it is because at least one of +-- the original given 'PackageId's do not occur in the index. +-- +dependencyClosure :: 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] + -> Either (PackageIndex a) + [(a, [InstalledPackageId])] +dependencyClosure' fakeMap 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 + Nothing -> closure completed (pkgid:failed) pkgids + Just pkg -> case fakeLookupInstalledPackageId fakeMap completed (installedPackageId pkg) of + Just _ -> closure completed failed pkgids + Nothing -> closure completed' failed pkgids' + where completed' = insert pkg completed + pkgids' = installedDepends pkg ++ pkgids + +-- | Takes the transitive closure of the packages reverse dependencies. +-- +-- * 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] + -> [a] +reverseDependencyClosure' fakeMap index = + map vertexToPkg + . concatMap Tree.flatten + . Graph.dfs reverseDepGraph + . map (fromMaybe noSuchPkgId . pkgIdToVertex) + + where + (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph' fakeMap index + reverseDepGraph = Graph.transposeG depGraph + noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" + +topologicalOrder :: PackageInstalled a => PackageIndex a -> [a] +topologicalOrder index = map toPkgId + . Graph.topSort + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +reverseTopologicalOrder :: PackageInstalled a => PackageIndex a -> [a] +reverseTopologicalOrder index = map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +-- | Builds a graph of the package dependencies. +-- +-- Dependencies on other packages that are not in the index are discarded. +-- You can check if there are any such dependencies with 'brokenPackages'. +-- +dependencyGraph :: 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) + 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..] + vertex_map = Map.fromList vertices + id_to_vertex pid = Map.lookup (Map.findWithDefault pid pid fakeMap) vertex_map + + vertex_to_pkg vertex = pkgTable ! vertex + + pkgTable = Array.listArray bounds pkgs + topBound = length pkgs - 1 + bounds = (0, topBound) + +-- | Given a package index where we assume we want to use all the packages +-- (use 'dependencyClosure' if you need to get such a index subset) find out +-- if the dependencies within it use consistent versions of each package. +-- Return all cases where multiple packages depend on different versions of +-- some other package. +-- +-- Each element in the result is a package name along with the packages that +-- depend on it and the versions they require. These are guaranteed to be +-- distinct. +-- +dependencyInconsistencies :: 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 = + [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids]) + | (name, ipid_map) <- Map.toList inverseIndex + , let uses = Map.elems ipid_map + , reallyIsInconsistent (map fst uses) ] + + where -- for each PackageName, + -- for each package with that name, + -- the InstalledPackageInfo and the package Ids of packages + -- that depend on it. + inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) + [ (packageName dep, + Map.fromList [(ipid,(dep,[packageId pkg]))]) + | pkg <- allPackages index + , ipid <- fakeInstalledDepends fakeMap pkg + , Just dep <- [fakeLookupInstalledPackageId fakeMap 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 + 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] +moduleNameIndex index = + Map.fromListWith (++) $ do + pkg <- allPackages index + IPI.ExposedModule m reexport _ <- IPI.exposedModules pkg + case reexport of + Nothing -> return (m, [pkg]) + Just (IPI.OriginalModule _ m') | m == m' -> [] + | otherwise -> return (m', [pkg]) + -- The heuristic is this: we want to prefer the original package + -- which originally exported a module. However, if a reexport + -- also *renamed* the module (m /= m'), then we have to use the + -- downstream package, since the upstream package has the wrong + -- module name! diff --git a/Distribution/Simple/PreProcess.hs b/Distribution/Simple/PreProcess.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/PreProcess.hs @@ -0,0 +1,622 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PreProcess +-- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines a 'PreProcessor' abstraction which represents a pre-processor +-- that can transform one kind of file into another. There is also a +-- 'PPSuffixHandler' which is a combination of a file extension and a function +-- for configuring a 'PreProcessor'. It defines a bunch of known built-in +-- preprocessors like @cpp@, @cpphs@, @c2hs@, @hsc2hs@, @happy@, @alex@ etc and +-- lists them in 'knownSuffixHandlers'. On top of this it provides a function +-- for actually preprocessing some sources given a bunch of known suffix +-- handlers. This module is not as good as it could be, it could really do with +-- a rewrite to address some of the problems we have with pre-processors. + +module Distribution.Simple.PreProcess (preprocessComponent, knownSuffixHandlers, + ppSuffixes, PPSuffixHandler, PreProcessor(..), + mkSimplePreProcessor, runSimplePreProcessor, + ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, + ppHappy, ppAlex, ppUnlit, platformDefines + ) + where + + +import Control.Monad +import Distribution.Simple.PreProcess.Unlit (unlit) +import Distribution.Package + ( Package(..), PackageName(..) ) +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..) + , Executable(..) + , Library(..), libModules + , TestSuite(..), testModules + , TestSuiteInterface(..) + , Benchmark(..), benchmarkModules, BenchmarkInterface(..) ) +import qualified Distribution.InstalledPackageInfo as Installed + ( InstalledPackageInfo_(..) ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.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.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 Data.Maybe (fromMaybe) +import Data.List (nub) +import System.Directory (doesFileExist) +import System.Info (os, arch) +import System.FilePath (splitExtension, dropExtensions, (), (<.>), + takeDirectory, normalise, replaceExtension) + +-- |The interface to a preprocessor, which may be implemented using an +-- external program, but need not be. The arguments are the name of +-- the input file, the name of the output file and a verbosity level. +-- Here is a simple example that merely prepends a comment to the given +-- source file: +-- +-- > ppTestHandler :: PreProcessor +-- > ppTestHandler = +-- > PreProcessor { +-- > platformIndependent = True, +-- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> +-- > do info verbosity (inFile++" has been preprocessed to "++outFile) +-- > stuff <- readFile inFile +-- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) +-- > return ExitSuccess +-- +-- We split the input and output file names into a base directory and the +-- rest of the file name. The input base dir is the path in the list of search +-- dirs that this file was found in. The output base dir is the build dir where +-- all the generated source files are put. +-- +-- The reason for splitting it up this way is that some pre-processors don't +-- simply generate one output .hs file from one input file but have +-- dependencies on other generated files (notably c2hs, where building one +-- .hs file may require reading other .chi files, and then compiling the .hs +-- file may require reading a generated .h file). In these cases the generated +-- files need to embed relative path names to each other (eg the generated .hs +-- file mentions the .h file in the FFI imports). This path must be relative to +-- the base directory where the generated files are located, it cannot be +-- relative to the top level of the build tree because the compilers do not +-- look for .h files relative to there, ie we do not use \"-I .\", instead we +-- use \"-I dist\/build\" (or whatever dist dir has been set by the user) +-- +-- Most pre-processors do not care of course, so mkSimplePreProcessor and +-- runSimplePreProcessor functions handle the simple case. +-- +data PreProcessor = PreProcessor { + + -- Is the output of the pre-processor platform independent? eg happy output + -- is portable haskell but c2hs's output is platform dependent. + -- This matters since only platform independent generated code can be + -- inlcuded into a source tarball. + platformIndependent :: Bool, + + -- TODO: deal with pre-processors that have implementaion dependent output + -- eg alex and happy have --ghc flags. However we can't really inlcude + -- ghc-specific code into supposedly portable source tarballs. + + runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir + -> (FilePath, FilePath) -- Output file name, relative to an output base dir + -> Verbosity -- verbosity + -> IO () -- Should exit if the preprocessor fails + } + +mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ()) + -> (FilePath, FilePath) + -> (FilePath, FilePath) -> Verbosity -> IO () +mkSimplePreProcessor simplePP + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity + where inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity + -> IO () +runSimplePreProcessor pp inFile outFile verbosity = + runPreProcessor pp (".", inFile) (".", outFile) verbosity + +-- |A preprocessor for turning non-Haskell files with the given extension +-- into plain Haskell source files. +type PPSuffixHandler + = (String, BuildInfo -> LocalBuildInfo -> PreProcessor) + +-- | Apply preprocessors to the sources from 'hsSourceDirs' for a given +-- component (lib, exe, or test suite). +preprocessComponent :: PackageDescription + -> Component + -> LocalBuildInfo + -> Bool + -> Verbosity + -> [PPSuffixHandler] + -> IO () +preprocessComponent pd comp lbi isSrcDist verbosity handlers = case comp of + (CLib lib@Library{ libBuildInfo = bi }) -> do + let dirs = hsSourceDirs bi ++ [autogenModulesDir lbi] + setupMessage verbosity "Preprocessing library" (packageId pd) + forM_ (map ModuleName.toFilePath $ libModules lib) $ + pre dirs (buildDir lbi) (localHandlers bi) + (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do + let exeDir = buildDir lbi nm nm ++ "-tmp" + dirs = hsSourceDirs bi ++ [autogenModulesDir lbi] + setupMessage verbosity ("Preprocessing executable '" ++ nm ++ "' for") (packageId pd) + forM_ (map ModuleName.toFilePath $ otherModules bi) $ + pre dirs exeDir (localHandlers bi) + pre (hsSourceDirs bi) exeDir (localHandlers bi) $ + dropExtensions (modulePath exe) + CTest test@TestSuite{ testName = nm } -> do + setupMessage verbosity ("Preprocessing test suite '" ++ nm ++ "' for") (packageId pd) + case testInterface test of + TestSuiteExeV10 _ f -> + preProcessTest test f $ buildDir lbi testName test + testName test ++ "-tmp" + TestSuiteLibV09 _ _ -> do + let testDir = buildDir lbi stubName test + stubName test ++ "-tmp" + writeSimpleTestStub test testDir + preProcessTest test (stubFilePath test) testDir + TestSuiteUnsupported tt -> die $ "No support for preprocessing test " + ++ "suite type " ++ display tt + CBench bm@Benchmark{ benchmarkName = nm } -> do + setupMessage verbosity ("Preprocessing benchmark '" ++ nm ++ "' for") (packageId pd) + case benchmarkInterface bm of + BenchmarkExeV10 _ f -> + preProcessBench bm f $ buildDir lbi benchmarkName bm + benchmarkName bm ++ "-tmp" + BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark " + ++ "type " ++ display tt + where + builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"] + builtinCSuffixes = cSourceExtensions + builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes + localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] + pre dirs dir lhndlrs fp = + preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs + preProcessTest test = preProcessComponent (testBuildInfo test) + (testModules test) + preProcessBench bm = preProcessComponent (benchmarkBuildInfo bm) + (benchmarkModules bm) + preProcessComponent bi modules exePath dir = do + let biHandlers = localHandlers bi + sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ] + sequence_ [ preprocessFile sourceDirs dir isSrcDist + (ModuleName.toFilePath modu) verbosity builtinSuffixes + biHandlers + | modu <- modules ] + preprocessFile (dir : (hsSourceDirs bi)) dir isSrcDist + (dropExtensions $ exePath) verbosity + builtinSuffixes biHandlers + +--TODO: try to list all the modules that could not be found +-- not just the first one. It's annoying and slow due to the need +-- to reconfigure after editing the .cabal file each time. + +-- |Find the first extension of the file that exists, and preprocess it +-- if required. +preprocessFile + :: [FilePath] -- ^source directories + -> FilePath -- ^build directory + -> Bool -- ^preprocess for sdist + -> FilePath -- ^module file name + -> Verbosity -- ^verbosity + -> [String] -- ^builtin suffixes + -> [(String, PreProcessor)] -- ^possible preprocessors + -> IO () +preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers = do + -- look for files in the various source dirs with this module name + -- and a file extension of a known preprocessor + psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc baseFile + case psrcFiles of + -- no preprocessor file exists, look for an ordinary source file + -- just to make sure one actually exists at all for this module. + -- Note: by looking in the target/output build dir too, we allow + -- source files to appear magically in the target build dir without + -- any corresponding "real" source file. This lets custom Setup.hs + -- files generate source modules directly into the build dir without + -- the rest of the build system being aware of it (somewhat dodgy) + Nothing -> do + bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : searchLoc) baseFile + case bsrcFiles of + Nothing -> die $ "can't find source for " ++ baseFile + ++ " in " ++ intercalate ", " searchLoc + _ -> return () + -- found a pre-processable file in one of the source dirs + Just (psrcLoc, psrcRelFile) -> do + let (srcStem, ext) = splitExtension psrcRelFile + psrcFile = psrcLoc psrcRelFile + pp = fromMaybe (error "Internal error in preProcess module: Just expected") + (lookup (tailNotNull ext) handlers) + -- Preprocessing files for 'sdist' is different from preprocessing + -- for 'build'. When preprocessing for sdist we preprocess to + -- avoid that the user has to have the preprocessors available. + -- ATM, we don't have a way to specify which files are to be + -- preprocessed and which not, so for sdist we only process + -- platform independent files and put them into the 'buildLoc' + -- (which we assume is set to the temp. directory that will become + -- the tarball). + --TODO: eliminate sdist variant, just supply different handlers + when (not forSDist || forSDist && platformIndependent pp) $ do + -- look for existing pre-processed source file in the dest dir to + -- see if we really have to re-run the preprocessor. + ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile + recomp <- case ppsrcFiles of + Nothing -> return True + Just ppsrcFile -> + psrcFile `moreRecentFile` ppsrcFile + when recomp $ do + let destDir = buildLoc dirName srcStem + createDirectoryIfMissingVerbose verbosity True destDir + runPreProcessorWithHsBootHack pp + (psrcLoc, psrcRelFile) + (buildLoc, srcStem <.> "hs") + + where + dirName = takeDirectory + tailNotNull [] = [] + tailNotNull x = tail x + + -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files + -- be in the same place as the hs files, so if we put the hs file in dist/ + -- then we need to copy the hs-boot file there too. This should probably be + -- done another way. Possibly we should also be looking for .lhs-boot + -- files, but I think that preprocessors only produce .hs files. + runPreProcessorWithHsBootHack pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) = do + runPreProcessor pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity + + exists <- doesFileExist inBoot + when exists $ copyFileVerbose verbosity inBoot outBoot + + where + inBoot = replaceExtension inFile "hs-boot" + outBoot = replaceExtension outFile "hs-boot" + + inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +-- ------------------------------------------------------------ +-- * known preprocessors +-- ------------------------------------------------------------ + +ppGreenCard :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppGreenCard _ lbi + = PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + rawSystemProgramConf verbosity greencardProgram (withPrograms lbi) + (["-tffi", "-o" ++ outFile, inFile]) + } + +-- This one is useful for preprocessors that can't handle literate source. +-- We also need a way to chain preprocessors. +ppUnlit :: PreProcessor +ppUnlit = + PreProcessor { + platformIndependent = True, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> + withUTF8FileContents inFile $ \contents -> + either (writeUTF8File outFile) die (unlit inFile contents) + } + +ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpp = ppCpp' [] + +ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpp' extraArgs bi lbi = + case compilerFlavor (compiler lbi) of + GHC -> ppGhcCpp ghcProgram (>= Version [6,6] []) args bi lbi + GHCJS -> ppGhcCpp ghcjsProgram (const True) args bi lbi + _ -> ppCpphs args bi lbi + where cppArgs = getCppOptions bi lbi + args = cppArgs ++ extraArgs + +ppGhcCpp :: Program -> (Version -> Bool) + -> [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppGhcCpp program xHs extraArgs _bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (prog, version, _) <- requireProgramVersion verbosity + program anyVersion (withPrograms lbi) + rawSystemProgram verbosity prog $ + ["-E", "-cpp"] + -- This is a bit of an ugly hack. We're going to + -- unlit the file ourselves later on if appropriate, + -- so we need GHC not to unlit it now or it'll get + -- double-unlitted. In the future we might switch to + -- using cpphs --unlit instead. + ++ (if xHs version then ["-x", "hs"] else []) + ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] + ++ ["-o", outFile, inFile] + ++ extraArgs + } + +ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpphs extraArgs _bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity + cpphsProgram anyVersion (withPrograms lbi) + rawSystemProgram verbosity cpphsProg $ + ("-O" ++ outFile) : inFile + : "--noline" : "--strip" + : (if cpphsVersion >= Version [1,6] [] + then ["--include="++ (autogenModulesDir lbi cppHeaderName)] + else []) + ++ extraArgs + } + +ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppHsc2hs bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + rawSystemProgramConf verbosity hsc2hsProgram (withPrograms lbi) $ + [ "--cc=" ++ programPath gccProg + , "--ld=" ++ programPath gccProg ] + + -- Additional gcc options + ++ [ "--cflag=" ++ opt | opt <- programDefaultArgs gccProg + ++ programOverrideArgs gccProg ] + ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs gccProg + ++ programOverrideArgs gccProg ] + + -- OSX frameworks: + ++ [ what ++ "=-F" ++ opt + | isOSX + , opt <- nub (concatMap Installed.frameworkDirs pkgs) + , what <- ["--cflag", "--lflag"] ] + ++ [ "--lflag=" ++ arg + | isOSX + , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs + , arg <- ["-framework", opt] ] + + -- Note that on ELF systems, wherever we use -L, we must also use -R + -- because presumably that -L dir is not on the normal path for the + -- system's dynamic linker. This is needed because hsc2hs works by + -- compiling a C program and then running it. + + ++ [ "--cflag=" ++ opt | opt <- platformDefines lbi ] + + -- Options from the current package: + ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ] + ++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi + ++ PD.cppOptions bi ] + ++ [ "--cflag=" ++ opt | opt <- + [ "-I" ++ autogenModulesDir lbi, + "-include", autogenModulesDir lbi cppHeaderName ] ] + ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ] + ++ [ "--lflag=-Wl,-R," ++ opt | isELF + , opt <- PD.extraLibDirs bi ] + ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs bi ] + ++ [ "--lflag=" ++ opt | opt <- PD.ldOptions bi ] + + -- Options from dependent packages + ++ [ "--cflag=" ++ opt + | pkg <- pkgs + , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] + ++ [ opt | opt <- Installed.ccOptions pkg ] ] + ++ [ "--lflag=" ++ opt + | pkg <- pkgs + , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] + ++ [ "-Wl,-R," ++ opt | isELF + , opt <- Installed.libraryDirs pkg ] + ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ] + ++ [ opt | opt <- Installed.ldOptions pkg ] ] + ++ ["-o", outFile, inFile] + } + where + pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi)) + isOSX = case buildOS of OSX -> True; _ -> False + isELF = case buildOS of OSX -> False; Windows -> False; _ -> True; + packageHacks = case compilerFlavor (compiler lbi) of + GHC -> hackRtsPackage + GHCJS -> hackRtsPackage + _ -> id + -- We don't link in the actual Haskell libraries of our dependencies, so + -- the -u flags in the ldOptions of the rts package mean linking fails on + -- OS X (it's ld is a tad stricter than gnu ld). Thus we remove the + -- ldOptions for GHC's rts package: + hackRtsPackage index = + case PackageIndex.lookupPackageName index (PackageName "rts") of + [(_, [rts])] + -> PackageIndex.insert rts { Installed.ldOptions = [] } index + _ -> error "No (or multiple) ghc rts package is registered!!" + + +ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppC2hs bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = \(inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity -> do + (c2hsProg, _, _) <- requireProgramVersion verbosity + c2hsProgram (orLaterVersion (Version [0,15] [])) + (withPrograms lbi) + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + rawSystemProgram verbosity c2hsProg $ + + -- Options from the current package: + [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] + ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ] + ++ [ "--include=" ++ outBaseDir ] + + -- Options from dependent packages + ++ [ "--cppopts=" ++ opt + | pkg <- pkgs + , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] + ++ [ opt | opt@('-':c:_) <- Installed.ccOptions pkg + , c `elem` "DIU" ] ] + --TODO: install .chi files for packages, so we can --include + -- those dirs here, for the dependencies + + -- input and output files + ++ [ "--output-dir=" ++ outBaseDir + , "--output=" ++ outRelativeFile + , inBaseDir inRelativeFile ] + } + where + pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) + +--TODO: perhaps use this with hsc2hs too +--TODO: remove cc-options from cpphs for cabal-version: >= 1.10 +getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] +getCppOptions bi lbi + = platformDefines lbi + ++ cppOptions bi + ++ ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ [opt | opt@('-':c:_) <- PD.ccOptions bi, c `elem` "DIU"] + +platformDefines :: LocalBuildInfo -> [String] +platformDefines lbi = + case compilerFlavor comp of + GHC -> + ["-D__GLASGOW_HASKELL__=" ++ versionInt version] ++ + ["-D" ++ os ++ "_BUILD_OS=1"] ++ + ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ + map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ + map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr + GHCJS -> + compatGlasgowHaskell ++ + ["-D__GHCJS__=" ++ versionInt version] ++ + ["-D" ++ os ++ "_BUILD_OS=1"] ++ + ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ + map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ + map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr + JHC -> ["-D__JHC__=" ++ versionInt version] + HaskellSuite {} -> + ["-D__HASKELL_SUITE__"] ++ + map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ + map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr + _ -> [] + where + comp = compiler lbi + Platform hostArch hostOS = hostPlatform lbi + version = compilerVersion comp + compatGlasgowHaskell = + maybe [] (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v]) + (compilerCompatVersion GHC comp) + -- TODO: move this into the compiler abstraction + -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all + -- the other compilers. Check if that's really what they want. + versionInt :: Version -> String + versionInt (Version { versionBranch = [] }) = "1" + versionInt (Version { versionBranch = [n] }) = show n + versionInt (Version { versionBranch = n1:n2:_ }) + = -- 6.8.x -> 608 + -- 6.10.x -> 610 + let s1 = show n1 + s2 = show n2 + middle = case s2 of + _ : _ : _ -> "" + _ -> "0" + in s1 ++ middle ++ s2 + osStr = case hostOS of + Linux -> ["linux"] + Windows -> ["mingw32"] + OSX -> ["darwin"] + FreeBSD -> ["freebsd"] + OpenBSD -> ["openbsd"] + NetBSD -> ["netbsd"] + DragonFly -> ["dragonfly"] + Solaris -> ["solaris2"] + AIX -> ["aix"] + HPUX -> ["hpux"] + IRIX -> ["irix"] + HaLVM -> [] + IOS -> ["ios"] + Android -> ["android"] + Ghcjs -> ["ghcjs"] + Hurd -> ["hurd"] + OtherOS _ -> [] + archStr = case hostArch of + I386 -> ["i386"] + X86_64 -> ["x86_64"] + PPC -> ["powerpc"] + PPC64 -> ["powerpc64"] + Sparc -> ["sparc"] + Arm -> ["arm"] + Mips -> ["mips"] + SH -> [] + IA64 -> ["ia64"] + S390 -> ["s390"] + Alpha -> ["alpha"] + Hppa -> ["hppa"] + Rs6000 -> ["rs6000"] + M68k -> ["m68k"] + Vax -> ["vax"] + JavaScript -> ["javascript"] + OtherArch _ -> [] + +ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppHappy _ lbi = pp { platformIndependent = True } + where pp = standardPP lbi happyProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-agc"] + hcFlags GHCJS = ["-agc"] + hcFlags _ = [] + +ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppAlex _ lbi = pp { platformIndependent = True } + where pp = standardPP lbi alexProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-g"] + hcFlags GHCJS = ["-g"] + hcFlags _ = [] + +standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor +standardPP lbi prog args = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + rawSystemProgramConf verbosity prog (withPrograms lbi) + (args ++ ["-o", outFile, inFile]) + } + +-- |Convenience function; get the suffixes of these preprocessors. +ppSuffixes :: [ PPSuffixHandler ] -> [String] +ppSuffixes = map fst + +-- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. +knownSuffixHandlers :: [ PPSuffixHandler ] +knownSuffixHandlers = + [ ("gc", ppGreenCard) + , ("chs", ppC2hs) + , ("hsc", ppHsc2hs) + , ("x", ppAlex) + , ("y", ppHappy) + , ("ly", ppHappy) + , ("cpphs", ppCpp) + ] diff --git a/Distribution/Simple/PreProcess/Unlit.hs b/Distribution/Simple/PreProcess/Unlit.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/PreProcess/Unlit.hs @@ -0,0 +1,165 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PreProcess.Unlit +-- Copyright : ... +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Remove the \"literal\" markups from a Haskell source file, including +-- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\" + +-- This version is interesting because instead of striping comment lines, it +-- turns them into "-- " style comments. This allows using haddock markup +-- in literate scripts without having to use "> --" prefix. + +module Distribution.Simple.PreProcess.Unlit (unlit,plain) where + +import Data.Char +import Data.List + +data Classified = BirdTrack String | Blank String | Ordinary String + | Line !Int String | CPP String + | BeginCode | EndCode + -- output only: + | Error String | Comment String + +-- | No unliteration. +plain :: String -> String -> String +plain _ hs = hs + +classify :: String -> Classified +classify ('>':s) = BirdTrack s +classify ('#':s) = case tokens s of + (line:file:_) | all isDigit line + && length file >= 2 + && head file == '"' + && last file == '"' + -> Line (read line) (tail (init file)) + _ -> CPP s + where tokens = unfoldr $ \str -> case lex str of + (t@(_:_), str'):_ -> Just (t, str') + _ -> Nothing +classify ('\\':s) + | "begin{code}" `isPrefixOf` s = BeginCode + | "end{code}" `isPrefixOf` s = EndCode +classify s | all isSpace s = Blank s +classify s = Ordinary s + +-- So the weird exception for comment indenting is to make things work with +-- haddock, see classifyAndCheckForBirdTracks below. +unclassify :: Bool -> Classified -> String +unclassify _ (BirdTrack s) = ' ':s +unclassify _ (Blank s) = s +unclassify _ (Ordinary s) = s +unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file +unclassify _ (CPP s) = '#':s +unclassify True (Comment "") = " --" +unclassify True (Comment s) = " -- " ++ s +unclassify False (Comment "") = "--" +unclassify False (Comment s) = "-- " ++ s +unclassify _ _ = internalError + +-- | 'unlit' takes a filename (for error reports), and transforms the +-- given string, to eliminate the literate comments from the program text. +unlit :: FilePath -> String -> Either String String +unlit file input = + let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks + . inlines + $ input + in either (Left . unlines . map (unclassify usesBirdTracks)) + Right + . checkErrors + . reclassify + $ classified + + where + -- So haddock requires comments and code to align, since it treats comments + -- as following the layout rule. This is a pain for us since bird track + -- style literate code typically gets indented by two since ">" is replaced + -- by " " and people usually use one additional space of indent ie + -- "> then the code". On the other hand we cannot just go and indent all + -- the comments by two since that does not work for latex style literate + -- code. So the hacky solution we use here is that if we see any bird track + -- style code then we'll indent all comments by two, otherwise by none. + -- Of course this will not work for mixed latex/bird track .lhs files but + -- nobody does that, it's silly and specifically recommended against in the + -- H98 unlit spec. + -- + classifyAndCheckForBirdTracks = + flip mapAccumL False $ \seenBirdTrack line -> + let classification = classify line + in (seenBirdTrack || isBirdTrack classification, classification) + + isBirdTrack (BirdTrack _) = True + isBirdTrack _ = False + + checkErrors ls = case [ e | Error e <- ls ] of + [] -> Left ls + (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message) + where (f, n) = errorPos file 1 ls + errorPos f n [] = (f, n) + errorPos f n (Error _:_) = (f, n) + errorPos _ _ (Line n' f':ls) = errorPos f' n' ls + errorPos f n (_ :ls) = errorPos f (n+1) ls + +-- Here we model a state machine, with each state represented by +-- a local function. We only have four states (well, five, +-- if you count the error state), but the rules +-- to transition between then are not so simple. +-- Would it be simpler to have more states? +-- +-- Each state represents the type of line that was last read +-- i.e. are we in a comment section, or a latex-code section, +-- or a bird-code section, etc? +reclassify :: [Classified] -> [Classified] +reclassify = blank -- begin in blank state + where + latex [] = [] + latex (EndCode :ls) = Blank "" : comment ls + latex (BeginCode :_ ) = [Error "\\begin{code} in code section"] + latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls + latex ( l:ls) = l : latex ls + + blank [] = [] + blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] + blank (BeginCode :ls) = Blank "" : latex ls + blank (BirdTrack l:ls) = BirdTrack l : bird ls + blank (Ordinary l:ls) = Comment l : comment ls + blank ( l:ls) = l : blank ls + + bird [] = [] + bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] + bird (BeginCode :ls) = Blank "" : latex ls + bird (Blank l :ls) = Blank l : blank ls + bird (Ordinary _:_ ) = [Error "program line before comment line"] + bird ( l:ls) = l : bird ls + + comment [] = [] + comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] + comment (BeginCode :ls) = Blank "" : latex ls + comment (CPP l :ls) = CPP l : comment ls + comment (BirdTrack _:_ ) = [Error "comment line before program line"] + -- a blank line and another ordinary line following a comment + -- will be treated as continuing the comment. Otherwise it's + -- then end of the comment, with a blank line. + comment (Blank l:ls@(Ordinary _:_)) = Comment l : comment ls + comment (Blank l:ls) = Blank l : blank ls + comment (Line n f :ls) = Line n f : comment ls + comment (Ordinary l:ls) = Comment l : comment ls + comment (Comment _: _) = internalError + comment (Error _: _) = internalError + +-- Re-implementation of 'lines', for better efficiency (but decreased laziness). +-- Also, importantly, accepts non-standard DOS and Mac line ending characters. +inlines :: String -> [String] +inlines xs = lines' xs id + where + lines' [] acc = [acc []] + lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS + lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS + lines' ('\n':s) acc = acc [] : lines' s id -- Unix + lines' (c:s) acc = lines' s (acc . (c:)) + +internalError :: a +internalError = error "unlit: internal error" diff --git a/Distribution/Simple/Program.hs b/Distribution/Simple/Program.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program.hs @@ -0,0 +1,222 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides an abstraction which deals with configuring and running +-- programs. A 'Program' is a static notion of a known program. A +-- 'ConfiguredProgram' is a 'Program' that has been found on the current +-- machine and is ready to be run (possibly with some user-supplied default +-- args). Configuring a program involves finding its location and if necessary +-- finding its version. There is also a 'ProgramConfiguration' type which holds +-- configured and not-yet configured programs. It is the parameter to lots of +-- actions elsewhere in Cabal that need to look up and run programs. If we had +-- a Cabal monad, the 'ProgramConfiguration' would probably be a reader or +-- state component of it. +-- +-- The module also defines all the known built-in 'Program's and the +-- 'defaultProgramConfiguration' which contains them all. +-- +-- One nice thing about using it is that any program that is +-- registered with Cabal will get some \"configure\" and \".cabal\" +-- helpers like --with-foo-args --foo-path= and extra-foo-args. +-- +-- There's also good default behavior for trying to find \"foo\" in +-- PATH, being able to override its location, etc. +-- +-- There's also a hook for adding programs in a Setup.lhs script. See +-- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a +-- hook user the ability to get the above flags and such so that they +-- don't have to write all the PATH logic inside Setup.lhs. + +module Distribution.Simple.Program ( + -- * Program and functions for constructing them + Program(..) + , ProgramSearchPath + , ProgramSearchPathEntry(..) + , simpleProgram + , findProgramLocation + , findProgramVersion + + -- * Configured program and related functions + , ConfiguredProgram(..) + , programPath + , ProgArg + , ProgramLocation(..) + , runProgram + , getProgramOutput + , suppressOverrideArgs + + -- * Program invocations + , ProgramInvocation(..) + , emptyProgramInvocation + , simpleProgramInvocation + , programInvocation + , runProgramInvocation + , getProgramInvocationOutput + + -- * The collection of unconfigured and configured programs + , builtinPrograms + + -- * The collection of configured programs we can run + , ProgramConfiguration + , emptyProgramConfiguration + , defaultProgramConfiguration + , restoreProgramConfiguration + , addKnownProgram + , addKnownPrograms + , lookupKnownProgram + , knownPrograms + , getProgramSearchPath + , setProgramSearchPath + , userSpecifyPath + , userSpecifyPaths + , userMaybeSpecifyPath + , userSpecifyArgs + , userSpecifyArgss + , userSpecifiedArgs + , lookupProgram + , lookupProgramVersion + , updateProgram + , configureProgram + , configureAllKnownPrograms + , reconfigurePrograms + , requireProgram + , requireProgramVersion + , runDbProgram + , getDbProgramOutput + + -- * Programs that Cabal knows about + , ghcProgram + , ghcPkgProgram + , ghcjsProgram + , ghcjsPkgProgram + , lhcProgram + , lhcPkgProgram + , hmakeProgram + , jhcProgram + , uhcProgram + , gccProgram + , arProgram + , stripProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , hscolourProgram + , haddockProgram + , greencardProgram + , ldProgram + , tarProgram + , cppProgram + , pkgConfigProgram + , hpcProgram + + -- * deprecated + , rawSystemProgram + , rawSystemProgramStdout + , rawSystemProgramConf + , rawSystemProgramStdoutConf + , findProgramOnPath + + ) where + +import Distribution.Simple.Program.Types +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Builtin + +import Distribution.Simple.Utils + ( die, findProgramLocation, findProgramVersion ) +import Distribution.Verbosity + ( Verbosity ) + + +-- | Runs the given configured program. +-- +runProgram :: Verbosity -- ^Verbosity + -> ConfiguredProgram -- ^The program to run + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO () +runProgram verbosity prog args = + runProgramInvocation verbosity (programInvocation prog args) + + +-- | Runs the given configured program and gets the output. +-- +getProgramOutput :: Verbosity -- ^Verbosity + -> ConfiguredProgram -- ^The program to run + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO String +getProgramOutput verbosity prog args = + getProgramInvocationOutput verbosity (programInvocation prog args) + + +-- | Looks up the given program in the program database and runs it. +-- +runDbProgram :: Verbosity -- ^verbosity + -> Program -- ^The program to run + -> ProgramDb -- ^look up the program here + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO () +runDbProgram verbosity prog programDb args = + case lookupProgram prog programDb of + Nothing -> die notFound + Just configuredProg -> runProgram verbosity configuredProg args + where + notFound = "The program '" ++ programName prog + ++ "' is required but it could not be found" + +-- | Looks up the given program in the program database and runs it. +-- +getDbProgramOutput :: Verbosity -- ^verbosity + -> Program -- ^The program to run + -> ProgramDb -- ^look up the program here + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO String +getDbProgramOutput verbosity prog programDb args = + case lookupProgram prog programDb of + Nothing -> die notFound + Just configuredProg -> getProgramOutput verbosity configuredProg args + where + notFound = "The program '" ++ programName prog + ++ "' is required but it could not be found" + + +--------------------- +-- Deprecated aliases +-- + +rawSystemProgram :: Verbosity -> ConfiguredProgram + -> [ProgArg] -> IO () +rawSystemProgram = runProgram + +rawSystemProgramStdout :: Verbosity -> ConfiguredProgram + -> [ProgArg] -> IO String +rawSystemProgramStdout = getProgramOutput + +rawSystemProgramConf :: Verbosity -> Program -> ProgramConfiguration + -> [ProgArg] -> IO () +rawSystemProgramConf = runDbProgram + +rawSystemProgramStdoutConf :: Verbosity -> Program -> ProgramConfiguration + -> [ProgArg] -> IO String +rawSystemProgramStdoutConf = getDbProgramOutput + +type ProgramConfiguration = ProgramDb + +emptyProgramConfiguration, defaultProgramConfiguration :: ProgramConfiguration +emptyProgramConfiguration = emptyProgramDb +defaultProgramConfiguration = defaultProgramDb + +restoreProgramConfiguration :: [Program] -> ProgramConfiguration + -> ProgramConfiguration +restoreProgramConfiguration = restoreProgramDb + +{-# DEPRECATED findProgramOnPath "use findProgramLocation instead" #-} +findProgramOnPath :: String -> Verbosity -> IO (Maybe FilePath) +findProgramOnPath = flip findProgramLocation diff --git a/Distribution/Simple/Program/Ar.hs b/Distribution/Simple/Program/Ar.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/Ar.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Ar +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @ar@ program. + +module Distribution.Simple.Program.Ar ( + createArLibArchive, + multiStageProgramInvocation + ) where + +import Control.Monad (when, unless) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Char (isSpace) +import Distribution.Compat.CopyFile (filesEqual) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.Program + ( arProgram, requireProgram ) +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 + ( Arch(..), OS(..), Platform(..) ) +import Distribution.Verbosity + ( Verbosity, deafening, verbose ) +import System.Directory (doesFileExist, renameFile) +import System.FilePath ((), splitFileName) +import System.IO + ( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek) + , hFileSize, hSeek, withBinaryFile ) + +-- | Call @ar@ to create a library archive from a bunch of object files. +-- +createArLibArchive :: Verbosity -> LocalBuildInfo + -> FilePath -> [FilePath] -> IO () +createArLibArchive verbosity lbi targetPath files = do + (ar, _) <- requireProgram verbosity arProgram progConf + + let (targetDir, targetName) = splitFileName targetPath + withTempDirectory verbosity targetDir targetName $ \ tmpDir -> do + let tmpPath = tmpDir targetName + + -- The args to use with "ar" are actually rather subtle and system-dependent. + -- In particular we have the following issues: + -- + -- -- On OS X, "ar q" does not make an archive index. Archives with no + -- index cannot be used. + -- + -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us + -- do that. We have duplicates because of modules like "A.M" and "B.M" + -- both make an object file "M.o" and ar does not consider the directory. + -- + -- Our solution is to use "ar r" in the simple case when one call is enough. + -- When we need to call ar multiple times we use "ar q" and for the last + -- call on OSX we use "ar qs" so that it'll make the index. + + let simpleArgs = case hostOS of + OSX -> ["-r", "-s"] + _ -> ["-r"] + + initialArgs = ["-q"] + finalArgs = case hostOS of + OSX -> ["-q", "-s"] + _ -> ["-q"] + + extraArgs = verbosityOpts verbosity ++ [tmpPath] + + simple = programInvocation ar (simpleArgs ++ extraArgs) + initial = programInvocation ar (initialArgs ++ extraArgs) + middle = initial + final = programInvocation ar (finalArgs ++ extraArgs) + + sequence_ + [ runProgramInvocation verbosity inv + | inv <- multiStageProgramInvocation + simple (initial, middle, final) files ] + + when stripLib $ Strip.stripLib verbosity platform progConf tmpPath + unless (hostArch == Arm) $ -- See #1537 + wipeMetadata tmpPath + equal <- filesEqual tmpPath targetPath + unless equal $ renameFile tmpPath targetPath + + where + progConf = withPrograms lbi + stripLib = stripLibs lbi + platform@(Platform hostArch hostOS) = hostPlatform lbi + verbosityOpts v | v >= deafening = ["-v"] + | v >= verbose = [] + | otherwise = ["-c"] + +-- | @ar@ by default includes various metadata for each object file in their +-- respective headers, so the output can differ for the same inputs, making +-- it difficult to avoid re-linking. GNU @ar@(1) has a deterministic mode +-- (@-D@) flag that always writes zero for the mtime, UID and GID, and 0644 +-- for the file mode. However detecting whether @-D@ is supported seems +-- rather harder than just re-implementing this feature. +wipeMetadata :: FilePath -> IO () +wipeMetadata path = do + -- Check for existence first (ReadWriteMode would create one otherwise) + exists <- doesFileExist path + unless exists $ wipeError "Temporary file disappeared" + withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h + + where + wipeError msg = dieWithLocation path Nothing $ + "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg + archLF = "!\x0a" -- global magic, 8 bytes + x60LF = "\x60\x0a" -- header magic, 2 bytes + metadata = BS.concat + [ "0 " -- mtime, 12 bytes + , "0 " -- UID, 6 bytes + , "0 " -- GID, 6 bytes + , "0644 " -- mode, 8 bytes + ] + headerSize :: Int + headerSize = 60 + + -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details + wipeArchive :: Handle -> Integer -> IO () + wipeArchive h archiveSize = do + global <- BS.hGet h (BS.length archLF) + unless (global == archLF) $ wipeError "Bad global header" + wipeHeader (toInteger $ BS.length archLF) + + where + wipeHeader :: Integer -> IO () + wipeHeader offset = case compare offset archiveSize of + EQ -> return () + GT -> wipeError (atOffset "Archive truncated") + LT -> do + header <- BS.hGet h headerSize + unless (BS.length header == headerSize) $ + wipeError (atOffset "Short header") + let magic = BS.drop 58 header + unless (magic == x60LF) . wipeError . atOffset $ + "Bad magic " ++ show magic ++ " in header" + + let name = BS.take 16 header + let size = BS.take 10 $ BS.drop 48 header + objSize <- case reads (BS8.unpack size) of + [(n, s)] | all isSpace s -> return n + _ -> wipeError (atOffset "Bad file size in header") + + let replacement = BS.concat [ name, metadata, size, magic ] + unless (BS.length replacement == headerSize) $ + wipeError (atOffset "Something has gone terribly wrong") + hSeek h AbsoluteSeek offset + BS.hPut h replacement + + let nextHeader = offset + toInteger headerSize + + -- Odd objects are padded with an extra '\x0a' + if odd objSize then objSize + 1 else objSize + hSeek h AbsoluteSeek nextHeader + wipeHeader nextHeader + + where + atOffset msg = msg ++ " at offset " ++ show offset diff --git a/Distribution/Simple/Program/Builtin.hs b/Distribution/Simple/Program/Builtin.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/Builtin.hs @@ -0,0 +1,361 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Builtin +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- The module defines all the known built-in 'Program's. +-- +-- Where possible we try to find their version numbers. +-- +module Distribution.Simple.Program.Builtin ( + + -- * The collection of unconfigured and configured programs + builtinPrograms, + + -- * Programs that Cabal knows about + ghcProgram, + ghcPkgProgram, + ghcjsProgram, + ghcjsPkgProgram, + lhcProgram, + lhcPkgProgram, + hmakeProgram, + jhcProgram, + haskellSuiteProgram, + haskellSuitePkgProgram, + uhcProgram, + gccProgram, + arProgram, + stripProgram, + happyProgram, + alexProgram, + hsc2hsProgram, + c2hsProgram, + cpphsProgram, + hscolourProgram, + haddockProgram, + greencardProgram, + ldProgram, + tarProgram, + cppProgram, + pkgConfigProgram, + hpcProgram, + ) where + +import Distribution.Simple.Program.Find + ( findProgramOnSearchPath ) +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 + +-- ------------------------------------------------------------ +-- * Known programs +-- ------------------------------------------------------------ + +-- | The default list of programs. +-- These programs are typically used internally to Cabal. +builtinPrograms :: [Program] +builtinPrograms = + [ + -- compilers and related progs + ghcProgram + , ghcPkgProgram + , ghcjsProgram + , ghcjsPkgProgram + , haskellSuiteProgram + , haskellSuitePkgProgram + , hmakeProgram + , jhcProgram + , lhcProgram + , lhcPkgProgram + , uhcProgram + , hpcProgram + -- preprocessors + , hscolourProgram + , haddockProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , greencardProgram + -- platform toolchain + , gccProgram + , arProgram + , stripProgram + , ldProgram + , tarProgram + -- configuration tools + , pkgConfigProgram + ] + +ghcProgram :: Program +ghcProgram = (simpleProgram "ghc") { + programFindVersion = findProgramVersion "--numeric-version" id, + + -- Workaround for https://ghc.haskell.org/trac/ghc/ticket/8825 + -- (spurious warning on non-english locales) + programPostConf = \_verbosity ghcProg -> + do let ghcProg' = ghcProg { + programOverrideEnv = ("LANGUAGE", Just "en") + : programOverrideEnv ghcProg + } + -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4. + affectedVersionRange = intersectVersionRanges + (laterVersion $ Version [7,8,0] []) + (earlierVersion $ Version [7,8,4] []) + return $ maybe ghcProg + (\v -> if withinRange v affectedVersionRange + then ghcProg' else ghcProg) + (programVersion ghcProg) + } + +ghcPkgProgram :: Program +ghcPkgProgram = (simpleProgram "ghc-pkg") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "ghc-pkg --version" gives a string like + -- "GHC package manager version 6.4.1" + case words str of + (_:_:_:_:ver:_) -> ver + _ -> "" + } + +ghcjsProgram :: Program +ghcjsProgram = (simpleProgram "ghcjs") { + programFindVersion = findProgramVersion "--numeric-ghcjs-version" id + } + +ghcjsPkgProgram :: Program +ghcjsPkgProgram = (simpleProgram "ghcjs-pkg") { + programFindVersion = findProgramVersion "--ghcjs-version" $ \str -> + -- Invoking "ghcjs-pkg --version" gives a string like + -- "GHCJS package manager version 6.4.1" + case words str of + (_:_:_:_:ver:_) -> ver + _ -> "" + } + +lhcProgram :: Program +lhcProgram = (simpleProgram "lhc") { + programFindVersion = findProgramVersion "--numeric-version" id + } + +lhcPkgProgram :: Program +lhcPkgProgram = (simpleProgram "lhc-pkg") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "lhc-pkg --version" gives a string like + -- "LHC package manager version 0.7" + case words str of + (_:_:_:_:ver:_) -> ver + _ -> "" + } + +hmakeProgram :: Program +hmakeProgram = (simpleProgram "hmake") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "hmake --version" gives a string line + -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +jhcProgram :: Program +jhcProgram = (simpleProgram "jhc") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- invoking "jhc --version" gives a string like + -- "jhc 0.3.20080208 (wubgipkamcep-2) + -- compiled by ghc-6.8 on a x86_64 running linux" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +uhcProgram :: Program +uhcProgram = (simpleProgram "uhc") { + programFindVersion = findProgramVersion "--version-dotted" id + } + +hpcProgram :: Program +hpcProgram = (simpleProgram "hpc") + { + programFindVersion = findProgramVersion "version" $ \str -> + case words str of + (_ : _ : _ : ver : _) -> ver + _ -> "" + } + +-- This represents a haskell-suite compiler. Of course, the compiler +-- itself probably is not called "haskell-suite", so this is not a real +-- program. (But we don't know statically the name of the actual compiler, +-- so this is the best we can do.) +-- +-- Having this Program value serves two purposes: +-- +-- 1. We can accept options for the compiler in the form of +-- +-- --haskell-suite-option(s)=... +-- +-- 2. We can find a program later using this static id (with +-- requireProgram). +-- +-- The path to the real compiler is found and recorded in the ProgramDb +-- during the configure phase. +haskellSuiteProgram :: Program +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" + } + +-- 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" + } + + +happyProgram :: Program +happyProgram = (simpleProgram "happy") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "happy --version" gives a string like + -- "Happy Version 1.16 Copyright (c) ...." + case words str of + (_:_:ver:_) -> ver + _ -> "" + } + +alexProgram :: Program +alexProgram = (simpleProgram "alex") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "alex --version" gives a string like + -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" + case words str of + (_:_:ver:_) -> takeWhile (\x -> isDigit x || x == '.') ver + _ -> "" + } + +gccProgram :: Program +gccProgram = (simpleProgram "gcc") { + programFindVersion = findProgramVersion "-dumpversion" id + } + +arProgram :: Program +arProgram = simpleProgram "ar" + +stripProgram :: Program +stripProgram = (simpleProgram "strip") { + programFindVersion = \verbosity -> + findProgramVersion "--version" selectVersion (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") { + programFindVersion = + findProgramVersion "--version" $ \str -> + -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" + case words str of + (_:_:ver:_) -> ver + _ -> "" + } + +c2hsProgram :: Program +c2hsProgram = (simpleProgram "c2hs") { + programFindVersion = findProgramVersion "--numeric-version" id + } + +cpphsProgram :: Program +cpphsProgram = (simpleProgram "cpphs") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "cpphs --version" gives a string like "cpphs 1.3" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +hscolourProgram :: Program +hscolourProgram = (simpleProgram "hscolour") { + programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour", + programFindVersion = findProgramVersion "-version" $ \str -> + -- Invoking "HsColour -version" gives a string like "HsColour 1.7" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +haddockProgram :: Program +haddockProgram = (simpleProgram "haddock") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "haddock --version" gives a string like + -- "Haddock version 0.8, (c) Simon Marlow 2006" + case words str of + (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver + _ -> "" + } + +greencardProgram :: Program +greencardProgram = simpleProgram "greencard" + +ldProgram :: Program +ldProgram = simpleProgram "ld" + +tarProgram :: Program +tarProgram = (simpleProgram "tar") { + -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the + -- '--format' option. + programPostConf = \verbosity tarProg -> do + tarHelpOutput <- getProgramInvocationOutput + verbosity (programInvocation tarProg ["--help"]) + -- Some versions of tar don't support '--help'. + `catchIO` (\_ -> return "") + let k = "Supports --format" + v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO" + m = Map.insert k v (programProperties tarProg) + return $ tarProg { programProperties = m } + } + +cppProgram :: Program +cppProgram = simpleProgram "cpp" + +pkgConfigProgram :: Program +pkgConfigProgram = (simpleProgram "pkg-config") { + programFindVersion = findProgramVersion "--version" id + } diff --git a/Distribution/Simple/Program/Db.hs b/Distribution/Simple/Program/Db.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/Db.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Db +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides a 'ProgramDb' type which holds configured and not-yet +-- configured programs. It is the parameter to lots of actions elsewhere in +-- Cabal that need to look up and run programs. If we had a Cabal monad, +-- the 'ProgramDb' would probably be a reader or state component of it. +-- +-- One nice thing about using it is that any program that is +-- registered with Cabal will get some \"configure\" and \".cabal\" +-- helpers like --with-foo-args --foo-path= and extra-foo-args. +-- +-- There's also a hook for adding programs in a Setup.lhs script. See +-- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a +-- hook user the ability to get the above flags and such so that they +-- don't have to write all the PATH logic inside Setup.lhs. + +module Distribution.Simple.Program.Db ( + -- * The collection of configured programs we can run + ProgramDb, + emptyProgramDb, + defaultProgramDb, + restoreProgramDb, + + -- ** Query and manipulate the program db + addKnownProgram, + addKnownPrograms, + lookupKnownProgram, + knownPrograms, + getProgramSearchPath, + setProgramSearchPath, + modifyProgramSearchPath, + userSpecifyPath, + userSpecifyPaths, + userMaybeSpecifyPath, + userSpecifyArgs, + userSpecifyArgss, + userSpecifiedArgs, + lookupProgram, + updateProgram, + configuredPrograms, + + -- ** Query and manipulate the program db + configureProgram, + configureAllKnownPrograms, + lookupProgramVersion, + reconfigurePrograms, + requireProgram, + requireProgramVersion, + + ) 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 (Binary(..)) +#if __GLASGOW_HASKELL__ < 710 +import Data.Functor ((<$>)) +#endif +import Data.List + ( foldl' ) +import Data.Maybe + ( catMaybes ) +import qualified Data.Map as Map +import Control.Monad + ( join, foldM ) + +-- ------------------------------------------------------------ +-- * Programs database +-- ------------------------------------------------------------ + +-- | The configuration is a collection of information about programs. It +-- contains information both about configured programs and also about programs +-- that we are yet to configure. +-- +-- The idea is that we start from a collection of unconfigured programs and one +-- by one we try to configure them at which point we move them into the +-- configured collection. For unconfigured programs we record not just the +-- 'Program' but also any user-provided arguments and location for the program. +data ProgramDb = ProgramDb { + unconfiguredProgs :: UnconfiguredProgs, + progSearchPath :: ProgramSearchPath, + configuredProgs :: ConfiguredProgs + } + +type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) +type UnconfiguredProgs = Map.Map String UnconfiguredProgram +type ConfiguredProgs = Map.Map String ConfiguredProgram + + +emptyProgramDb :: ProgramDb +emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty + +defaultProgramDb :: ProgramDb +defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb + + +-- internal helpers: +updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs) + -> ProgramDb -> ProgramDb +updateUnconfiguredProgs update conf = + conf { unconfiguredProgs = update (unconfiguredProgs conf) } + +updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs) + -> ProgramDb -> ProgramDb +updateConfiguredProgs update conf = + conf { configuredProgs = update (configuredProgs conf) } + + +-- Read & Show instances are based on listToFM +-- Note that we only serialise the configured part of the database, this is +-- because we don't need the unconfigured part after the configure stage, and +-- additionally because we cannot read/show 'Program' as it contains functions. +instance Show ProgramDb where + show = show . Map.toAscList . configuredProgs + +instance Read ProgramDb where + readsPrec p s = + [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r) + | (s', r) <- readsPrec p s ] + +instance Binary ProgramDb where + put = put . configuredProgs + get = do + progs <- get + return $! emptyProgramDb { 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. +-- +-- * It does not add the default programs, but you probably want them, use +-- 'builtinPrograms' in addition to any extra you might need. +-- +restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb +restoreProgramDb = addKnownPrograms + + +-- ------------------------------- +-- Managing unconfigured programs + +-- | Add a known program that we may configure later +-- +addKnownProgram :: Program -> ProgramDb -> ProgramDb +addKnownProgram prog = updateUnconfiguredProgs $ + Map.insertWith combine (programName prog) (prog, Nothing, []) + where combine _ (_, path, args) = (prog, path, args) + + +addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb +addKnownPrograms progs conf = foldl' (flip addKnownProgram) conf progs + + +lookupKnownProgram :: String -> ProgramDb -> Maybe Program +lookupKnownProgram name = + fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs + + +knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)] +knownPrograms conf = + [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf) + , let p' = Map.lookup (programName p) (configuredProgs conf) ] + +-- | Get the current 'ProgramSearchPath' used by the 'ProgramDb'. +-- This is the default list of locations where programs are looked for when +-- configuring them. This can be overridden for specific programs (with +-- 'userSpecifyPath'), and specific known programs can modify or ignore this +-- search path in their own configuration code. +-- +getProgramSearchPath :: ProgramDb -> ProgramSearchPath +getProgramSearchPath = progSearchPath + +-- | Change the current 'ProgramSearchPath' used by the 'ProgramDb'. +-- This will affect programs that are configured from here on, so you +-- should usually set it before configuring any programs. +-- +setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb +setProgramSearchPath searchpath db = db { progSearchPath = searchpath } + +-- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'. +-- This will affect programs that are configured from here on, so you +-- should usually modify it before configuring any programs. +-- +modifyProgramSearchPath :: (ProgramSearchPath -> ProgramSearchPath) + -> ProgramDb + -> ProgramDb +modifyProgramSearchPath f db = + setProgramSearchPath (f $ getProgramSearchPath db) db + +-- |User-specify this path. Basically override any path information +-- for this program in the configuration. If it's not a known +-- program ignore it. +-- +userSpecifyPath :: String -- ^Program name + -> FilePath -- ^user-specified path to the program + -> ProgramDb -> ProgramDb +userSpecifyPath name path = updateUnconfiguredProgs $ + flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args) + + +userMaybeSpecifyPath :: String -> Maybe FilePath + -> ProgramDb -> ProgramDb +userMaybeSpecifyPath _ Nothing conf = conf +userMaybeSpecifyPath name (Just path) conf = userSpecifyPath name path conf + + +-- |User-specify the arguments for this program. Basically override +-- any args information for this program in the configuration. If it's +-- not a known program, ignore it.. +userSpecifyArgs :: String -- ^Program name + -> [ProgArg] -- ^user-specified args + -> ProgramDb + -> ProgramDb +userSpecifyArgs name args' = + updateUnconfiguredProgs + (flip Map.update name $ + \(prog, path, args) -> Just (prog, path, args ++ args')) + . updateConfiguredProgs + (flip Map.update name $ + \prog -> Just prog { programOverrideArgs = programOverrideArgs prog + ++ args' }) + + +-- | Like 'userSpecifyPath' but for a list of progs and their paths. +-- +userSpecifyPaths :: [(String, FilePath)] + -> ProgramDb + -> ProgramDb +userSpecifyPaths paths conf = + foldl' (\conf' (prog, path) -> userSpecifyPath prog path conf') conf paths + + +-- | Like 'userSpecifyPath' but for a list of progs and their args. +-- +userSpecifyArgss :: [(String, [ProgArg])] + -> ProgramDb + -> ProgramDb +userSpecifyArgss argss conf = + foldl' (\conf' (prog, args) -> userSpecifyArgs prog args conf') conf argss + + +-- | Get the path that has been previously specified for a program, if any. +-- +userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath +userSpecifiedPath prog = + join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs + + +-- | Get any extra args that have been previously specified for a program. +-- +userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg] +userSpecifiedArgs prog = + maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs + + +-- ----------------------------- +-- Managing configured programs + +-- | Try to find a configured program +lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram +lookupProgram prog = Map.lookup (programName prog) . configuredProgs + + +-- | Update a configured program in the database. +updateProgram :: ConfiguredProgram -> ProgramDb + -> ProgramDb +updateProgram prog = updateConfiguredProgs $ + Map.insert (programId prog) prog + + +-- | List all configured programs. +configuredPrograms :: ProgramDb -> [ConfiguredProgram] +configuredPrograms = Map.elems . configuredProgs + +-- --------------------------- +-- Configuring known programs + +-- | Try to configure a specific program. If the program is already included in +-- the collection of unconfigured programs then we use any user-supplied +-- location and arguments. If the program gets configured successfully it gets +-- added to the configured collection. +-- +-- Note that it is not a failure if the program cannot be configured. It's only +-- a failure if the user supplied a location and the program could not be found +-- at that location. +-- +-- The reason for it not being a failure at this stage is that we don't know up +-- front all the programs we will need, so we try to configure them all. +-- To verify that a program was actually successfully configured use +-- 'requireProgram'. +-- +configureProgram :: Verbosity + -> Program + -> ProgramDb + -> IO ProgramDb +configureProgram verbosity prog conf = do + let name = programName prog + maybeLocation <- case userSpecifiedPath prog conf of + Nothing -> programFindLocation prog verbosity (progSearchPath conf) + >>= return . fmap FoundOnSystem + Just path -> do + absolute <- doesExecutableExist path + if absolute + then return (Just (UserSpecified path)) + else findProgramOnSearchPath verbosity (progSearchPath conf) path + >>= maybe (die notFound) (return . Just . UserSpecified) + 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 + version <- programFindVersion prog verbosity (locationPath location) + newPath <- programSearchPathAsPATHVar (progSearchPath conf) + let configuredProg = ConfiguredProgram { + programId = name, + programVersion = version, + programDefaultArgs = [], + programOverrideArgs = userSpecifiedArgs prog conf, + programOverrideEnv = [("PATH", Just newPath)], + programProperties = Map.empty, + programLocation = location + } + configuredProg' <- programPostConf prog verbosity configuredProg + return (updateConfiguredProgs (Map.insert name configuredProg') conf) + + +-- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. +-- +configurePrograms :: Verbosity + -> [Program] + -> ProgramDb + -> IO ProgramDb +configurePrograms verbosity progs conf = + foldM (flip (configureProgram verbosity)) conf progs + + +-- | Try to configure all the known programs that have not yet been configured. +-- +configureAllKnownPrograms :: Verbosity + -> ProgramDb + -> IO ProgramDb +configureAllKnownPrograms verbosity conf = + configurePrograms verbosity + [ prog | (prog,_,_) <- Map.elems notYetConfigured ] conf + where + notYetConfigured = unconfiguredProgs conf + `Map.difference` configuredProgs conf + + +-- | reconfigure a bunch of programs given new user-specified args. It takes +-- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs +-- with a new path it calls 'configureProgram'. +-- +reconfigurePrograms :: Verbosity + -> [(String, FilePath)] + -> [(String, [ProgArg])] + -> ProgramDb + -> IO ProgramDb +reconfigurePrograms verbosity paths argss conf = do + configurePrograms verbosity progs + . userSpecifyPaths paths + . userSpecifyArgss argss + $ conf + + where + progs = catMaybes [ lookupKnownProgram name conf | (name,_) <- paths ] + + +-- | Check that a program is configured and available to be run. +-- +-- It raises an exception if the program could not be configured, otherwise +-- it returns the configured program. +-- +requireProgram :: Verbosity -> Program -> ProgramDb + -> IO (ConfiguredProgram, ProgramDb) +requireProgram verbosity prog conf = do + + -- If it's not already been configured, try to configure it now + conf' <- case lookupProgram prog conf of + Nothing -> configureProgram verbosity prog conf + Just _ -> return conf + + case lookupProgram prog conf' of + Nothing -> die notFound + Just configuredProg -> return (configuredProg, conf') + + where notFound = "The program '" ++ programName prog + ++ "' is required but it could not be found." + + +-- | Check that a program is configured and available to be run. +-- +-- Additionally check that the program version number is suitable and return +-- it. For example you could require 'AnyVersion' or @'orLaterVersion' +-- ('Version' [1,0] [])@ +-- +-- It returns the configured program, its version number and a possibly updated +-- 'ProgramDb'. If the program could not be configured or the version is +-- unsuitable, it returns an error value. +-- +lookupProgramVersion + :: Verbosity -> Program -> VersionRange -> ProgramDb + -> IO (Either String (ConfiguredProgram, Version, ProgramDb)) +lookupProgramVersion verbosity prog range programDb = do + + -- If it's not already been configured, try to configure it now + programDb' <- case lookupProgram prog programDb of + Nothing -> configureProgram verbosity prog programDb + Just _ -> return programDb + + case lookupProgram prog programDb' of + Nothing -> return $! Left notFound + Just configuredProg@ConfiguredProgram { programLocation = location } -> + case programVersion configuredProg of + Just version + | withinRange version range -> + return $! Right (configuredProg, version ,programDb') + | otherwise -> + return $! Left (badVersion version location) + Nothing -> + return $! Left (noVersion location) + + where notFound = "The program '" + ++ programName prog ++ "'" ++ versionRequirement + ++ " is required but it could not be found." + badVersion v l = "The program '" + ++ programName prog ++ "'" ++ versionRequirement + ++ " is required but the version found at " + ++ locationPath l ++ " is version " ++ display v + noVersion l = "The program '" + ++ programName prog ++ "'" ++ versionRequirement + ++ " is required but the version of " + ++ locationPath l ++ " could not be determined." + versionRequirement + | isAnyVersion range = "" + | otherwise = " version " ++ display range + +-- | Like 'lookupProgramVersion', but raises an exception in case of error +-- instead of returning 'Left errMsg'. +-- +requireProgramVersion :: Verbosity -> Program -> VersionRange + -> ProgramDb + -> IO (ConfiguredProgram, Version, ProgramDb) +requireProgramVersion verbosity prog range programDb = + join $ either die return <$> + lookupProgramVersion verbosity prog range programDb diff --git a/Distribution/Simple/Program/Find.hs b/Distribution/Simple/Program/Find.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/Find.hs @@ -0,0 +1,126 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Types +-- Copyright : Duncan Coutts 2013 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A somewhat extended notion of the normal program search path concept. +-- +-- Usually when finding executables we just want to look in the usual places +-- using the OS's usual method for doing so. In Haskell the normal OS-specific +-- method is captured by 'findExecutable'. On all common OSs that makes use of +-- a @PATH@ environment variable, (though on Windows it is not just the @PATH@). +-- +-- However it is sometimes useful to be able to look in additional locations +-- without having to change the process-global @PATH@ environment variable. +-- So we need an extension of the usual 'findExecutable' that can look in +-- additional locations, either before, after or instead of the normal OS +-- locations. +-- +module Distribution.Simple.Program.Find ( + -- * Program search path + ProgramSearchPath, + ProgramSearchPathEntry(..), + defaultProgramSearchPath, + findProgramOnSearchPath, + programSearchPathAsPATHVar, + ) where + +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Simple.Utils + ( debug, doesExecutableExist ) +import Distribution.System + ( OS(..), buildOS ) +import System.Directory + ( findExecutable ) +import Distribution.Compat.Environment + ( getEnvironment ) +import System.FilePath + ( (), (<.>), splitSearchPath, searchPathSeparator ) +import Data.List + ( intercalate ) + + +-- | A search path to use when locating executables. This is analogous +-- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use +-- the system default method for finding executables ('findExecutable' which +-- on unix is simply looking on the @$PATH@ but on win32 is a bit more +-- complicated). +-- +-- The default to use is @[ProgSearchPathDefault]@ but you can add extra dirs +-- either before, after or instead of the default, e.g. here we add an extra +-- dir to search after the usual ones. +-- +-- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir] +-- +type ProgramSearchPath = [ProgramSearchPathEntry] +data ProgramSearchPathEntry = + ProgramSearchPathDir FilePath -- ^ A specific dir + | ProgramSearchPathDefault -- ^ The system default + +defaultProgramSearchPath :: ProgramSearchPath +defaultProgramSearchPath = [ProgramSearchPathDefault] + +findProgramOnSearchPath :: Verbosity -> ProgramSearchPath + -> FilePath -> IO (Maybe FilePath) +findProgramOnSearchPath verbosity searchpath prog = do + debug verbosity $ "Searching for " ++ prog ++ " in path." + res <- tryPathElems searchpath + case res of + Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") + Just path -> debug verbosity ("Found " ++ prog ++ " at "++ path) + return res + where + tryPathElems [] = return Nothing + tryPathElems (pe:pes) = do + res <- tryPathElem pe + case res of + Nothing -> tryPathElems pes + Just _ -> return res + + tryPathElem (ProgramSearchPathDir dir) = + findFirstExe [ dir prog <.> ext | ext <- extensions ] + where + -- Possible improvement: on Windows, read the list of extensions from + -- the PATHEXT environment variable. By default PATHEXT is ".com; .exe; + -- .bat; .cmd". + extensions = case buildOS of + Windows -> ["", "exe"] + Ghcjs -> ["", "exe"] + _ -> [""] + + 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 + case mExe of + Just exe -> do + exeExists <- doesExecutableExist exe + if exeExists + then return mExe + else return Nothing + _ -> return mExe + + findFirstExe [] = return Nothing + findFirstExe (f:fs) = do + isExe <- doesExecutableExist f + if isExe + then return (Just f) + else findFirstExe fs + +-- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var. +-- Note that this is close but not perfect because on Windows the search +-- algorithm looks at more than just the @%PATH%@. +programSearchPathAsPATHVar :: ProgramSearchPath -> IO String +programSearchPathAsPATHVar searchpath = do + ess <- mapM getEntries searchpath + return (intercalate [searchPathSeparator] (concat ess)) + where + getEntries (ProgramSearchPathDir dir) = return [dir] + getEntries ProgramSearchPathDefault = do + env <- getEnvironment + return (maybe [] splitSearchPath (lookup "PATH" env)) diff --git a/Distribution/Simple/Program/GHC.hs b/Distribution/Simple/Program/GHC.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/GHC.hs @@ -0,0 +1,562 @@ +{-# LANGUAGE CPP #-} +module Distribution.Simple.Program.GHC ( + GhcOptions(..), + GhcMode(..), + GhcOptimisation(..), + GhcDynLinkMode(..), + + ghcInvocation, + renderGhcOptions, + + runGHC, + + ) where + +import Distribution.Simple.GHC.ImplInfo ( getImplInfo, GhcImplInfo(..) ) +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.Program.Types +import Distribution.Simple.Program.Run +import Distribution.Text +import Distribution.Verbosity +import Distribution.Utils.NubList ( NubListR, fromNubListR ) +import Language.Haskell.Extension ( Language(..), Extension(..) ) + +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 +-- +data GhcOptions = GhcOptions { + + -- | The major mode for the ghc invocation. + ghcOptMode :: Flag GhcMode, + + -- | Any extra options to pass directly to ghc. These go at the end and hence + -- override other stuff. + ghcOptExtra :: NubListR String, + + -- | Extra default flags to pass directly to ghc. These go at the beginning + -- and so can be overridden by other stuff. + ghcOptExtraDefault :: NubListR String, + + ----------------------- + -- Inputs and outputs + + -- | The main input files; could be .hs, .hi, .c, .o, depending on mode. + ghcOptInputFiles :: NubListR FilePath, + + -- | The names of input Haskell modules, mainly for @--make@ mode. + ghcOptInputModules :: NubListR ModuleName, + + -- | Location for output file; the @ghc -o@ flag. + ghcOptOutputFile :: Flag FilePath, + + -- | Location for dynamic output file in 'GhcStaticAndDynamic' mode; + -- the @ghc -dyno@ flag. + ghcOptOutputDynFile :: Flag FilePath, + + -- | Start with an empty search path for Haskell source files; + -- the @ghc -i@ flag (@-i@ on it's own with no path argument). + ghcOptSourcePathClear :: Flag Bool, + + -- | Search path for Haskell source files; the @ghc -i@ flag. + ghcOptSourcePath :: NubListR FilePath, + + ------------- + -- Packages + + -- | The package key the modules will belong to; the @ghc -this-package-key@ + -- flag. + ghcOptPackageKey :: Flag PackageKey, + + -- | GHC package databases to use, the @ghc -package-conf@ flag. + ghcOptPackageDBs :: PackageDBStack, + + -- | The GHC packages to use. For compatability with old and new ghc, this + -- requires both the short and long form of the package id; + -- the @ghc -package@ or @ghc -package-id@ flags. + ghcOptPackages :: + NubListR (InstalledPackageId, PackageId, ModuleRenaming), + + -- | Start with a clean package set; the @ghc -hide-all-packages@ flag + ghcOptHideAllPackages :: Flag Bool, + + -- | Don't automatically link in Haskell98 etc; the @ghc + -- -no-auto-link-packages@ flag. + ghcOptNoAutoLinkPackages :: Flag Bool, + + -- | What packages are implementing the signatures + ghcOptSigOf :: [(ModuleName, (PackageKey, ModuleName))], + + ----------------- + -- Linker stuff + + -- | Names of libraries to link in; the @ghc -l@ flag. + ghcOptLinkLibs :: NubListR FilePath, + + -- | Search path for libraries to link in; the @ghc -L@ flag. + ghcOptLinkLibPath :: NubListR FilePath, + + -- | Options to pass through to the linker; the @ghc -optl@ flag. + ghcOptLinkOptions :: NubListR String, + + -- | OSX only: frameworks to link in; the @ghc -framework@ flag. + ghcOptLinkFrameworks :: NubListR String, + + -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag. + ghcOptNoLink :: Flag Bool, + + -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ + -- flag. + ghcOptLinkNoHsMain :: Flag Bool, + + -------------------- + -- C and CPP stuff + + -- | Options to pass through to the C compiler; the @ghc -optc@ flag. + ghcOptCcOptions :: NubListR String, + + -- | Options to pass through to CPP; the @ghc -optP@ flag. + ghcOptCppOptions :: NubListR String, + + -- | Search path for CPP includes like header files; the @ghc -I@ flag. + ghcOptCppIncludePath :: NubListR FilePath, + + -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag. + ghcOptCppIncludes :: NubListR FilePath, + + -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag. + ghcOptFfiIncludes :: NubListR FilePath, + + ---------------------------- + -- Language and extensions + + -- | The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag. + ghcOptLanguage :: Flag Language, + + -- | The language extensions; the @ghc -X@ flag. + ghcOptExtensions :: NubListR Extension, + + -- | A GHC version-dependent mapping of extensions to flags. This must be + -- set to be able to make use of the 'ghcOptExtensions'. + ghcOptExtensionMap :: M.Map Extension String, + + ---------------- + -- Compilation + + -- | What optimisation level to use; the @ghc -O@ flag. + ghcOptOptimisation :: Flag GhcOptimisation, + + -- | Emit debug info; the @ghc -g@ flag. + ghcOptDebugInfo :: Flag Bool, + + -- | Compile in profiling mode; the @ghc -prof@ flag. + ghcOptProfilingMode :: Flag Bool, + + -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag. + ghcOptSplitObjs :: Flag Bool, + + -- | Run N jobs simultaneously (if possible). + ghcOptNumJobs :: Flag (Maybe Int), + + -- | Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags. + ghcOptHPCDir :: Flag FilePath, + + ---------------- + -- GHCi + + -- | Extra GHCi startup scripts; the @-ghci-script@ flag + ghcOptGHCiScripts :: NubListR FilePath, + + ------------------------ + -- Redirecting outputs + + ghcOptHiSuffix :: Flag String, + ghcOptObjSuffix :: Flag String, + ghcOptDynHiSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode + ghcOptDynObjSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode + ghcOptHiDir :: Flag FilePath, + ghcOptObjDir :: Flag FilePath, + ghcOptOutputDir :: Flag FilePath, + ghcOptStubDir :: Flag FilePath, + + -------------------- + -- Dynamic linking + + ghcOptDynLinkMode :: Flag GhcDynLinkMode, + ghcOptShared :: Flag Bool, + ghcOptFPic :: Flag Bool, + ghcOptDylibName :: Flag String, + ghcOptRPaths :: NubListR FilePath, + + --------------- + -- Misc flags + + -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. + ghcOptVerbosity :: Flag Verbosity, + + -- | Let GHC know that it is Cabal that's calling it. + -- Modifies some of the GHC error messages. + ghcOptCabal :: Flag Bool + +} deriving Show + + +data GhcMode = GhcModeCompile -- ^ @ghc -c@ + | GhcModeLink -- ^ @ghc@ + | GhcModeMake -- ^ @ghc --make@ + | GhcModeInteractive -- ^ @ghci@ \/ @ghc --interactive@ + | GhcModeAbiHash -- ^ @ghc --abi-hash@ +-- | GhcModeDepAnalysis -- ^ @ghc -M@ +-- | GhcModeEvaluate -- ^ @ghc -e@ + deriving (Show, Eq) + +data GhcOptimisation = GhcNoOptimisation -- ^ @-O0@ + | GhcNormalOptimisation -- ^ @-O@ + | GhcMaximumOptimisation -- ^ @-O2@ + | GhcSpecialOptimisation String -- ^ e.g. @-Odph@ + deriving (Show, Eq) + +data GhcDynLinkMode = GhcStaticOnly -- ^ @-static@ + | GhcDynamicOnly -- ^ @-dynamic@ + | GhcStaticAndDynamic -- ^ @-static -dynamic-too@ + deriving (Show, Eq) + + +runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> GhcOptions -> IO () +runGHC verbosity ghcProg comp opts = do + runProgramInvocation verbosity (ghcInvocation ghcProg comp opts) + + +ghcInvocation :: ConfiguredProgram -> Compiler -> GhcOptions -> ProgramInvocation +ghcInvocation prog comp opts = + programInvocation prog (renderGhcOptions comp opts) + +renderGhcOptions :: Compiler -> GhcOptions -> [String] +renderGhcOptions comp opts + | compilerFlavor comp `notElem` [GHC, GHCJS] = + error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " + ++ "compiler flavor must be 'GHC' or 'GHCJS'!" + | otherwise = + concat + [ case flagToMaybe (ghcOptMode opts) of + Nothing -> [] + Just GhcModeCompile -> ["-c"] + Just GhcModeLink -> [] + Just GhcModeMake -> ["--make"] + Just GhcModeInteractive -> ["--interactive"] + Just GhcModeAbiHash -> ["--abi-hash"] +-- Just GhcModeDepAnalysis -> ["-M"] +-- Just GhcModeEvaluate -> ["-e", expr] + + , flags ghcOptExtraDefault + + , [ "-no-link" | flagBool ghcOptNoLink ] + + --------------- + -- Misc flags + + , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts)) + + , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal + , flagBuildingCabalPkg implInfo ] + + ---------------- + -- Compilation + + , case flagToMaybe (ghcOptOptimisation opts) of + Nothing -> [] + Just GhcNoOptimisation -> ["-O0"] + Just GhcNormalOptimisation -> ["-O"] + Just GhcMaximumOptimisation -> ["-O2"] + Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph + + , [ "-g" | flagDebugInfo implInfo && flagBool ghcOptDebugInfo ] + + , [ "-prof" | flagBool ghcOptProfilingMode ] + + , [ "-split-objs" | flagBool ghcOptSplitObjs ] + + , case flagToMaybe (ghcOptHPCDir opts) of + Nothing -> [] + Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir] + + , if parmakeSupported comp + then case ghcOptNumJobs opts of + NoFlag -> [] + Flag n -> ["-j" ++ maybe "" show n] + else [] + + -------------------- + -- Dynamic linking + + , [ "-shared" | flagBool ghcOptShared ] + , case flagToMaybe (ghcOptDynLinkMode opts) of + Nothing -> [] + Just GhcStaticOnly -> ["-static"] + Just GhcDynamicOnly -> ["-dynamic"] + Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"] + , [ "-fPIC" | flagBool ghcOptFPic ] + + , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ] + + ------------------------ + -- Redirecting outputs + + , concat [ ["-osuf", suf] | suf <- flag ghcOptObjSuffix ] + , concat [ ["-hisuf", suf] | suf <- flag ghcOptHiSuffix ] + , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ] + , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix ] + , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir + , flagOutputDir implInfo ] + , concat [ ["-odir", dir] | dir <- flag ghcOptObjDir ] + , concat [ ["-hidir", dir] | dir <- flag ghcOptHiDir ] + , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir + , flagStubdir implInfo ] + + ----------------------- + -- Source search path + + , [ "-i" | flagBool ghcOptSourcePathClear ] + , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ] + + -------------------- + -- C and CPP stuff + + , [ "-I" ++ dir | dir <- flags ghcOptCppIncludePath ] + , [ "-optP" ++ opt | opt <- flags ghcOptCppOptions ] + , concat [ [ "-optP-include", "-optP" ++ inc] + | inc <- flags ghcOptCppIncludes ] + , [ "-#include \"" ++ inc ++ "\"" + | inc <- flags ghcOptFfiIncludes, flagFfiIncludes implInfo ] + , [ "-optc" ++ opt | opt <- flags ghcOptCcOptions ] + + ----------------- + -- Linker stuff + + , [ "-optl" ++ opt | opt <- flags ghcOptLinkOptions ] + , ["-l" ++ lib | lib <- flags ghcOptLinkLibs ] + , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath ] + , concat [ ["-framework", fmwk] | fmwk <- flags ghcOptLinkFrameworks ] + , [ "-no-hs-main" | flagBool ghcOptLinkNoHsMain ] + , [ "-dynload deploy" | not (null (flags ghcOptRPaths)) ] + , concat [ [ "-optl-Wl,-rpath," ++ dir] + | dir <- flags ghcOptRPaths ] + + ------------- + -- Packages + + , concat [ [if packageKeySupported comp + then "-this-package-key" + else "-package-name", display pkgid] + | pkgid <- flag ghcOptPackageKey ] + + , [ "-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 + in [ ["-package-id", display ipkgid ++ space (display rns)] + | (ipkgid,_,rns) <- flags ghcOptPackages ] + else [ ["-package", display pkgid] + | (_,pkgid,_) <- flags ghcOptPackages ] + + ---------------------------- + -- Language and extensions + + , if supportsHaskell2010 implInfo + then [ "-X" ++ display lang | lang <- flag ghcOptLanguage ] + else [] + + , [ case M.lookup ext (ghcOptExtensionMap opts) of + Just arg -> arg + Nothing -> error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " + ++ display ext ++ " not present in ghcOptExtensionMap." + | ext <- flags ghcOptExtensions ] + + ---------------- + -- GHCi + + , concat [ [ "-ghci-script", script ] | script <- flags ghcOptGHCiScripts + , flagGhciScript implInfo ] + + --------------- + -- Inputs + + , [ display modu | modu <- flags ghcOptInputModules ] + , flags ghcOptInputFiles + + , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ] + , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ] + + --------------- + -- Extra + + , flags ghcOptExtra + + ] + + + where + implInfo = getImplInfo comp + flag flg = flagToList (flg opts) + flags flg = fromNubListR . flg $ opts + flagBool flg = fromFlagOrDefault False (flg opts) + +verbosityOpts :: Verbosity -> [String] +verbosityOpts verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-w", "-v0"] + + +packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String] +packageDbArgs implInfo dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> ("-no-user-" ++ packageDbFlag) + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ '-':packageDbFlag , db ] + specific _ = ierror + ierror = error $ "internal error: unexpected package db stack: " + ++ show dbstack + packageDbFlag + | flagPackageConf implInfo + = "package-conf" + | otherwise + = "package-db" + + +-- ----------------------------------------------------------------------------- +-- Boilerplate Monoid instance for GhcOptions + +instance Monoid GhcOptions where + mempty = GhcOptions { + ghcOptMode = mempty, + ghcOptExtra = mempty, + ghcOptExtraDefault = mempty, + ghcOptInputFiles = mempty, + ghcOptInputModules = mempty, + ghcOptOutputFile = mempty, + 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 diff --git a/Distribution/Simple/Program/HcPkg.hs b/Distribution/Simple/Program/HcPkg.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/HcPkg.hs @@ -0,0 +1,396 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.HcPkg +-- Copyright : Duncan Coutts 2009, 2013 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hc-pkg@ program. +-- Currently only GHC, GHCJS and LHC have hc-pkg programs. + +module Distribution.Simple.Program.HcPkg ( + HcPkgInfo(..), + + init, + invoke, + register, + reregister, + unregister, + expose, + hide, + dump, + list, + + -- * Program invocations + initInvocation, + registerInvocation, + reregisterInvocation, + unregisterInvocation, + exposeInvocation, + hideInvocation, + dumpInvocation, + listInvocation, + ) where + +import Prelude hiding (init) +import Distribution.Package + ( PackageId, InstalledPackageId(..) ) +import Distribution.InstalledPackageInfo + ( 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 Data.Char + ( isSpace ) +import Data.List + ( stripPrefix ) +import System.FilePath as FilePath + ( (), splitPath, splitDirectories, joinPath, isPathSeparator ) +import qualified System.FilePath.Posix as FilePath.Posix + +-- | Information about the features and capabilities of an @hc-pkg@ +-- program. +-- +data HcPkgInfo = HcPkgInfo + { hcPkgProgram :: ConfiguredProgram + , 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 + } + +-- | 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) + +-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the +-- provided command-line arguments to it. +invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO () +invoke hpi verbosity dbStack extraArgs = + runProgramInvocation verbosity invocation + where + args = packageDbStackOpts hpi dbStack ++ extraArgs + invocation = programInvocation (hcPkgProgram hpi) args + +-- | Call @hc-pkg@ to register a package. +-- +-- > hc-pkg register {filename | -} [--user | --global | --package-db] +-- +register :: HcPkgInfo -> Verbosity -> PackageDBStack + -> Either FilePath + InstalledPackageInfo + -> IO () +register hpi verbosity packagedb pkgFile = + runProgramInvocation verbosity + (registerInvocation hpi verbosity packagedb pkgFile) + + +-- | Call @hc-pkg@ to re-register a package. +-- +-- > hc-pkg register {filename | -} [--user | --global | --package-db] +-- +reregister :: HcPkgInfo -> Verbosity -> PackageDBStack + -> Either FilePath + InstalledPackageInfo + -> IO () +reregister hpi verbosity packagedb pkgFile = + runProgramInvocation verbosity + (reregisterInvocation hpi verbosity packagedb pkgFile) + + +-- | Call @hc-pkg@ to unregister a package +-- +-- > hc-pkg unregister [pkgid] [--user | --global | --package-db] +-- +unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () +unregister hpi verbosity packagedb pkgid = + runProgramInvocation verbosity + (unregisterInvocation hpi verbosity packagedb pkgid) + + +-- | Call @hc-pkg@ to expose a package. +-- +-- > hc-pkg expose [pkgid] [--user | --global | --package-db] +-- +expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () +expose hpi verbosity packagedb pkgid = + runProgramInvocation verbosity + (exposeInvocation hpi verbosity packagedb pkgid) + + +-- | Call @hc-pkg@ to hide a package. +-- +-- > hc-pkg hide [pkgid] [--user | --global | --package-db] +-- +hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () +hide hpi verbosity packagedb pkgid = + runProgramInvocation verbosity + (hideInvocation hpi verbosity packagedb pkgid) + + +-- | Call @hc-pkg@ to get all the details of all the packages in the given +-- package database. +-- +dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo] +dump hpi verbosity packagedb = do + + output <- getProgramInvocationOutput verbosity + (dumpInvocation hpi verbosity packagedb) + `catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed" + + case parsePackages output of + Left ok -> return ok + _ -> die $ "failed to parse output of '" + ++ programId (hcPkgProgram hpi) ++ " dump'" + + 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 + + splitWith :: (a -> Bool) -> [a] -> [[a]] + splitWith p xs = ys : case zs of + [] -> [] + _:ws -> splitWith p ws + where (ys,zs) = break p xs + +mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +mungePackagePaths pkgroot pkginfo = + pkginfo { + importDirs = mungePaths (importDirs pkginfo), + includeDirs = mungePaths (includeDirs pkginfo), + libraryDirs = mungePaths (libraryDirs pkginfo), + frameworkDirs = mungePaths (frameworkDirs pkginfo), + haddockInterfaces = mungePaths (haddockInterfaces pkginfo), + haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) + } + where + mungePaths = map mungePath + mungeUrls = map mungeUrl + + mungePath p = case stripVarPrefix "${pkgroot}" p of + Just p' -> pkgroot p' + Nothing -> p + + mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of + Just p' -> toUrlPath pkgroot p' + Nothing -> p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) + + stripVarPrefix var p = + case splitPath p of + (root:path') -> case stripPrefix var root of + Just [sep] | isPathSeparator sep -> Just (joinPath path') + _ -> Nothing + _ -> Nothing + + +-- Older installed package info files did not have the installedPackageId +-- field, so if it is missing then we fill it as the source package ID. +setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo +setInstalledPackageId pkginfo@InstalledPackageInfo { + installedPackageId = InstalledPackageId "", + sourcePackageId = pkgid + } + = pkginfo { + --TODO use a proper named function for the conversion + -- from source package id to installed package id + installedPackageId = InstalledPackageId (display pkgid) + } +setInstalledPackageId pkginfo = pkginfo + + +-- | Call @hc-pkg@ to get the source package Id of all the packages in the +-- given package database. +-- +-- This is much less information than with 'dump', but also rather quicker. +-- Note in particular that it does not include the 'InstalledPackageId', just +-- the source 'PackageId' which is not necessarily unique in any package db. +-- +list :: HcPkgInfo -> Verbosity -> PackageDB + -> IO [PackageId] +list hpi verbosity packagedb = do + + output <- getProgramInvocationOutput verbosity + (listInvocation hpi verbosity packagedb) + `catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed" + + case parsePackageIds output of + Just ok -> return ok + _ -> die $ "failed to parse output of '" + ++ programId (hcPkgProgram hpi) ++ " list'" + + where + parsePackageIds = sequence . map simpleParse . words + +-------------------------- +-- The program invocations +-- + +initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation +initInvocation hpi verbosity path = + programInvocation (hcPkgProgram hpi) args + where + args = ["init", path] + ++ verbosityOpts hpi verbosity + +registerInvocation, reregisterInvocation + :: HcPkgInfo -> Verbosity -> PackageDBStack + -> Either FilePath InstalledPackageInfo + -> ProgramInvocation +registerInvocation = registerInvocation' "register" +reregisterInvocation = registerInvocation' "update" + + +registerInvocation' :: String -> 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 hpi verbosity packagedbs (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 + + +unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId + -> ProgramInvocation +unregisterInvocation hpi verbosity packagedb pkgid = + programInvocation (hcPkgProgram hpi) $ + ["unregister", packageDbOpts hpi packagedb, display pkgid] + ++ verbosityOpts hpi verbosity + + +exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId + -> ProgramInvocation +exposeInvocation hpi verbosity packagedb pkgid = + programInvocation (hcPkgProgram hpi) $ + ["expose", packageDbOpts hpi packagedb, display pkgid] + ++ verbosityOpts hpi verbosity + + +hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId + -> ProgramInvocation +hideInvocation hpi verbosity packagedb pkgid = + programInvocation (hcPkgProgram hpi) $ + ["hide", packageDbOpts hpi packagedb, display pkgid] + ++ verbosityOpts hpi verbosity + + +dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation +dumpInvocation hpi _verbosity packagedb = + (programInvocation (hcPkgProgram hpi) args) { + progInvokeOutputEncoding = IOEncodingUTF8 + } + where + args = ["dump", packageDbOpts hpi packagedb] + ++ verbosityOpts hpi silent + -- We use verbosity level 'silent' because it is important that we + -- do not contaminate the output with info/debug messages. + +listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation +listInvocation hpi _verbosity packagedb = + (programInvocation (hcPkgProgram hpi) args) { + progInvokeOutputEncoding = IOEncodingUTF8 + } + where + args = ["list", "--simple-output", packageDbOpts hpi packagedb] + ++ verbosityOpts hpi silent + -- We use verbosity level 'silent' because it is important that we + -- do not contaminate the output with info/debug messages. + + +packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String] +packageDbStackOpts hpi dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> "--global" + : "--user" + : map specific dbs + (GlobalPackageDB:dbs) -> "--global" + : ("--no-user-" ++ packageDbFlag hpi) + : map specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db + specific _ = ierror + ierror :: a + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + +packageDbFlag :: HcPkgInfo -> String +packageDbFlag hpi + | flagPackageConf hpi + = "package-conf" + | otherwise + = "package-db" + +packageDbOpts :: HcPkgInfo -> PackageDB -> String +packageDbOpts _ GlobalPackageDB = "--global" +packageDbOpts _ UserPackageDB = "--user" +packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db + +verbosityOpts :: HcPkgInfo -> Verbosity -> [String] +verbosityOpts hpi v + | noVerboseFlag hpi + = [] + | v >= deafening = ["-v2"] + | v == silent = ["-v0"] + | otherwise = [] + diff --git a/Distribution/Simple/Program/Hpc.hs b/Distribution/Simple/Program/Hpc.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/Hpc.hs @@ -0,0 +1,100 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Hpc +-- Copyright : Thomas Tuegel 2011 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hpc@ program. + +module Distribution.Simple.Program.Hpc + ( markup + , union + ) where + +import Distribution.ModuleName ( ModuleName ) +import Distribution.Simple.Program.Run + ( ProgramInvocation, programInvocation, runProgramInvocation ) +import Distribution.Simple.Program.Types ( ConfiguredProgram(..) ) +import Distribution.Text ( display ) +import Distribution.Simple.Utils ( warn ) +import Distribution.Verbosity ( Verbosity ) +import Distribution.Version ( Version(..), orLaterVersion, withinRange ) + +-- | Invoke hpc with the given parameters. +-- +-- Prior to HPC version 0.7 (packaged with GHC 7.8), hpc did not handle +-- multiple .mix paths correctly, so we print a warning, and only pass it the +-- first path in the list. This means that e.g. test suites that import their +-- library as a dependency can still work, but those that include the library +-- modules directly (in other-modules) don't. +markup :: ConfiguredProgram + -> Version + -> Verbosity + -> FilePath -- ^ Path to .tix file + -> [FilePath] -- ^ Paths to .mix file directories + -> FilePath -- ^ Path where html output should be located + -> [ModuleName] -- ^ List of modules to exclude from report + -> IO () +markup hpc hpcVer verbosity tixFile hpcDirs destDir excluded = do + hpcDirs' <- if withinRange hpcVer (orLaterVersion version07) + then return hpcDirs + else do + warn verbosity $ "Your version of HPC (" ++ display hpcVer + ++ ") does not properly handle multiple search paths. " + ++ "Coverage report generation may fail unexpectedly. These " + ++ "issues are addressed in version 0.7 or later (GHC 7.8 or " + ++ "later)." + ++ if null droppedDirs + then "" + else " The following search paths have been abandoned: " + ++ show droppedDirs + return passedDirs + + runProgramInvocation verbosity + (markupInvocation hpc tixFile hpcDirs' destDir excluded) + where + version07 = Version [0, 7] [] + (passedDirs, droppedDirs) = splitAt 1 hpcDirs + +markupInvocation :: ConfiguredProgram + -> FilePath -- ^ Path to .tix file + -> [FilePath] -- ^ Paths to .mix file directories + -> FilePath -- ^ Path where html output should be + -- located + -> [ModuleName] -- ^ List of modules to exclude from + -- report + -> ProgramInvocation +markupInvocation hpc tixFile hpcDirs destDir excluded = + let args = [ "markup", tixFile + , "--destdir=" ++ destDir + ] + ++ map ("--hpcdir=" ++) hpcDirs + ++ ["--exclude=" ++ display moduleName + | moduleName <- excluded ] + in programInvocation hpc args + +union :: ConfiguredProgram + -> Verbosity + -> [FilePath] -- ^ Paths to .tix files + -> FilePath -- ^ Path to resultant .tix file + -> [ModuleName] -- ^ List of modules to exclude from union + -> IO () +union hpc verbosity tixFiles outFile excluded = + runProgramInvocation verbosity + (unionInvocation hpc tixFiles outFile excluded) + +unionInvocation :: ConfiguredProgram + -> [FilePath] -- ^ Paths to .tix files + -> FilePath -- ^ Path to resultant .tix file + -> [ModuleName] -- ^ List of modules to exclude from union + -> ProgramInvocation +unionInvocation hpc tixFiles outFile excluded = + programInvocation hpc $ concat + [ ["sum", "--union"] + , tixFiles + , ["--output=" ++ outFile] + , ["--exclude=" ++ display moduleName + | moduleName <- excluded ] + ] diff --git a/Distribution/Simple/Program/Ld.hs b/Distribution/Simple/Program/Ld.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/Ld.hs @@ -0,0 +1,62 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Ld +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @ld@ linker program. + +module Distribution.Simple.Program.Ld ( + combineObjectFiles, + ) where + +import Distribution.Simple.Program.Types + ( ConfiguredProgram(..) ) +import Distribution.Simple.Program.Run + ( programInvocation, multiStageProgramInvocation + , runProgramInvocation ) +import Distribution.Verbosity + ( Verbosity ) + +import System.Directory + ( renameFile ) +import System.FilePath + ( (<.>) ) + +-- | Call @ld -r@ to link a bunch of object files together. +-- +combineObjectFiles :: Verbosity -> ConfiguredProgram + -> FilePath -> [FilePath] -> IO () +combineObjectFiles verbosity ld target files = + + -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is, + -- if we have more object files than fit on a single command line then we + -- have a slight problem. What we have to do is link files in batches into + -- a temp object file and then include that one in the next batch. + + let simpleArgs = ["-r", "-o", target] + + initialArgs = ["-r", "-o", target] + middleArgs = ["-r", "-o", target, tmpfile] + finalArgs = middleArgs + + simple = programInvocation ld simpleArgs + initial = programInvocation ld initialArgs + middle = programInvocation ld middleArgs + final = programInvocation ld finalArgs + + invocations = multiStageProgramInvocation + simple (initial, middle, final) files + + in run invocations + + where + tmpfile = target <.> "tmp" -- perhaps should use a proper temp file + + run [] = return () + run [inv] = runProgramInvocation verbosity inv + run (inv:invs) = do runProgramInvocation verbosity inv + renameFile target tmpfile + run invs diff --git a/Distribution/Simple/Program/Run.hs b/Distribution/Simple/Program/Run.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/Run.hs @@ -0,0 +1,257 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Run +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides a data type for program invocations and functions to +-- run them. + +module Distribution.Simple.Program.Run ( + ProgramInvocation(..), + IOEncoding(..), + emptyProgramInvocation, + simpleProgramInvocation, + programInvocation, + multiStageProgramInvocation, + + runProgramInvocation, + getProgramInvocationOutput, + + getEffectiveEnvironment, + ) where + +import Distribution.Simple.Program.Types + ( ConfiguredProgram(..), programPath ) +import Distribution.Simple.Utils + ( die, rawSystemExit, rawSystemIOWithEnv, rawSystemStdInOut + , toUTF8, fromUTF8, normaliseLineEndings ) +import Distribution.Verbosity + ( Verbosity ) + +import Data.List + ( foldl', unfoldr ) +import qualified Data.Map as Map +import Control.Monad + ( when ) +import System.Exit + ( ExitCode(..), exitWith ) +import Distribution.Compat.Environment + ( getEnvironment ) + +-- | Represents a specific invocation of a specific program. +-- +-- This is used as an intermediate type between deciding how to call a program +-- and actually doing it. This provides the opportunity to the caller to +-- adjust how the program will be called. These invocations can either be run +-- directly or turned into shell or batch scripts. +-- +data ProgramInvocation = ProgramInvocation { + progInvokePath :: FilePath, + progInvokeArgs :: [String], + progInvokeEnv :: [(String, Maybe String)], + progInvokeCwd :: Maybe FilePath, + progInvokeInput :: Maybe String, + progInvokeInputEncoding :: IOEncoding, + progInvokeOutputEncoding :: IOEncoding + } + +data IOEncoding = IOEncodingText -- locale mode text + | IOEncodingUTF8 -- always utf8 + +emptyProgramInvocation :: ProgramInvocation +emptyProgramInvocation = + ProgramInvocation { + progInvokePath = "", + progInvokeArgs = [], + progInvokeEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Nothing, + progInvokeInputEncoding = IOEncodingText, + progInvokeOutputEncoding = IOEncodingText + } + +simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation +simpleProgramInvocation path args = + emptyProgramInvocation { + progInvokePath = path, + progInvokeArgs = args + } + +programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation +programInvocation prog args = + emptyProgramInvocation { + progInvokePath = programPath prog, + progInvokeArgs = programDefaultArgs prog + ++ args + ++ programOverrideArgs prog, + progInvokeEnv = programOverrideEnv prog + } + + +runProgramInvocation :: Verbosity -> ProgramInvocation -> IO () +runProgramInvocation verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Nothing + } = + rawSystemExit verbosity path args + +runProgramInvocation verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envOverrides, + progInvokeCwd = mcwd, + progInvokeInput = Nothing + } = do + menv <- getEffectiveEnvironment envOverrides + exitCode <- rawSystemIOWithEnv verbosity + path args + mcwd menv + Nothing Nothing Nothing + when (exitCode /= ExitSuccess) $ + exitWith exitCode + +runProgramInvocation verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envOverrides, + progInvokeCwd = mcwd, + progInvokeInput = Just inputStr, + progInvokeInputEncoding = encoding + } = do + menv <- getEffectiveEnvironment envOverrides + (_, errors, exitCode) <- rawSystemStdInOut verbosity + path args + mcwd menv + (Just input) True + when (exitCode /= ExitSuccess) $ + die $ "'" ++ path ++ "' exited with an error:\n" ++ errors + where + input = case encoding of + IOEncodingText -> (inputStr, False) + IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for + -- utf8 + + +getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String +getProgramInvocationOutput verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envOverrides, + progInvokeCwd = mcwd, + progInvokeInput = minputStr, + progInvokeOutputEncoding = encoding + } = do + let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False + decode | utf8 = fromUTF8 . normaliseLineEndings + | otherwise = id + menv <- getEffectiveEnvironment envOverrides + (output, errors, exitCode) <- rawSystemStdInOut verbosity + path args + mcwd menv + input utf8 + when (exitCode /= ExitSuccess) $ + die $ "'" ++ path ++ "' exited with an error:\n" ++ errors + return (decode output) + where + input = + case minputStr of + Nothing -> Nothing + Just inputStr -> Just $ + case encoding of + IOEncodingText -> (inputStr, False) + IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8 + + +-- | Return the current environment extended with the given overrides. +-- +getEffectiveEnvironment :: [(String, Maybe String)] + -> IO (Maybe [(String, String)]) +getEffectiveEnvironment [] = return Nothing +getEffectiveEnvironment overrides = + fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment + where + apply os env = foldl' (flip update) env os + update (var, Nothing) = Map.delete var + update (var, Just val) = Map.insert var val + +-- | Like the unix xargs program. Useful for when we've got very long command +-- lines that might overflow an OS limit on command line length and so you +-- need to invoke a command multiple times to get all the args in. +-- +-- It takes four template invocations corresponding to the simple, initial, +-- middle and last invocations. If the number of args given is small enough +-- that we can get away with just a single invocation then the simple one is +-- used: +-- +-- > $ simple args +-- +-- If the number of args given means that we need to use multiple invocations +-- then the templates for the initial, middle and last invocations are used: +-- +-- > $ initial args_0 +-- > $ middle args_1 +-- > $ middle args_2 +-- > ... +-- > $ final args_n +-- +multiStageProgramInvocation + :: ProgramInvocation + -> (ProgramInvocation, ProgramInvocation, ProgramInvocation) + -> [String] + -> [ProgramInvocation] +multiStageProgramInvocation simple (initial, middle, final) args = + + let argSize inv = length (progInvokePath inv) + + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) + fixedArgSize = maximum (map argSize [simple, initial, middle, final]) + chunkSize = maxCommandLineSize - fixedArgSize + + in case splitChunks chunkSize args of + [] -> [ simple ] + + [c] -> [ simple `appendArgs` c ] + + [c,c'] -> [ initial `appendArgs` c ] + ++ [ final `appendArgs` c'] + + (c:cs) -> [ initial `appendArgs` c ] + ++ [ middle `appendArgs` c'| c' <- init cs ] + ++ [ final `appendArgs` c'| let c' = last cs ] + + where + inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as } + + splitChunks len = unfoldr $ \s -> + if null s then Nothing + else Just (chunk len s) + + chunk len (s:_) | length s >= len = error toolong + chunk len ss = chunk' [] len ss + + chunk' acc _ [] = (reverse acc,[]) + chunk' acc len (s:ss) + | len' < len = chunk' (s:acc) (len-len'-1) ss + | otherwise = (reverse acc, s:ss) + where len' = length s + + toolong = "multiStageProgramInvocation: a single program arg is larger " + ++ "than the maximum command line length!" + + +--FIXME: discover this at configure time or runtime on unix +-- The value is 32k on Windows and posix specifies a minimum of 4k +-- but all sensible unixes use more than 4k. +-- we could use getSysVar ArgumentLimit but that's in the unix lib +-- +maxCommandLineSize :: Int +maxCommandLineSize = 30 * 1024 diff --git a/Distribution/Simple/Program/Script.hs b/Distribution/Simple/Program/Script.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/Script.hs @@ -0,0 +1,110 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Script +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hc-pkg@ program. +-- Currently only GHC and LHC have hc-pkg programs. + +module Distribution.Simple.Program.Script ( + + invocationAsSystemScript, + invocationAsShellScript, + invocationAsBatchFile, + ) where + +import Distribution.Simple.Program.Run + ( ProgramInvocation(..) ) +import Distribution.System + ( OS(..) ) + +import Data.Maybe + ( maybeToList ) + +-- | Generate a system script, either POSIX shell script or Windows batch file +-- as appropriate for the given system. +-- +invocationAsSystemScript :: OS -> ProgramInvocation -> String +invocationAsSystemScript Windows = invocationAsBatchFile +invocationAsSystemScript _ = invocationAsShellScript + + +-- | Generate a POSIX shell script that invokes a program. +-- +invocationAsShellScript :: ProgramInvocation -> String +invocationAsShellScript + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envExtra, + progInvokeCwd = mcwd, + progInvokeInput = minput + } = unlines $ + [ "#!/bin/sh" ] + ++ concatMap setEnv envExtra + ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ] + ++ [ (case minput of + Nothing -> "" + Just input -> "echo " ++ quote input ++ " | ") + ++ unwords (map quote $ path : args) ++ " \"$@\""] + + where + setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var] + setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val] + + quote :: String -> String + quote s = "'" ++ escape s ++ "'" + + escape [] = [] + escape ('\'':cs) = "'\\''" ++ escape cs + escape (c :cs) = c : escape cs + + +-- | Generate a Windows batch file that invokes a program. +-- +invocationAsBatchFile :: ProgramInvocation -> String +invocationAsBatchFile + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envExtra, + progInvokeCwd = mcwd, + progInvokeInput = minput + } = unlines $ + [ "@echo off" ] + ++ map setEnv envExtra + ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ] + ++ case minput of + Nothing -> + [ path ++ concatMap (' ':) args ] + + Just input -> + [ "(" ] + ++ [ "echo " ++ escape line | line <- lines input ] + ++ [ ") | " + ++ "\"" ++ path ++ "\"" + ++ concatMap (\arg -> ' ':quote arg) args ] + + where + setEnv (var, Nothing) = "set " ++ var ++ "=" + setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val + + quote :: String -> String + quote s = "\"" ++ escapeQ s ++ "\"" + + escapeQ [] = [] + escapeQ ('"':cs) = "\"\"\"" ++ escapeQ cs + escapeQ (c :cs) = c : escapeQ cs + + escape [] = [] + escape ('|':cs) = "^|" ++ escape cs + escape ('<':cs) = "^<" ++ escape cs + escape ('>':cs) = "^>" ++ escape cs + escape ('&':cs) = "^&" ++ escape cs + escape ('(':cs) = "^(" ++ escape cs + escape (')':cs) = "^)" ++ escape cs + escape ('^':cs) = "^^" ++ escape cs + escape (c :cs) = c : escape cs diff --git a/Distribution/Simple/Program/Strip.hs b/Distribution/Simple/Program/Strip.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/Strip.hs @@ -0,0 +1,72 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Strip +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @strip@ program. + +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 Control.Monad (unless) +import Data.Version (Version(..)) +import System.FilePath (takeBaseName) + +runStrip :: Verbosity -> ProgramConfiguration -> FilePath -> [String] -> IO () +runStrip verbosity progConf path args = + case lookupProgram stripProgram progConf of + Just strip -> rawSystemProgram verbosity strip (path:args) + Nothing -> unless (buildOS == Windows) $ + -- Don't bother warning on windows, we don't expect them to + -- have the strip program anyway. + warn verbosity $ "Unable to strip executable or library '" + ++ (takeBaseName path) + ++ "' (missing the 'strip' program)" + +stripExe :: Verbosity -> Platform -> ProgramConfiguration -> FilePath -> IO () +stripExe verbosity (Platform _arch os) conf path = + runStrip verbosity conf path args + where + args = case os of + OSX -> ["-x"] -- By default, stripping the ghc binary on at least + -- some OS X installations causes: + -- HSbase-3.0.o: unknown symbol `_environ'" + -- The -x flag fixes that. + _ -> [] + +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 + -- Solaris. See #1630. + return () + IOS -> return () + Solaris -> return () + Windows -> -- Stripping triggers a bug in 'strip.exe' for + -- libraries with lots identically named modules. See + -- #1784. + return() + Linux | arch == I386 -> + -- Versions of 'strip' on 32-bit Linux older than 2.18 are + -- broken. See #2339. + let okVersion = orLaterVersion (Version [2,18] []) + in case programVersion =<< lookupProgram stripProgram conf of + Just v | withinRange v okVersion -> + runStrip verbosity conf path args + _ -> warn verbosity $ "Unable to strip library '" + ++ (takeBaseName path) + ++ "' (version of 'strip' too old; " + ++ "requires >= 2.18 on 32-bit Linux)" + _ -> runStrip verbosity conf path args + where + args = ["--strip-unneeded"] diff --git a/Distribution/Simple/Program/Types.hs b/Distribution/Simple/Program/Types.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/Types.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Types +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides an abstraction which deals with configuring and running +-- programs. A 'Program' is a static notion of a known program. A +-- 'ConfiguredProgram' is a 'Program' that has been found on the current +-- machine and is ready to be run (possibly with some user-supplied default +-- args). Configuring a program involves finding its location and if necessary +-- finding its version. There's reasonable default behavior for trying to find +-- \"foo\" in PATH, being able to override its location, etc. +-- +module Distribution.Simple.Program.Types ( + -- * Program and functions for constructing them + Program(..), + ProgramSearchPath, + ProgramSearchPathEntry(..), + simpleProgram, + + -- * Configured program and related functions + ConfiguredProgram(..), + programPath, + suppressOverrideArgs, + ProgArg, + ProgramLocation(..), + simpleConfiguredProgram, + ) where + +import Distribution.Simple.Program.Find + ( ProgramSearchPath, ProgramSearchPathEntry(..) + , findProgramOnSearchPath ) +import Distribution.Version + ( Version ) +import Distribution.Verbosity + ( Verbosity ) + +import Distribution.Compat.Binary (Binary) +import qualified Data.Map as Map +import GHC.Generics (Generic) + +-- | Represents a program which can be configured. +-- +-- Note: rather than constructing this directly, start with 'simpleProgram' and +-- override any extra fields. +-- +data Program = Program { + -- | The simple name of the program, eg. ghc + programName :: String, + + -- | A function to search for the program if its location was not + -- specified by the user. Usually this will just be a call to + -- 'findProgramOnSearchPath'. + -- + -- It is supplied with the prevailing search path which will typically + -- just be used as-is, but can be extended or ignored as needed. + programFindLocation :: Verbosity -> ProgramSearchPath + -> IO (Maybe FilePath), + + -- | Try to find the version of the program. For many programs this is + -- not possible or is not necessary so it's OK to return Nothing. + programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version), + + -- | A function to do any additional configuration after we have + -- located the program (and perhaps identified its version). For example + -- it could add args, or environment vars. + programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + } + +type ProgArg = String + +-- | Represents a program which has been configured and is thus ready to be run. +-- +-- These are usually made by configuring a 'Program', but if you have to +-- construct one directly then start with 'simpleConfiguredProgram' and +-- override any extra fields. +-- +data ConfiguredProgram = ConfiguredProgram { + -- | Just the name again + programId :: String, + + -- | The version of this program, if it is known. + programVersion :: Maybe Version, + + -- | Default command-line args for this program. + -- These flags will appear first on the command line, so they can be + -- overridden by subsequent flags. + programDefaultArgs :: [String], + + -- | Override command-line args for this program. + -- These flags will appear last on the command line, so they override + -- all earlier flags. + programOverrideArgs :: [String], + + -- | Override environment variables for this program. + -- These env vars will extend\/override the prevailing environment of + -- the current to form the environment for the new process. + programOverrideEnv :: [(String, Maybe String)], + + -- | A key-value map listing various properties of the program, useful + -- for feature detection. Populated during the configuration step, key + -- names depend on the specific program. + programProperties :: Map.Map String String, + + -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ + programLocation :: ProgramLocation + } deriving (Eq, Generic, Read, Show) + +instance Binary ConfiguredProgram + +-- | Where a program was found. Also tells us whether it's specified by user or +-- not. This includes not just the path, but the program as well. +data ProgramLocation + = UserSpecified { locationPath :: FilePath } + -- ^The user gave the path to this program, + -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 + | FoundOnSystem { locationPath :: FilePath } + -- ^The program was found automatically. + deriving (Eq, Generic, Read, Show) + +instance Binary ProgramLocation + +-- | The full path of a configured program. +programPath :: ConfiguredProgram -> FilePath +programPath = locationPath . programLocation + +-- | Suppress any extra arguments added by the user. +suppressOverrideArgs :: ConfiguredProgram -> ConfiguredProgram +suppressOverrideArgs prog = prog { programOverrideArgs = [] } + +-- | Make a simple named program. +-- +-- By default we'll just search for it in the path and not try to find the +-- version name. You can override these behaviours if necessary, eg: +-- +-- > simpleProgram "foo" { programFindLocation = ... , programFindVersion ... } +-- +simpleProgram :: String -> Program +simpleProgram name = Program { + programName = name, + programFindLocation = \v p -> findProgramOnSearchPath v p name, + programFindVersion = \_ _ -> return Nothing, + programPostConf = \_ p -> return p + } + +-- | Make a simple 'ConfiguredProgram'. +-- +-- > simpleConfiguredProgram "foo" (FoundOnSystem path) +-- +simpleConfiguredProgram :: String -> ProgramLocation -> ConfiguredProgram +simpleConfiguredProgram name loc = ConfiguredProgram { + programId = name, + programVersion = Nothing, + programDefaultArgs = [], + programOverrideArgs = [], + programOverrideEnv = [], + programProperties = Map.empty, + programLocation = loc + } diff --git a/Distribution/Simple/Register.hs b/Distribution/Simple/Register.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Register.hs @@ -0,0 +1,464 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Register +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module deals with registering and unregistering packages. There are a +-- couple ways it can do this, one is to do it directly. Another is to generate +-- a script that can be run later to do it. The idea here being that the user +-- is shielded from the details of what command to use for package registration +-- for a particular compiler. In practice this aspect was not especially +-- popular so we also provide a way to simply generate the package registration +-- file which then must be manually passed to @ghc-pkg@. It is possible to +-- generate registration information for where the package is to be installed, +-- or alternatively to register the package in place in the build tree. The +-- latter is occasionally handy, and will become more important when we try to +-- build multi-package systems. +-- +-- This module does not delegate anything to the per-compiler modules but just +-- mixes it all in in this module, which is rather unsatisfactory. The script +-- generation and the unregister feature are not well used or tested. + +module Distribution.Simple.Register ( + register, + unregister, + + initPackageDB, + invokeHcPkg, + registerPackage, + generateRegistrationInfo, + inplaceInstalledPackageInfo, + absoluteInstalledPackageInfo, + generalInstalledPackageInfo, + ) where + +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) + , ComponentName(..), getComponentLocalBuildInfo + , LibraryName(..) + , InstallDirs(..), absoluteInstallDirs ) +import Distribution.Simple.BuildPaths (haddockName) + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS +import qualified Distribution.Simple.LHC as LHC +import qualified Distribution.Simple.UHC as UHC +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.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 ) + +import Control.Monad (when) +import Data.Maybe + ( isJust, fromMaybe, maybeToList ) +import Data.List + ( partition, nub ) +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 + +-- ----------------------------------------------------------------------------- +-- Registration + +register :: PackageDescription -> LocalBuildInfo + -> RegisterFlags -- ^Install in the user's database?; verbose + -> IO () +register pkg@PackageDescription { library = Just lib } lbi regFlags + = do + let clbi = getComponentLocalBuildInfo lbi CLibName + + absPackageDBs <- absolutePackageDBPaths packageDbs + installedPkgInfo <- generateRegistrationInfo + verbosity pkg lib lbi clbi inplace reloc distPref + (registrationPackageDB absPackageDBs) + + when (fromFlag (regPrintId regFlags)) $ do + putStrLn (display (IPI.installedPackageId installedPkgInfo)) + + -- Three different modes: + case () of + _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo + | modeGenerateRegScript -> writeRegisterScript installedPkgInfo + | otherwise -> registerPackage verbosity + installedPkgInfo pkg lbi inplace packageDbs + + where + modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) + regFile = fromMaybe (display (packageId pkg) <.> "conf") + (fromFlag (regGenPkgConf regFlags)) + + modeGenerateRegScript = fromFlag (regGenScript regFlags) + + inplace = fromFlag (regInPlace regFlags) + reloc = relocatable lbi + -- FIXME: there's really no guarantee this will work. + -- registering into a totally different db stack can + -- fail if dependencies cannot be satisfied. + packageDbs = nub $ withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + distPref = fromFlag (regDistPref regFlags) + verbosity = fromFlag (regVerbosity regFlags) + + writeRegistrationFile installedPkgInfo = do + notice verbosity ("Creating package registration file: " ++ regFile) + writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo) + + writeRegisterScript installedPkgInfo = + case compilerFlavor (compiler lbi) of + JHC -> notice verbosity "Registration scripts not needed for jhc" + UHC -> notice verbosity "Registration scripts not needed for uhc" + _ -> withHcPkg + "Registration scripts are not implemented for this compiler" + (compiler lbi) (withPrograms lbi) + (writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs) + +register _ _ regFlags = notice verbosity "No package to register" + where + verbosity = fromFlag (regVerbosity regFlags) + + +generateRegistrationInfo :: Verbosity + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Bool + -> Bool + -> FilePath + -> PackageDB + -> IO InstalledPackageInfo +generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packageDb = do + --TODO: eliminate pwd! + pwd <- getCurrentDirectory + + --TODO: the method of setting the InstalledPackageId is compiler specific + -- this aspect should be delegated to a per-compiler helper. + let comp = compiler lbi + ipid <- + case compilerFlavor comp of + GHC | compilerVersion comp >= Version [6,11] [] -> do + s <- GHC.libAbiHash verbosity pkg lbi lib clbi + return (InstalledPackageId (display (packageId pkg) ++ '-':s)) + GHCJS -> do + s <- GHCJS.libAbiHash verbosity pkg lbi lib clbi + return (InstalledPackageId (display (packageId pkg) ++ '-':s)) + _other -> do + return (InstalledPackageId (display (packageId pkg))) + + installedPkgInfo <- + if inplace + then return (inplaceInstalledPackageInfo pwd distPref + pkg ipid lib lbi clbi) + else if reloc + then relocRegistrationInfo verbosity + pkg lib lbi clbi ipid packageDb + else return (absoluteInstalledPackageInfo + pkg ipid lib lbi clbi) + + + return installedPkgInfo{ IPI.installedPackageId = ipid } + +relocRegistrationInfo :: Verbosity + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageId + -> PackageDB + -> IO InstalledPackageInfo +relocRegistrationInfo verbosity pkg lib lbi clbi ipid packageDb = + case (compilerFlavor (compiler lbi)) of + GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb + return (relocatableInstalledPackageInfo + pkg ipid lib lbi clbi fs) + _ -> die "Distribution.Simple.Register.relocRegistrationInfo: \ + \not implemented for this compiler" + +-- | 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) + +-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the +-- provided command-line arguments to it. +invokeHcPkg :: Verbosity -> Compiler -> ProgramConfiguration -> PackageDBStack + -> [String] -> IO () +invokeHcPkg verbosity comp conf dbStack extraArgs = + withHcPkg "invokeHcPkg" comp conf + (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs) + +withHcPkg :: String -> Compiler -> ProgramConfiguration + -> (HcPkgInfo -> IO a) -> IO a +withHcPkg name comp conf f = + case compilerFlavor comp of + GHC -> f (GHC.hcPkgInfo conf) + GHCJS -> f (GHCJS.hcPkgInfo conf) + LHC -> f (LHC.hcPkgInfo conf) + _ -> die ("Distribution.Simple.Register." ++ name ++ ":\ + \not implemented for this compiler") + +registerPackage :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do + let msg = if inplace + then "In-place registering" + else "Registering" + setupMessage verbosity msg (packageId pkg) + case compilerFlavor (compiler lbi) of + GHC -> GHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + 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 + JHC -> notice verbosity "Registering for jhc (nothing to do)" + HaskellSuite {} -> + HaskellSuite.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + _ -> die "Registering is not implemented for this compiler" + +writeHcPkgRegisterScript :: Verbosity + -> InstalledPackageInfo + -> PackageDBStack + -> HcPkgInfo + -> IO () +writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs hpi = do + let invocation = HcPkg.reregisterInvocation hpi Verbosity.normal + packageDbs (Right installedPkgInfo) + regScript = invocationAsSystemScript buildOS invocation + + notice verbosity ("Creating package registration script: " ++ regScriptFileName) + writeUTF8File regScriptFileName regScript + setFileExecutable regScriptFileName + +regScriptFileName :: FilePath +regScriptFileName = case buildOS of + Windows -> "register.bat" + _ -> "register.sh" + + +-- ----------------------------------------------------------------------------- +-- Making the InstalledPackageInfo + +-- | Construct 'InstalledPackageInfo' for a library in a package, given a set +-- of installation directories. +-- +generalInstalledPackageInfo + :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to + -- absolute paths. + -> PackageDescription + -> InstalledPackageId + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstallDirs FilePath + -> InstalledPackageInfo +generalInstalledPackageInfo adjustRelIncDirs pkg ipid lib lbi clbi installDirs = + InstalledPackageInfo { + IPI.installedPackageId = ipid, + IPI.sourcePackageId = packageId pkg, + IPI.packageKey = pkgKey lbi, + IPI.license = license pkg, + IPI.copyright = copyright pkg, + IPI.maintainer = maintainer pkg, + IPI.author = author pkg, + IPI.stability = stability pkg, + IPI.homepage = homepage pkg, + IPI.pkgUrl = pkgUrl pkg, + IPI.synopsis = synopsis pkg, + IPI.description = description pkg, + IPI.category = category pkg, + IPI.exposed = libExposed lib, + IPI.exposedModules = map fixupSelf (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 + -- into libdir and datadir. + IPI.libraryDirs = if hasLibrary + then libdir installDirs : extraLibDirs bi + else extraLibDirs bi, + IPI.dataDir = datadir installDirs, + IPI.hsLibraries = [ libname + | LibraryName libname <- componentLibraries clbi + , hasLibrary ], + IPI.extraLibraries = extraLibs bi, + IPI.extraGHCiLibraries = extraGHCiLibs bi, + IPI.includeDirs = absinc ++ adjustRelIncDirs relinc, + IPI.includes = includes bi, + IPI.depends = map fst (componentPackageDeps clbi), + IPI.ccOptions = [], -- Note. NOT ccOptions bi! + -- We don't want cc-options to be propagated + -- to C compilations in other packages. + IPI.ldOptions = ldOptions bi, + IPI.frameworkDirs = [], + IPI.frameworks = frameworks bi, + IPI.haddockInterfaces = [haddockdir installDirs haddockName pkg], + IPI.haddockHTMLs = [htmldir installDirs], + IPI.pkgRoot = Nothing + } + where + bi = libBuildInfo lib + (absinc, relinc) = partition isAbsolute (includeDirs bi) + hasModules = not $ null (libModules lib) + hasLibrary = hasModules || not (null (cSources bi)) + || (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. +-- +-- This function knows about the layout of in place packages. +-- +inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree + -> FilePath -- ^ location of the dist tree + -> PackageDescription + -> InstalledPackageId + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo +inplaceInstalledPackageInfo inplaceDir distPref pkg ipid lib lbi clbi = + generalInstalledPackageInfo adjustRelativeIncludeDirs + pkg ipid lib lbi clbi installDirs + where + adjustRelativeIncludeDirs = map (inplaceDir ) + installDirs = + (absoluteInstallDirs pkg lbi NoCopyDest) { + libdir = inplaceDir buildDir lbi, + datadir = inplaceDir dataDir pkg, + docdir = inplaceDocdir, + htmldir = inplaceHtmldir, + haddockdir = inplaceHtmldir + } + inplaceDocdir = inplaceDir distPref "doc" + inplaceHtmldir = inplaceDocdir "html" display (packageName pkg) + + +-- | Construct 'InstalledPackageInfo' for the final install location of a +-- library package. +-- +-- This function knows about the layout of installed packages. +-- +absoluteInstalledPackageInfo :: PackageDescription + -> InstalledPackageId + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo +absoluteInstalledPackageInfo pkg ipid lib lbi clbi = + generalInstalledPackageInfo adjustReativeIncludeDirs + pkg ipid 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. + adjustReativeIncludeDirs _ + | null (installIncludes bi) = [] + | otherwise = [includedir installDirs] + bi = libBuildInfo lib + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + + +relocatableInstalledPackageInfo :: PackageDescription + -> InstalledPackageId + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> InstalledPackageInfo +relocatableInstalledPackageInfo pkg ipid lib lbi clbi pkgroot = + generalInstalledPackageInfo adjustReativeIncludeDirs + pkg ipid 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. + adjustReativeIncludeDirs _ + | null (installIncludes bi) = [] + | otherwise = [includedir installDirs] + bi = libBuildInfo lib + + installDirs = fmap (("${pkgroot}" ) . shortRelativePath pkgroot) + $ absoluteInstallDirs pkg lbi NoCopyDest + +-- ----------------------------------------------------------------------------- +-- Unregistration + +unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () +unregister pkg lbi regFlags = do + let pkgid = packageId pkg + genScript = fromFlag (regGenScript regFlags) + verbosity = fromFlag (regVerbosity regFlags) + packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) + (regPackageDB regFlags) + unreg hpi = + let invocation = HcPkg.unregisterInvocation + hpi Verbosity.normal packageDb pkgid + in if genScript + then writeFileAtomic unregScriptFileName + (BS.Char8.pack $ invocationAsSystemScript buildOS invocation) + else runProgramInvocation verbosity invocation + setupMessage verbosity "Unregistering" pkgid + withHcPkg "unregistering is only implemented for GHC and GHCJS" + (compiler lbi) (withPrograms lbi) unreg + +unregScriptFileName :: FilePath +unregScriptFileName = case buildOS of + Windows -> "unregister.bat" + _ -> "unregister.sh" diff --git a/Distribution/Simple/Setup.hs b/Distribution/Simple/Setup.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Setup.hs @@ -0,0 +1,2215 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Setup +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is a big module, but not very complicated. The code is very regular +-- and repetitive. It defines the command line interface for all the Cabal +-- commands. For each command (like @configure@, @build@ etc) it defines a type +-- that holds all the flags, the default set of flags and a 'CommandUI' that +-- maps command line flags to and from the corresponding flags type. +-- +-- All the flags types are instances of 'Monoid', see +-- +-- for an explanation. +-- +-- The types defined here get used in the front end and especially in +-- @cabal-install@ which has to do quite a bit of manipulating sets of command +-- line flags. +-- +-- This is actually relatively nice, it works quite well. The main change it +-- needs is to unify it with the code for managing sets of fields that can be +-- read and written from files. This would allow us to save configure flags in +-- config files. + +{-# LANGUAGE CPP #-} + +module Distribution.Simple.Setup ( + + GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, + ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, + configAbsolutePaths, readPackageDbList, showPackageDbList, + CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, + InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, + HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, + HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, + BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, + buildVerbose, + ReplFlags(..), defaultReplFlags, replCommand, + CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, + RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, + unregisterCommand, + SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, + TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, + TestShowDetails(..), + BenchmarkFlags(..), emptyBenchmarkFlags, + defaultBenchmarkFlags, benchmarkCommand, + CopyDest(..), + configureArgs, configureOptions, configureCCompiler, configureLinker, + buildOptions, haddockOptions, installDirsOptions, + programConfigurationOptions, programConfigurationPaths', + + defaultDistPref, + + Flag(..), + toFlag, + fromFlag, + fromFlagOrDefault, + flagToMaybe, + flagToList, + boolOpt, boolOpt', trueArg, falseArg, optionVerbosity, optionNumJobs ) where + +import Distribution.Compiler () +import Distribution.ReadE +import Distribution.Text + ( Text(..), display ) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Distribution.ModuleName +import Distribution.Package ( Dependency(..) + , PackageName + , InstalledPackageId ) +import Distribution.PackageDescription + ( FlagName(..), FlagAssignment ) +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import qualified Distribution.Simple.Command as Command +import Distribution.Simple.Compiler + ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..) + , DebugInfoLevel(..), flagToDebugInfoLevel + , OptimisationLevel(..), flagToOptimisationLevel + , absolutePackageDBPath ) +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.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) + +-- FIXME Not sure where this should live +defaultDistPref :: FilePath +defaultDistPref = "dist" + +-- ------------------------------------------------------------ +-- * Flag type +-- ------------------------------------------------------------ + +-- | All flags are monoids, they come in two flavours: +-- +-- 1. list flags eg +-- +-- > --ghc-option=foo --ghc-option=bar +-- +-- gives us all the values ["foo", "bar"] +-- +-- 2. singular value flags, eg: +-- +-- > --enable-foo --disable-foo +-- +-- gives us Just False +-- So this Flag type is for the latter singular kind of flag. +-- Its monoid instance gives us the behaviour where it starts out as +-- 'NoFlag' and later flags override earlier ones. +-- +data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read) + +instance Binary a => Binary (Flag a) + +instance Functor Flag where + fmap f (Flag x) = Flag (f x) + fmap _ NoFlag = NoFlag + +instance Monoid (Flag a) where + mempty = NoFlag + _ `mappend` f@(Flag _) = f + f `mappend` NoFlag = f + +instance Bounded a => Bounded (Flag a) where + minBound = toFlag minBound + maxBound = toFlag maxBound + +instance Enum a => Enum (Flag a) where + fromEnum = fromEnum . fromFlag + toEnum = toFlag . toEnum + enumFrom (Flag a) = map toFlag . enumFrom $ a + enumFrom _ = [] + enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b + enumFromThen _ _ = [] + enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b + enumFromTo _ _ = [] + enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c + enumFromThenTo _ _ _ = [] + +toFlag :: a -> Flag a +toFlag = Flag + +fromFlag :: Flag a -> a +fromFlag (Flag x) = x +fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" + +fromFlagOrDefault :: a -> Flag a -> a +fromFlagOrDefault _ (Flag x) = x +fromFlagOrDefault def NoFlag = def + +flagToMaybe :: Flag a -> Maybe a +flagToMaybe (Flag x) = Just x +flagToMaybe NoFlag = Nothing + +flagToList :: Flag a -> [a] +flagToList (Flag x) = [x] +flagToList NoFlag = [] + +allFlags :: [Flag Bool] -> Flag Bool +allFlags flags = if all (\f -> fromFlagOrDefault False f) flags + then Flag True + else NoFlag + +-- ------------------------------------------------------------ +-- * Global flags +-- ------------------------------------------------------------ + +-- In fact since individual flags types are monoids and these are just sets of +-- flags then they are also monoids pointwise. This turns out to be really +-- useful. The mempty is the set of empty flags and mappend allows us to +-- override specific flags. For example we can start with default flags and +-- override with the ones we get from a file or the command line, or both. + +-- | Flags that apply at the top level, not to any sub-command. +data GlobalFlags = GlobalFlags { + globalVersion :: Flag Bool, + globalNumericVersion :: Flag Bool + } + +defaultGlobalFlags :: GlobalFlags +defaultGlobalFlags = GlobalFlags { + globalVersion = Flag False, + globalNumericVersion = Flag False + } + +globalCommand :: [Command action] -> CommandUI GlobalFlags +globalCommand commands = CommandUI + { commandName = "" + , commandSynopsis = "" + , commandUsage = \pname -> + "This Setup program uses the Haskell Cabal Infrastructure.\n" + ++ "See http://www.haskell.org/cabal/ for more information.\n" + ++ "\n" + ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n" + , commandDescription = Just $ \pname -> + let + commands' = commands ++ [commandAddAction helpCommandUI undefined] + cmdDescs = getNormalCommandDescriptions commands' + maxlen = maximum $ [length name | (name, _) <- cmdDescs] + align str = str ++ replicate (maxlen - length str) ' ' + in + "Commands:\n" + ++ unlines [ " " ++ align name ++ " " ++ description + | (name, description) <- cmdDescs ] + ++ "\n" + ++ "For more information about a command use\n" + ++ " " ++ pname ++ " COMMAND --help\n\n" + ++ "Typical steps for installing Cabal packages:\n" + ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" + | x <- ["configure", "build", "install"]] + , commandNotes = Nothing + , commandDefaultFlags = defaultGlobalFlags + , commandOptions = \_ -> + [option ['V'] ["version"] + "Print version information" + globalVersion (\v flags -> flags { globalVersion = v }) + trueArg + ,option [] ["numeric-version"] + "Print just the version number" + globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) + trueArg + ] + } + +emptyGlobalFlags :: GlobalFlags +emptyGlobalFlags = mempty + +instance Monoid GlobalFlags where + mempty = GlobalFlags { + globalVersion = mempty, + globalNumericVersion = mempty + } + mappend a b = GlobalFlags { + globalVersion = combine globalVersion, + globalNumericVersion = combine globalNumericVersion + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Config flags +-- ------------------------------------------------------------ + +-- | Flags to @configure@ command +data ConfigFlags = ConfigFlags { + --FIXME: the configPrograms is only here to pass info through to configure + -- because the type of configure is constrained by the UserHooks. + -- when we change UserHooks next we should pass the initial + -- ProgramConfiguration directly and not via ConfigFlags + configPrograms :: ProgramConfiguration, -- ^All programs that cabal may + -- run + + configProgramPaths :: [(String, FilePath)], -- ^user specified programs paths + configProgramArgs :: [(String, [String])], -- ^user specified programs args + configProgramPathExtra :: NubList FilePath, -- ^Extend the $PATH + configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the + -- compiler, such as GHC or + -- JHC. + configHcPath :: Flag FilePath, -- ^given compiler location + configHcPkg :: Flag FilePath, -- ^given hc-pkg location + configVanillaLib :: Flag Bool, -- ^Enable vanilla library + configProfLib :: Flag Bool, -- ^Enable profiling in the library + configSharedLib :: Flag Bool, -- ^Build shared library + configDynExe :: Flag Bool, -- ^Enable dynamic linking of the + -- executables. + configProfExe :: Flag Bool, -- ^Enable profiling in the + -- executables. + configProf :: Flag Bool, -- ^Enable profiling in the library + -- and executables. + configConfigureArgs :: [String], -- ^Extra arguments to @configure@ + configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. + configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix. + configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix. + configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation + -- paths + configScratchDir :: Flag FilePath, + configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries + configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files + + configDistPref :: Flag FilePath, -- ^"dist" prefix + configVerbosity :: Flag Verbosity, -- ^verbosity level + configUserInstall :: Flag Bool, -- ^The --user\/--global flag + configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use + configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi + configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC + configStripExes :: Flag Bool, -- ^Enable executable stripping + configStripLibs :: Flag Bool, -- ^Enable library stripping + configConstraints :: [Dependency], -- ^Additional constraints for + -- dependencies. + configDependencies :: [(PackageName, InstalledPackageId)], + configInstantiateWith :: [(ModuleName, (InstalledPackageId, ModuleName))], + -- ^The packages depended on. + configConfigurationsFlags :: FlagAssignment, + configTests :: Flag Bool, -- ^Enable test suite compilation + configBenchmarks :: Flag Bool, -- ^Enable benchmark compilation + configCoverage :: Flag Bool, -- ^Enable program coverage + configLibCoverage :: Flag Bool, -- ^Enable program coverage (deprecated) + configExactConfiguration :: Flag Bool, + -- ^All direct dependencies and flags are provided on the command line by + -- the user via the '--dependency' and '--flags' options. + 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. + } + deriving (Generic, Read, Show) + +instance Binary ConfigFlags + +configAbsolutePaths :: ConfigFlags -> IO ConfigFlags +configAbsolutePaths f = + (\v -> f { configPackageDBs = v }) + `liftM` mapM (maybe (return Nothing) (liftM Just . absolutePackageDBPath)) + (configPackageDBs f) + +defaultConfigFlags :: ProgramConfiguration -> ConfigFlags +defaultConfigFlags progConf = emptyConfigFlags { + configPrograms = progConf, + configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, + configVanillaLib = Flag True, + configProfLib = NoFlag, + configSharedLib = NoFlag, + configDynExe = Flag False, + configProfExe = NoFlag, + configProf = NoFlag, + configOptimization = Flag NormalOptimisation, + configProgPrefix = Flag (toPathTemplate ""), + configProgSuffix = Flag (toPathTemplate ""), + configDistPref = Flag defaultDistPref, + configVerbosity = Flag normal, + configUserInstall = Flag False, --TODO: reverse this +#if defined(mingw32_HOST_OS) + -- See #1589. + configGHCiLib = Flag True, +#else + configGHCiLib = NoFlag, +#endif + configSplitObjs = Flag False, -- takes longer, so turn off by default + configStripExes = Flag True, + configStripLibs = Flag True, + configTests = Flag False, + configBenchmarks = Flag False, + configCoverage = Flag False, + configLibCoverage = NoFlag, + configExactConfiguration = Flag False, + configFlagError = NoFlag, + configRelocatable = Flag False, + configDebugInfo = Flag NoDebugInfo + } + +configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags +configureCommand progConf = CommandUI + { commandName = "configure" + , commandSynopsis = "Prepare to build the package." + , commandDescription = Just $ \_ -> wrapText $ + "Configure how the package is built by setting " + ++ "package (and other) flags.\n" + ++ "\n" + ++ "The configuration affects several other commands, " + ++ "including build, test, bench, run, repl.\n" + , commandNotes = Just (\_ -> programFlagsDescription progConf) + , commandUsage = \pname -> + "Usage: " ++ pname ++ " configure [FLAGS]\n" + , commandDefaultFlags = defaultConfigFlags progConf + , commandOptions = \showOrParseArgs -> + configureOptions showOrParseArgs + ++ programConfigurationPaths progConf showOrParseArgs + configProgramPaths (\v fs -> fs { configProgramPaths = v }) + ++ programConfigurationOption progConf showOrParseArgs + configProgramArgs (\v fs -> fs { configProgramArgs = v }) + ++ programConfigurationOptions progConf showOrParseArgs + configProgramArgs (\v fs -> fs { configProgramArgs = v }) + } + +configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] +configureOptions showOrParseArgs = + [optionVerbosity configVerbosity + (\v flags -> flags { configVerbosity = v }) + ,optionDistPref + configDistPref (\d flags -> flags { configDistPref = d }) + showOrParseArgs + + ,option [] ["compiler"] "compiler" + configHcFlavor (\v flags -> flags { configHcFlavor = v }) + (choiceOpt [ (Flag GHC, ("g", ["ghc"]), "compile with GHC") + , (Flag GHCJS, ([] , ["ghcjs"]), "compile with GHCJS") + , (Flag JHC, ([] , ["jhc"]), "compile with JHC") + , (Flag LHC, ([] , ["lhc"]), "compile with LHC") + , (Flag UHC, ([] , ["uhc"]), "compile with UHC") + -- "haskell-suite" compiler id string will be replaced + -- by a more specific one during the configure stage + , (Flag (HaskellSuite "haskell-suite"), ([] , ["haskell-suite"]), + "compile with a haskell-suite compiler")]) + + ,option "w" ["with-compiler"] + "give the path to a particular compiler" + configHcPath (\v flags -> flags { configHcPath = v }) + (reqArgFlag "PATH") + + ,option "" ["with-hc-pkg"] + "give the path to the package tool" + configHcPkg (\v flags -> flags { configHcPkg = v }) + (reqArgFlag "PATH") + ] + ++ map liftInstallDirs installDirsOptions + ++ [option "" ["program-prefix"] + "prefix to be applied to installed executables" + configProgPrefix + (\v flags -> flags { configProgPrefix = v }) + (reqPathTemplateArgFlag "PREFIX") + + ,option "" ["program-suffix"] + "suffix to be applied to installed executables" + configProgSuffix (\v flags -> flags { configProgSuffix = v } ) + (reqPathTemplateArgFlag "SUFFIX") + + ,option "" ["library-vanilla"] + "Vanilla libraries" + configVanillaLib (\v flags -> flags { configVanillaLib = v }) + (boolOpt [] []) + + ,option "p" ["library-profiling"] + "Library profiling" + configProfLib (\v flags -> flags { configProfLib = v }) + (boolOpt "p" []) + + ,option "" ["shared"] + "Shared library" + configSharedLib (\v flags -> flags { configSharedLib = v }) + (boolOpt [] []) + + ,option "" ["executable-dynamic"] + "Executable dynamic linking" + configDynExe (\v flags -> flags { configDynExe = v }) + (boolOpt [] []) + + ,option "" ["profiling"] + "Executable profiling (requires library profiling)" + configProf (\v flags -> flags { configProf = v }) + (boolOpt [] []) + + ,option "" ["executable-profiling"] + "Executable profiling (DEPRECATED)" + configProfExe (\v flags -> flags { configProfExe = v }) + (boolOpt [] []) + + ,multiOption "optimization" + configOptimization (\v flags -> flags { configOptimization = v }) + [optArg' "n" (Flag . flagToOptimisationLevel) + (\f -> case f of + Flag NoOptimisation -> [] + Flag NormalOptimisation -> [Nothing] + Flag MaximumOptimisation -> [Just "2"] + _ -> []) + "O" ["enable-optimization","enable-optimisation"] + "Build with optimization (n is 0--2, default is 1)", + noArg (Flag NoOptimisation) [] + ["disable-optimization","disable-optimisation"] + "Build without optimization" + ] + + ,multiOption "debug-info" + configDebugInfo (\v flags -> flags { configDebugInfo = v }) + [optArg' "n" (Flag . flagToDebugInfoLevel) + (\f -> case f of + Flag NoDebugInfo -> [] + Flag MinimalDebugInfo -> [Just "1"] + Flag NormalDebugInfo -> [Nothing] + Flag MaximalDebugInfo -> [Just "3"] + _ -> []) + "" ["enable-debug-info"] + "Emit debug info (n is 0--3, default is 0)", + noArg (Flag NoDebugInfo) [] + ["disable-debug-info"] + "Don't emit debug info" + ] + + ,option "" ["library-for-ghci"] + "compile library for use with GHCi" + configGHCiLib (\v flags -> flags { configGHCiLib = v }) + (boolOpt [] []) + + ,option "" ["split-objs"] + "split library into smaller objects to reduce binary sizes (GHC 6.6+)" + configSplitObjs (\v flags -> flags { configSplitObjs = v }) + (boolOpt [] []) + + ,option "" ["executable-stripping"] + "strip executables upon installation to reduce binary sizes" + configStripExes (\v flags -> flags { configStripExes = v }) + (boolOpt [] []) + + ,option "" ["library-stripping"] + "strip libraries upon installation to reduce binary sizes" + configStripLibs (\v flags -> flags { configStripLibs = v }) + (boolOpt [] []) + + ,option "" ["configure-option"] + "Extra option for configure" + configConfigureArgs (\v flags -> flags { configConfigureArgs = v }) + (reqArg' "OPT" (\x -> [x]) id) + + ,option "" ["user-install"] + "doing a per-user installation" + configUserInstall (\v flags -> flags { configUserInstall = v }) + (boolOpt' ([],["user"]) ([], ["global"])) + + ,option "" ["package-db"] + "Use a given package database (to satisfy dependencies and register in). May be a specific file, 'global', 'user' or 'clear'." + configPackageDBs (\v flags -> flags { configPackageDBs = v }) + (reqArg' "DB" readPackageDbList showPackageDbList) + + ,option "f" ["flags"] + "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." + configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v }) + (reqArg' "FLAGS" readFlagList showFlagList) + + ,option "" ["extra-include-dirs"] + "A list of directories to search for header files" + configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + + ,option "" ["extra-lib-dirs"] + "A list of directories to search for external libraries" + configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + + ,option "" ["extra-prog-path"] + "A list of directories to search for required programs (in addition to the normal search locations)" + configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v}) + (reqArg' "PATH" (\x -> toNubList [x]) fromNubList) + + ,option "" ["constraint"] + "A list of additional constraints on the dependencies." + configConstraints (\v flags -> flags { configConstraints = v}) + (reqArg "DEPENDENCY" + (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) + (map (\x -> display x))) + + ,option "" ["dependency"] + "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" + configDependencies (\v flags -> flags { configDependencies = v}) + (reqArg "NAME=ID" + (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 }) + (boolOpt [] []) + + ,option "" ["coverage"] + "build package with Haskell Program Coverage. (GHC only)" + configCoverage (\v flags -> flags { configCoverage = v }) + (boolOpt [] []) + + ,option "" ["library-coverage"] + "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)" + configLibCoverage (\v flags -> flags { configLibCoverage = v }) + (boolOpt [] []) + + ,option "" ["exact-configuration"] + "All direct dependencies and flags are provided on the command line." + configExactConfiguration + (\v flags -> flags { configExactConfiguration = v }) + trueArg + + ,option "" ["benchmarks"] + "dependency checking and compilation for benchmarks listed in the package description file." + configBenchmarks (\v flags -> flags { configBenchmarks = v }) + (boolOpt [] []) + + ,option "" ["relocatable"] + "building a package that is relocatable. (GHC only)" + configRelocatable (\v flags -> flags { configRelocatable = v}) + (boolOpt [] []) + ] + where + readFlagList :: String -> FlagAssignment + readFlagList = map tagWithValue . words + where tagWithValue ('-':fname) = (FlagName (lowercase fname), False) + tagWithValue fname = (FlagName (lowercase fname), True) + + showFlagList :: FlagAssignment -> [String] + showFlagList fs = [ if not set then '-':fname else fname + | (FlagName fname, set) <- fs] + + liftInstallDirs = + liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v }) + + reqPathTemplateArgFlag title _sf _lf d get set = + reqArgFlag title _sf _lf d + (fmap fromPathTemplate . get) (set . fmap toPathTemplate) + +readPackageDbList :: String -> [Maybe PackageDB] +readPackageDbList "clear" = [Nothing] +readPackageDbList "global" = [Just GlobalPackageDB] +readPackageDbList "user" = [Just UserPackageDB] +readPackageDbList other = [Just (SpecificPackageDB other)] + +showPackageDbList :: [Maybe PackageDB] -> [String] +showPackageDbList = map showPackageDb + where + showPackageDb Nothing = "clear" + showPackageDb (Just GlobalPackageDB) = "global" + showPackageDb (Just UserPackageDB) = "user" + showPackageDb (Just (SpecificPackageDB db)) = db + + +parseDependency :: Parse.ReadP r (PackageName, InstalledPackageId) +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"] + "bake this prefix in preparation of installation" + prefix (\v flags -> flags { prefix = v }) + installDirArg + + , option "" ["bindir"] + "installation directory for executables" + bindir (\v flags -> flags { bindir = v }) + installDirArg + + , option "" ["libdir"] + "installation directory for libraries" + libdir (\v flags -> flags { libdir = v }) + installDirArg + + , option "" ["libsubdir"] + "subdirectory of libdir in which libs are installed" + libsubdir (\v flags -> flags { libsubdir = v }) + installDirArg + + , option "" ["libexecdir"] + "installation directory for program executables" + libexecdir (\v flags -> flags { libexecdir = v }) + installDirArg + + , option "" ["datadir"] + "installation directory for read-only data" + datadir (\v flags -> flags { datadir = v }) + installDirArg + + , option "" ["datasubdir"] + "subdirectory of datadir in which data files are installed" + datasubdir (\v flags -> flags { datasubdir = v }) + installDirArg + + , option "" ["docdir"] + "installation directory for documentation" + docdir (\v flags -> flags { docdir = v }) + installDirArg + + , option "" ["htmldir"] + "installation directory for HTML documentation" + htmldir (\v flags -> flags { htmldir = v }) + installDirArg + + , option "" ["haddockdir"] + "installation directory for haddock interfaces" + haddockdir (\v flags -> flags { haddockdir = v }) + installDirArg + + , option "" ["sysconfdir"] + "installation directory for configuration files" + sysconfdir (\v flags -> flags { sysconfdir = v }) + installDirArg + ] + where + installDirArg _sf _lf d get set = + reqArgFlag "DIR" _sf _lf d + (fmap fromPathTemplate . get) (set . fmap toPathTemplate) + +emptyConfigFlags :: ConfigFlags +emptyConfigFlags = mempty + +instance Monoid ConfigFlags where + mempty = ConfigFlags { + configPrograms = error "FIXME: remove configPrograms", + configProgramPaths = mempty, + configProgramArgs = mempty, + configProgramPathExtra = mempty, + configHcFlavor = mempty, + configHcPath = mempty, + configHcPkg = mempty, + configVanillaLib = mempty, + configProfLib = mempty, + configSharedLib = mempty, + configDynExe = mempty, + configProfExe = mempty, + configProf = 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, + configProf = combine configProf, + 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 + +-- ------------------------------------------------------------ +-- * Copy flags +-- ------------------------------------------------------------ + +-- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity) +data CopyFlags = CopyFlags { + copyDest :: Flag CopyDest, + copyDistPref :: Flag FilePath, + copyVerbosity :: Flag Verbosity + } + deriving Show + +defaultCopyFlags :: CopyFlags +defaultCopyFlags = CopyFlags { + copyDest = Flag NoCopyDest, + copyDistPref = Flag defaultDistPref, + copyVerbosity = Flag normal + } + +copyCommand :: CommandUI CopyFlags +copyCommand = CommandUI + { commandName = "copy" + , commandSynopsis = "Copy the files into the install locations." + , commandDescription = Just $ \_ -> wrapText $ + "Does not call register, and allows a prefix at install time. " + ++ "Without the --destdir flag, configure determines location.\n" + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " copy [FLAGS]\n" + , commandDefaultFlags = defaultCopyFlags + , commandOptions = \showOrParseArgs -> + [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v }) + + ,optionDistPref + copyDistPref (\d flags -> flags { copyDistPref = d }) + showOrParseArgs + + ,option "" ["destdir"] + "directory to copy files to, prepended to installation directories" + copyDest (\v flags -> flags { copyDest = v }) + (reqArg "DIR" (succeedReadE (Flag . CopyTo)) + (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) + ] + } + +emptyCopyFlags :: CopyFlags +emptyCopyFlags = mempty + +instance Monoid CopyFlags where + mempty = CopyFlags { + copyDest = mempty, + copyDistPref = mempty, + copyVerbosity = mempty + } + mappend a b = CopyFlags { + copyDest = combine copyDest, + copyDistPref = combine copyDistPref, + copyVerbosity = combine copyVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Install flags +-- ------------------------------------------------------------ + +-- | Flags to @install@: (package db, verbosity) +data InstallFlags = InstallFlags { + installPackageDB :: Flag PackageDB, + installDistPref :: Flag FilePath, + installUseWrapper :: Flag Bool, + installInPlace :: Flag Bool, + installVerbosity :: Flag Verbosity + } + deriving Show + +defaultInstallFlags :: InstallFlags +defaultInstallFlags = InstallFlags { + installPackageDB = NoFlag, + installDistPref = Flag defaultDistPref, + installUseWrapper = Flag False, + installInPlace = Flag False, + installVerbosity = Flag normal + } + +installCommand :: CommandUI InstallFlags +installCommand = CommandUI + { commandName = "install" + , commandSynopsis = + "Copy the files into the install locations. Run register." + , commandDescription = Just $ \_ -> wrapText $ + "Unlike the copy command, install calls the register command." + ++ "If you want to install into a location that is not what was" + ++ "specified in the configure step, use the copy command.\n" + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " install [FLAGS]\n" + , commandDefaultFlags = defaultInstallFlags + , commandOptions = \showOrParseArgs -> + [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v }) + ,optionDistPref + installDistPref (\d flags -> flags { installDistPref = d }) + showOrParseArgs + + ,option "" ["inplace"] + "install the package in the install subdirectory of the dist prefix, so it can be used without being installed" + installInPlace (\v flags -> flags { installInPlace = v }) + trueArg + + ,option "" ["shell-wrappers"] + "using shell script wrappers around executables" + installUseWrapper (\v flags -> flags { installUseWrapper = v }) + (boolOpt [] []) + + ,option "" ["package-db"] "" + installPackageDB (\v flags -> flags { installPackageDB = v }) + (choiceOpt [ (Flag UserPackageDB, ([],["user"]), + "upon configuration register this package in the user's local package database") + , (Flag GlobalPackageDB, ([],["global"]), + "(default) upon configuration register this package in the system-wide package database")]) + ] + } + +emptyInstallFlags :: InstallFlags +emptyInstallFlags = mempty + +instance Monoid InstallFlags where + mempty = InstallFlags{ + installPackageDB = mempty, + installDistPref = mempty, + installUseWrapper = mempty, + installInPlace = mempty, + installVerbosity = mempty + } + mappend a b = InstallFlags{ + installPackageDB = combine installPackageDB, + installDistPref = combine installDistPref, + installUseWrapper = combine installUseWrapper, + installInPlace = combine installInPlace, + installVerbosity = combine installVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * SDist flags +-- ------------------------------------------------------------ + +-- | Flags to @sdist@: (snapshot, verbosity) +data SDistFlags = SDistFlags { + sDistSnapshot :: Flag Bool, + sDistDirectory :: Flag FilePath, + sDistDistPref :: Flag FilePath, + sDistListSources :: Flag FilePath, + sDistVerbosity :: Flag Verbosity + } + deriving Show + +defaultSDistFlags :: SDistFlags +defaultSDistFlags = SDistFlags { + sDistSnapshot = Flag False, + sDistDirectory = mempty, + sDistDistPref = Flag defaultDistPref, + sDistListSources = mempty, + sDistVerbosity = Flag normal + } + +sdistCommand :: CommandUI SDistFlags +sdistCommand = CommandUI + { commandName = "sdist" + , commandSynopsis = + "Generate a source distribution file (.tar.gz)." + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " sdist [FLAGS]\n" + , commandDefaultFlags = defaultSDistFlags + , commandOptions = \showOrParseArgs -> + [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v }) + ,optionDistPref + sDistDistPref (\d flags -> flags { sDistDistPref = d }) + showOrParseArgs + + ,option "" ["list-sources"] + "Just write a list of the package's sources to a file" + sDistListSources (\v flags -> flags { sDistListSources = v }) + (reqArgFlag "FILE") + + ,option "" ["snapshot"] + "Produce a snapshot source distribution" + sDistSnapshot (\v flags -> flags { sDistSnapshot = v }) + trueArg + + ,option "" ["output-directory"] + ("Generate a source distribution in the given directory, " + ++ "without creating a tarball") + sDistDirectory (\v flags -> flags { sDistDirectory = v }) + (reqArgFlag "DIR") + ] + } + +emptySDistFlags :: SDistFlags +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 + +-- ------------------------------------------------------------ +-- * Register flags +-- ------------------------------------------------------------ + +-- | Flags to @register@ and @unregister@: (user package, gen-script, +-- in-place, verbosity) +data RegisterFlags = RegisterFlags { + regPackageDB :: Flag PackageDB, + regGenScript :: Flag Bool, + regGenPkgConf :: Flag (Maybe FilePath), + regInPlace :: Flag Bool, + regDistPref :: Flag FilePath, + regPrintId :: Flag Bool, + regVerbosity :: Flag Verbosity + } + deriving Show + +defaultRegisterFlags :: RegisterFlags +defaultRegisterFlags = RegisterFlags { + regPackageDB = NoFlag, + regGenScript = Flag False, + regGenPkgConf = NoFlag, + regInPlace = Flag False, + regDistPref = Flag defaultDistPref, + regPrintId = Flag False, + regVerbosity = Flag normal + } + +registerCommand :: CommandUI RegisterFlags +registerCommand = CommandUI + { commandName = "register" + , commandSynopsis = + "Register this package with the compiler." + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " register [FLAGS]\n" + , commandDefaultFlags = defaultRegisterFlags + , commandOptions = \showOrParseArgs -> + [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) + ,optionDistPref + regDistPref (\d flags -> flags { regDistPref = d }) + showOrParseArgs + + ,option "" ["packageDB"] "" + regPackageDB (\v flags -> flags { regPackageDB = v }) + (choiceOpt [ (Flag UserPackageDB, ([],["user"]), + "upon registration, register this package in the user's local package database") + , (Flag GlobalPackageDB, ([],["global"]), + "(default)upon registration, register this package in the system-wide package database")]) + + ,option "" ["inplace"] + "register the package in the build location, so it can be used without being installed" + regInPlace (\v flags -> flags { regInPlace = v }) + trueArg + + ,option "" ["gen-script"] + "instead of registering, generate a script to register later" + regGenScript (\v flags -> flags { regGenScript = v }) + trueArg + + ,option "" ["gen-pkg-config"] + "instead of registering, generate a package registration file" + regGenPkgConf (\v flags -> flags { regGenPkgConf = v }) + (optArg' "PKG" Flag flagToList) + + ,option "" ["print-ipid"] + "print the installed package ID calculated for this package" + regPrintId (\v flags -> flags { regPrintId = v }) + trueArg + ] + } + +unregisterCommand :: CommandUI RegisterFlags +unregisterCommand = CommandUI + { commandName = "unregister" + , commandSynopsis = + "Unregister this package with the compiler." + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " unregister [FLAGS]\n" + , commandDefaultFlags = defaultRegisterFlags + , commandOptions = \showOrParseArgs -> + [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) + ,optionDistPref + regDistPref (\d flags -> flags { regDistPref = d }) + showOrParseArgs + + ,option "" ["user"] "" + regPackageDB (\v flags -> flags { regPackageDB = v }) + (choiceOpt [ (Flag UserPackageDB, ([],["user"]), + "unregister this package in the user's local package database") + , (Flag GlobalPackageDB, ([],["global"]), + "(default) unregister this package in the system-wide package database")]) + + ,option "" ["gen-script"] + "Instead of performing the unregister command, generate a script to unregister later" + regGenScript (\v flags -> flags { regGenScript = v }) + trueArg + ] + } + +emptyRegisterFlags :: RegisterFlags +emptyRegisterFlags = mempty + +instance Monoid RegisterFlags where + mempty = RegisterFlags { + regPackageDB = mempty, + regGenScript = mempty, + regGenPkgConf = mempty, + regInPlace = mempty, + 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 + +-- ------------------------------------------------------------ +-- * HsColour flags +-- ------------------------------------------------------------ + +data HscolourFlags = HscolourFlags { + hscolourCSS :: Flag FilePath, + hscolourExecutables :: Flag Bool, + hscolourTestSuites :: Flag Bool, + hscolourBenchmarks :: Flag Bool, + hscolourDistPref :: Flag FilePath, + hscolourVerbosity :: Flag Verbosity + } + deriving Show + +emptyHscolourFlags :: HscolourFlags +emptyHscolourFlags = mempty + +defaultHscolourFlags :: HscolourFlags +defaultHscolourFlags = HscolourFlags { + hscolourCSS = NoFlag, + hscolourExecutables = Flag False, + hscolourTestSuites = Flag False, + hscolourBenchmarks = Flag False, + hscolourDistPref = Flag defaultDistPref, + 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 + +hscolourCommand :: CommandUI HscolourFlags +hscolourCommand = CommandUI + { commandName = "hscolour" + , commandSynopsis = + "Generate HsColour colourised code, in HTML format." + , commandDescription = Just (\_ -> "Requires the hscolour program.\n") + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " hscolour [FLAGS]\n" + , commandDefaultFlags = defaultHscolourFlags + , commandOptions = \showOrParseArgs -> + [optionVerbosity hscolourVerbosity + (\v flags -> flags { hscolourVerbosity = v }) + ,optionDistPref + hscolourDistPref (\d flags -> flags { hscolourDistPref = d }) + showOrParseArgs + + ,option "" ["executables"] + "Run hscolour for Executables targets" + hscolourExecutables (\v flags -> flags { hscolourExecutables = v }) + trueArg + + ,option "" ["tests"] + "Run hscolour for Test Suite targets" + hscolourTestSuites (\v flags -> flags { hscolourTestSuites = v }) + trueArg + + ,option "" ["benchmarks"] + "Run hscolour for Benchmark targets" + hscolourBenchmarks (\v flags -> flags { hscolourBenchmarks = v }) + trueArg + + ,option "" ["all"] + "Run hscolour for all targets" + (\f -> allFlags [ hscolourExecutables f + , hscolourTestSuites f + , hscolourBenchmarks f]) + (\v flags -> flags { hscolourExecutables = v + , hscolourTestSuites = v + , hscolourBenchmarks = v }) + trueArg + + ,option "" ["css"] + "Use a cascading style sheet" + hscolourCSS (\v flags -> flags { hscolourCSS = v }) + (reqArgFlag "PATH") + ] + } + +-- ------------------------------------------------------------ +-- * Haddock flags +-- ------------------------------------------------------------ + +data HaddockFlags = HaddockFlags { + haddockProgramPaths :: [(String, FilePath)], + haddockProgramArgs :: [(String, [String])], + haddockHoogle :: Flag Bool, + haddockHtml :: Flag Bool, + haddockHtmlLocation :: Flag String, + haddockExecutables :: Flag Bool, + haddockTestSuites :: Flag Bool, + haddockBenchmarks :: Flag Bool, + haddockInternal :: Flag Bool, + haddockCss :: Flag FilePath, + haddockHscolour :: Flag Bool, + haddockHscolourCss :: Flag FilePath, + haddockContents :: Flag PathTemplate, + haddockDistPref :: Flag FilePath, + haddockKeepTempFiles:: Flag Bool, + haddockVerbosity :: Flag Verbosity + } + deriving Show + +defaultHaddockFlags :: HaddockFlags +defaultHaddockFlags = HaddockFlags { + haddockProgramPaths = mempty, + haddockProgramArgs = [], + haddockHoogle = Flag False, + haddockHtml = Flag False, + haddockHtmlLocation = NoFlag, + haddockExecutables = Flag False, + haddockTestSuites = Flag False, + haddockBenchmarks = Flag False, + haddockInternal = Flag False, + haddockCss = NoFlag, + haddockHscolour = Flag False, + haddockHscolourCss = NoFlag, + haddockContents = NoFlag, + haddockDistPref = Flag defaultDistPref, + haddockKeepTempFiles= Flag False, + haddockVerbosity = Flag normal + } + +haddockCommand :: CommandUI HaddockFlags +haddockCommand = CommandUI + { commandName = "haddock" + , commandSynopsis = "Generate Haddock HTML documentation." + , commandDescription = Just $ \_ -> + "Requires the program haddock, version 2.x.\n" + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " haddock [FLAGS]\n" + , commandDefaultFlags = defaultHaddockFlags + , commandOptions = \showOrParseArgs -> + haddockOptions showOrParseArgs + ++ programConfigurationPaths progConf ParseArgs + haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v}) + ++ programConfigurationOption progConf showOrParseArgs + haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v }) + ++ programConfigurationOptions progConf ParseArgs + haddockProgramArgs (\v flags -> flags { haddockProgramArgs = v}) + } + where + progConf = addKnownProgram haddockProgram + $ addKnownProgram ghcProgram + $ emptyProgramConfiguration + +haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] +haddockOptions showOrParseArgs = + [optionVerbosity haddockVerbosity + (\v flags -> flags { haddockVerbosity = v }) + ,optionDistPref + haddockDistPref (\d flags -> flags { haddockDistPref = d }) + showOrParseArgs + + ,option "" ["keep-temp-files"] + "Keep temporary files" + haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b }) + trueArg + + ,option "" ["hoogle"] + "Generate a hoogle database" + haddockHoogle (\v flags -> flags { haddockHoogle = v }) + trueArg + + ,option "" ["html"] + "Generate HTML documentation (the default)" + haddockHtml (\v flags -> flags { haddockHtml = v }) + trueArg + + ,option "" ["html-location"] + "Location of HTML documentation for pre-requisite packages" + haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v }) + (reqArgFlag "URL") + + ,option "" ["executables"] + "Run haddock for Executables targets" + haddockExecutables (\v flags -> flags { haddockExecutables = v }) + trueArg + + ,option "" ["tests"] + "Run haddock for Test Suite targets" + haddockTestSuites (\v flags -> flags { haddockTestSuites = v }) + trueArg + + ,option "" ["benchmarks"] + "Run haddock for Benchmark targets" + haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v }) + trueArg + + ,option "" ["all"] + "Run haddock for all targets" + (\f -> allFlags [ haddockExecutables f + , haddockTestSuites f + , haddockBenchmarks f]) + (\v flags -> flags { haddockExecutables = v + , haddockTestSuites = v + , haddockBenchmarks = v }) + trueArg + + ,option "" ["internal"] + "Run haddock for internal modules and include all symbols" + haddockInternal (\v flags -> flags { haddockInternal = v }) + trueArg + + ,option "" ["css"] + "Use PATH as the haddock stylesheet" + haddockCss (\v flags -> flags { haddockCss = v }) + (reqArgFlag "PATH") + + ,option "" ["hyperlink-source","hyperlink-sources"] + "Hyperlink the documentation to the source code (using HsColour)" + haddockHscolour (\v flags -> flags { haddockHscolour = v }) + trueArg + + ,option "" ["hscolour-css"] + "Use PATH as the HsColour stylesheet" + haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v }) + (reqArgFlag "PATH") + + ,option "" ["contents-location"] + "Bake URL in as the location for the contents page" + haddockContents (\v flags -> flags { haddockContents = v }) + (reqArg' "URL" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate)) + ] + +emptyHaddockFlags :: HaddockFlags +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 + +-- ------------------------------------------------------------ +-- * Clean flags +-- ------------------------------------------------------------ + +data CleanFlags = CleanFlags { + cleanSaveConf :: Flag Bool, + cleanDistPref :: Flag FilePath, + cleanVerbosity :: Flag Verbosity + } + deriving Show + +defaultCleanFlags :: CleanFlags +defaultCleanFlags = CleanFlags { + cleanSaveConf = Flag False, + cleanDistPref = Flag defaultDistPref, + cleanVerbosity = Flag normal + } + +cleanCommand :: CommandUI CleanFlags +cleanCommand = CommandUI + { commandName = "clean" + , commandSynopsis = "Clean up after a build." + , commandDescription = Just $ \_ -> + "Removes .hi, .o, preprocessed sources, etc.\n" + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " clean [FLAGS]\n" + , commandDefaultFlags = defaultCleanFlags + , commandOptions = \showOrParseArgs -> + [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) + ,optionDistPref + cleanDistPref (\d flags -> flags { cleanDistPref = d }) + showOrParseArgs + + ,option "s" ["save-configure"] + "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." + cleanSaveConf (\v flags -> flags { cleanSaveConf = v }) + trueArg + ] + } + +emptyCleanFlags :: CleanFlags +emptyCleanFlags = mempty + +instance Monoid CleanFlags where + mempty = CleanFlags { + cleanSaveConf = mempty, + cleanDistPref = mempty, + cleanVerbosity = mempty + } + mappend a b = CleanFlags { + cleanSaveConf = combine cleanSaveConf, + cleanDistPref = combine cleanDistPref, + cleanVerbosity = combine cleanVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Build flags +-- ------------------------------------------------------------ + +data BuildFlags = BuildFlags { + buildProgramPaths :: [(String, FilePath)], + buildProgramArgs :: [(String, [String])], + buildDistPref :: Flag FilePath, + buildVerbosity :: Flag Verbosity, + buildNumJobs :: Flag (Maybe Int), + -- TODO: this one should not be here, it's just that the silly + -- UserHooks stop us from passing extra info in other ways + buildArgs :: [String] + } + deriving Show + +{-# DEPRECATED buildVerbose "Use buildVerbosity instead" #-} +buildVerbose :: BuildFlags -> Verbosity +buildVerbose = fromFlagOrDefault normal . buildVerbosity + +defaultBuildFlags :: BuildFlags +defaultBuildFlags = BuildFlags { + buildProgramPaths = mempty, + buildProgramArgs = [], + buildDistPref = Flag defaultDistPref, + buildVerbosity = Flag normal, + buildNumJobs = mempty, + buildArgs = [] + } + +buildCommand :: ProgramConfiguration -> CommandUI BuildFlags +buildCommand progConf = CommandUI + { commandName = "build" + , commandSynopsis = "Compile all/specific components." + , commandDescription = Just $ \_ -> wrapText $ + "Components encompass executables, tests, and benchmarks.\n" + ++ "\n" + ++ "Affected by configuration options, see `configure`.\n" + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " build " + ++ " All the components in the package\n" + ++ " " ++ pname ++ " build foo " + ++ " A component (i.e. lib, exe, test suite)\n\n" + ++ programFlagsDescription progConf +--TODO: re-enable once we have support for module/file targets +-- ++ " " ++ pname ++ " build Foo.Bar " +-- ++ " A module\n" +-- ++ " " ++ pname ++ " build Foo/Bar.hs" +-- ++ " A file\n\n" +-- ++ "If a target is ambiguous it can be qualified with the component " +-- ++ "name, e.g.\n" +-- ++ " " ++ pname ++ " build foo:Foo.Bar\n" +-- ++ " " ++ pname ++ " build testsuite1:Foo/Bar.hs\n" + , commandUsage = usageAlternatives "build" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultBuildFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity + buildVerbosity (\v flags -> flags { buildVerbosity = v }) + + , optionDistPref + buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs + ] + ++ buildOptions progConf showOrParseArgs + } + +buildOptions :: ProgramConfiguration -> ShowOrParseArgs + -> [OptionField BuildFlags] +buildOptions progConf showOrParseArgs = + [ optionNumJobs + buildNumJobs (\v flags -> flags { buildNumJobs = v }) + ] + + ++ programConfigurationPaths progConf showOrParseArgs + buildProgramPaths (\v flags -> flags { buildProgramPaths = v}) + + ++ programConfigurationOption progConf showOrParseArgs + buildProgramArgs (\v fs -> fs { buildProgramArgs = v }) + + ++ programConfigurationOptions progConf showOrParseArgs + buildProgramArgs (\v flags -> flags { buildProgramArgs = v}) + +emptyBuildFlags :: BuildFlags +emptyBuildFlags = mempty + +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 + +-- ------------------------------------------------------------ +-- * REPL Flags +-- ------------------------------------------------------------ + +data ReplFlags = ReplFlags { + replProgramPaths :: [(String, FilePath)], + replProgramArgs :: [(String, [String])], + replDistPref :: Flag FilePath, + replVerbosity :: Flag Verbosity, + replReload :: Flag Bool + } + deriving Show + +defaultReplFlags :: ReplFlags +defaultReplFlags = ReplFlags { + replProgramPaths = mempty, + replProgramArgs = [], + replDistPref = Flag defaultDistPref, + replVerbosity = Flag normal, + replReload = Flag False + } + +instance Monoid ReplFlags where + mempty = ReplFlags { + replProgramPaths = mempty, + replProgramArgs = mempty, + replVerbosity = mempty, + replDistPref = mempty, + replReload = mempty + } + mappend a b = ReplFlags { + replProgramPaths = combine replProgramPaths, + replProgramArgs = combine replProgramArgs, + replVerbosity = combine replVerbosity, + replDistPref = combine replDistPref, + replReload = combine replReload + } + where combine field = field a `mappend` field b + +replCommand :: ProgramConfiguration -> CommandUI ReplFlags +replCommand progConf = CommandUI + { commandName = "repl" + , commandSynopsis = + "Open an interpreter session for the given component." + , commandDescription = Just $ \pname -> wrapText $ + "If the current directory contains no package, ignores COMPONENT " + ++ "parameters and opens an interactive interpreter session; if a " + ++ "sandbox is present, its package database will be used.\n" + ++ "\n" + ++ "Otherwise, (re)configures with the given or default flags, and " + ++ "loads the interpreter with the relevant modules. For executables, " + ++ "tests and benchmarks, loads the main module (and its " + ++ "dependencies); for libraries all exposed/other modules.\n" + ++ "\n" + ++ "The default component is the library itself, or the executable " + ++ "if that is the only component.\n" + ++ "\n" + ++ "Support for loading specific modules is planned but not " + ++ "implemented yet. For certain scenarios, `" ++ pname + ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will " + ++ "not (re)configure and you will have to specify the location of " + ++ "other modules, if required.\n" + + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " repl " + ++ " The first component in the package\n" + ++ " " ++ pname ++ " repl foo " + ++ " A named component (i.e. lib, exe, test suite)\n" + ++ " " ++ pname ++ " repl --ghc-options=\"-lstdc++\"" + ++ " Specifying flags for interpreter\n" +--TODO: re-enable once we have support for module/file targets +-- ++ " " ++ pname ++ " repl Foo.Bar " +-- ++ " A module\n" +-- ++ " " ++ pname ++ " repl Foo/Bar.hs" +-- ++ " A file\n\n" +-- ++ "If a target is ambiguous it can be qualified with the component " +-- ++ "name, e.g.\n" +-- ++ " " ++ pname ++ " repl foo:Foo.Bar\n" +-- ++ " " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n" + , commandUsage = \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n" + , commandDefaultFlags = defaultReplFlags + , commandOptions = \showOrParseArgs -> + optionVerbosity replVerbosity (\v flags -> flags { replVerbosity = v }) + : optionDistPref + replDistPref (\d flags -> flags { replDistPref = d }) + showOrParseArgs + + : programConfigurationPaths progConf showOrParseArgs + replProgramPaths (\v flags -> flags { replProgramPaths = v}) + + ++ programConfigurationOption progConf showOrParseArgs + replProgramArgs (\v flags -> flags { replProgramArgs = v}) + + ++ programConfigurationOptions progConf showOrParseArgs + replProgramArgs (\v flags -> flags { replProgramArgs = v}) + + ++ case showOrParseArgs of + ParseArgs -> + [ option "" ["reload"] + "Used from within an interpreter to update files." + replReload (\v flags -> flags { replReload = v }) + trueArg + ] + _ -> [] + } + +-- ------------------------------------------------------------ +-- * Test flags +-- ------------------------------------------------------------ + +data TestShowDetails = Never | Failures | Always | Streaming + deriving (Eq, Ord, Enum, Bounded, Show) + +knownTestShowDetails :: [TestShowDetails] +knownTestShowDetails = [minBound..maxBound] + +instance Text TestShowDetails where + disp = Disp.text . lowercase . show + + parse = maybe Parse.pfail return . classify =<< ident + where + ident = Parse.munch1 (\c -> isAlpha c || c == '_' || c == '-') + classify str = lookup (lowercase str) enumMap + enumMap :: [(String, TestShowDetails)] + enumMap = [ (display x, x) + | x <- knownTestShowDetails ] + +--TODO: do we need this instance? +instance Monoid TestShowDetails where + mempty = Never + mappend a b = if a < b then b else a + +data TestFlags = TestFlags { + testDistPref :: Flag FilePath, + testVerbosity :: Flag Verbosity, + testHumanLog :: Flag PathTemplate, + testMachineLog :: Flag PathTemplate, + testShowDetails :: Flag TestShowDetails, + testKeepTix :: Flag Bool, + -- TODO: think about if/how options are passed to test exes + testOptions :: [PathTemplate] + } + +defaultTestFlags :: TestFlags +defaultTestFlags = TestFlags { + testDistPref = Flag defaultDistPref, + testVerbosity = Flag normal, + testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log", + testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log", + testShowDetails = toFlag Failures, + testKeepTix = toFlag False, + testOptions = [] + } + +testCommand :: CommandUI TestFlags +testCommand = CommandUI + { commandName = "test" + , commandSynopsis = + "Run all/specific tests in the test suite." + , commandDescription = Just $ \pname -> wrapText $ + "If necessary (re)configures with `--enable-tests` flag and builds" + ++ " the test suite.\n" + ++ "\n" + ++ "Remember that the tests' dependencies must be installed if there" + ++ " are additional ones; e.g. with `" ++ pname + ++ " install --only-dependencies --enable-tests`.\n" + ++ "\n" + ++ "By defining UserHooks in a custom Setup.hs, the package can" + ++ " define actions to be executed before and after running tests.\n" + , commandNotes = Nothing + , commandUsage = usageAlternatives "test" + [ "[FLAGS]" + , "TESTCOMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultTestFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) + , optionDistPref + testDistPref (\d flags -> flags { testDistPref = d }) + showOrParseArgs + , option [] ["log"] + ("Log all test suite results to file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)") + testHumanLog (\v flags -> flags { testHumanLog = v }) + (reqArg' "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate)) + , option [] ["machine-log"] + ("Produce a machine-readable log file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $result)") + testMachineLog (\v flags -> flags { testMachineLog = v }) + (reqArg' "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate)) + , option [] ["show-details"] + ("'always': always show results of individual test cases. " + ++ "'never': never show results of individual test cases. " + ++ "'failures': show results of failing test cases. " + ++ "'streaming': show results of test cases in real time.") + testShowDetails (\v flags -> flags { testShowDetails = v }) + (reqArg "FILTER" + (readP_to_E (\_ -> "--show-details flag expects one of " + ++ intercalate ", " + (map display knownTestShowDetails)) + (fmap toFlag parse)) + (flagToList . fmap display)) + , option [] ["keep-tix-files"] + "keep .tix files for HPC between test runs" + testKeepTix (\v flags -> flags { testKeepTix = v}) + trueArg + , option [] ["test-options"] + ("give extra options to test executables " + ++ "(name templates can use $pkgid, $compiler, " + ++ "$os, $arch, $test-suite)") + testOptions (\v flags -> flags { testOptions = v }) + (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) + (const [])) + , option [] ["test-option"] + ("give extra option to test executables " + ++ "(no need to quote options containing spaces, " + ++ "name template can use $pkgid, $compiler, " + ++ "$os, $arch, $test-suite)") + testOptions (\v flags -> flags { testOptions = v }) + (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) + (map fromPathTemplate)) + ] + } + +emptyTestFlags :: TestFlags +emptyTestFlags = mempty + +instance Monoid TestFlags where + mempty = TestFlags { + testDistPref = mempty, + testVerbosity = mempty, + testHumanLog = mempty, + testMachineLog = mempty, + testShowDetails = mempty, + testKeepTix = mempty, + 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 + +-- ------------------------------------------------------------ +-- * Benchmark flags +-- ------------------------------------------------------------ + +data BenchmarkFlags = BenchmarkFlags { + benchmarkDistPref :: Flag FilePath, + benchmarkVerbosity :: Flag Verbosity, + benchmarkOptions :: [PathTemplate] + } + +defaultBenchmarkFlags :: BenchmarkFlags +defaultBenchmarkFlags = BenchmarkFlags { + benchmarkDistPref = Flag defaultDistPref, + benchmarkVerbosity = Flag normal, + benchmarkOptions = [] + } + +benchmarkCommand :: CommandUI BenchmarkFlags +benchmarkCommand = CommandUI + { commandName = "bench" + , commandSynopsis = + "Run all/specific benchmarks." + , commandDescription = Just $ \pname -> wrapText $ + "If necessary (re)configures with `--enable-benchmarks` flag and" + ++ " builds the benchmarks.\n" + ++ "\n" + ++ "Remember that the benchmarks' dependencies must be installed if" + ++ " there are additional ones; e.g. with `" ++ pname + ++ " install --only-dependencies --enable-benchmarks`.\n" + ++ "\n" + ++ "By defining UserHooks in a custom Setup.hs, the package can" + ++ " define actions to be executed before and after running" + ++ " benchmarks.\n" + , commandNotes = Nothing + , commandUsage = usageAlternatives "bench" + [ "[FLAGS]" + , "BENCHCOMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultBenchmarkFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity benchmarkVerbosity + (\v flags -> flags { benchmarkVerbosity = v }) + , optionDistPref + benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d }) + showOrParseArgs + , option [] ["benchmark-options"] + ("give extra options to benchmark executables " + ++ "(name templates can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)") + benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) + (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) + (const [])) + , option [] ["benchmark-option"] + ("give extra option to benchmark executables " + ++ "(no need to quote options containing spaces, " + ++ "name template can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)") + benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) + (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) + (map fromPathTemplate)) + ] + } + +emptyBenchmarkFlags :: BenchmarkFlags +emptyBenchmarkFlags = mempty + +instance Monoid BenchmarkFlags where + mempty = BenchmarkFlags { + benchmarkDistPref = mempty, + benchmarkVerbosity = mempty, + benchmarkOptions = mempty + } + mappend a b = BenchmarkFlags { + benchmarkDistPref = combine benchmarkDistPref, + benchmarkVerbosity = combine benchmarkVerbosity, + benchmarkOptions = combine benchmarkOptions + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Shared options utils +-- ------------------------------------------------------------ + +programFlagsDescription :: ProgramConfiguration -> String +programFlagsDescription progConf = + "The flags --with-PROG and --PROG-option(s) can be used with" + ++ " the following programs:" + ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort) + [ programName prog | (prog, _) <- knownPrograms progConf ] + ++ "\n" + +-- | For each known program @PROG@ in 'progConf', produce a @with-PROG@ +-- 'OptionField'. +programConfigurationPaths + :: ProgramConfiguration + -> ShowOrParseArgs + -> (flags -> [(String, FilePath)]) + -> ([(String, FilePath)] -> (flags -> flags)) + -> [OptionField flags] +programConfigurationPaths progConf showOrParseArgs get set = + programConfigurationPaths' ("with-" ++) progConf showOrParseArgs get set + +-- | Like 'programConfigurationPaths', but allows to customise the option name. +programConfigurationPaths' + :: (String -> String) + -> ProgramConfiguration + -> ShowOrParseArgs + -> (flags -> [(String, FilePath)]) + -> ([(String, FilePath)] -> (flags -> flags)) + -> [OptionField flags] +programConfigurationPaths' mkName progConf showOrParseArgs get set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [withProgramPath "PROG"] + ParseArgs -> map (withProgramPath . programName . fst) + (knownPrograms progConf) + where + withProgramPath prog = + option "" [mkName prog] + ("give the path to " ++ prog) + get set + (reqArg' "PATH" (\path -> [(prog, path)]) + (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) + +-- | For each known program @PROG@ in 'progConf', produce a @PROG-option@ +-- 'OptionField'. +programConfigurationOption + :: ProgramConfiguration + -> ShowOrParseArgs + -> (flags -> [(String, [String])]) + -> ([(String, [String])] -> (flags -> flags)) + -> [OptionField flags] +programConfigurationOption progConf showOrParseArgs get set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [programOption "PROG"] + ParseArgs -> map (programOption . programName . fst) + (knownPrograms progConf) + where + programOption prog = + option "" [prog ++ "-option"] + ("give an extra option to " ++ prog ++ + " (no need to quote options containing spaces)") + get set + (reqArg' "OPT" (\arg -> [(prog, [arg])]) + (\progArgs -> concat [ args + | (prog', args) <- progArgs, prog==prog' ])) + +-- | For each known program @PROG@ in 'progConf', produce a @PROG-options@ +-- 'OptionField'. +programConfigurationOptions + :: ProgramConfiguration + -> ShowOrParseArgs + -> (flags -> [(String, [String])]) + -> ([(String, [String])] -> (flags -> flags)) + -> [OptionField flags] +programConfigurationOptions progConf showOrParseArgs get set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [programOptions "PROG"] + ParseArgs -> map (programOptions . programName . fst) + (knownPrograms progConf) + where + programOptions prog = + option "" [prog ++ "-options"] + ("give extra options to " ++ prog) + get set + (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) + +-- ------------------------------------------------------------ +-- * GetOpt Utils +-- ------------------------------------------------------------ + +boolOpt :: SFlags -> SFlags + -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt = Command.boolOpt flagToMaybe Flag + +boolOpt' :: OptFlags -> OptFlags + -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt' = Command.boolOpt' flagToMaybe Flag + +trueArg, falseArg :: MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +trueArg sfT lfT = boolOpt' (sfT, lfT) ([], []) sfT lfT +falseArg sfF lfF = boolOpt' ([], []) (sfF, lfF) sfF lfF + +reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> + (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b +reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList + +optionDistPref :: (flags -> Flag FilePath) + -> (Flag FilePath -> flags -> flags) + -> ShowOrParseArgs + -> OptionField flags +optionDistPref get set = \showOrParseArgs -> + option "" (distPrefFlagName showOrParseArgs) + ( "The directory where Cabal puts generated build files " + ++ "(default " ++ defaultDistPref ++ ")") + get set + (reqArgFlag "DIR") + where + distPrefFlagName ShowArgs = ["builddir"] + distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"] + +optionVerbosity :: (flags -> Flag Verbosity) + -> (Flag Verbosity -> flags -> flags) + -> OptionField flags +optionVerbosity get set = + option "v" ["verbose"] + "Control verbosity (n is 0--3, default verbosity level is 1)" + get set + (optArg "n" (fmap Flag flagToVerbosity) + (Flag verbose) -- default Value if no n is given + (fmap (Just . showForCabal) . flagToList)) + +optionNumJobs :: (flags -> Flag (Maybe Int)) + -> (Flag (Maybe Int) -> flags -> flags) + -> OptionField flags +optionNumJobs get set = + option "j" ["jobs"] + "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)." + get set + (optArg "NUM" (fmap Flag numJobsParser) + (Flag Nothing) + (map (Just . maybe "$ncpus" show) . flagToList)) + where + numJobsParser :: ReadE (Maybe Int) + numJobsParser = ReadE $ \s -> + case s of + "$ncpus" -> Right Nothing + _ -> case reads s of + [(n, "")] + | n < 1 -> Left "The number of jobs should be 1 or more." + | n > 64 -> Left "You probably don't want that many jobs." + | otherwise -> Right (Just n) + _ -> Left "The jobs value should be a number or '$ncpus'" + +-- ------------------------------------------------------------ +-- * Other Utils +-- ------------------------------------------------------------ + +-- | Arguments to pass to a @configure@ script, e.g. generated by +-- @autoconf@. +configureArgs :: Bool -> ConfigFlags -> [String] +configureArgs bcHack flags + = hc_flag + ++ optFlag "with-hc-pkg" configHcPkg + ++ optFlag' "prefix" prefix + ++ optFlag' "bindir" bindir + ++ optFlag' "libdir" libdir + ++ optFlag' "libexecdir" libexecdir + ++ optFlag' "datadir" datadir + ++ optFlag' "sysconfdir" sysconfdir + ++ configConfigureArgs flags + where + hc_flag = case (configHcFlavor flags, configHcPath flags) of + (_, Flag hc_path) -> [hc_flag_name ++ hc_path] + (Flag hc, NoFlag) -> [hc_flag_name ++ display hc] + (NoFlag,NoFlag) -> [] + hc_flag_name + --TODO kill off thic bc hack when defaultUserHooks is removed. + | bcHack = "--with-hc=" + | otherwise = "--with-compiler=" + optFlag name config_field = case config_field flags of + Flag p -> ["--" ++ name ++ "=" ++ p] + NoFlag -> [] + optFlag' name config_field = optFlag name (fmap fromPathTemplate + . config_field + . configInstallDirs) + +configureCCompiler :: Verbosity -> ProgramConfiguration + -> IO (FilePath, [String]) +configureCCompiler verbosity lbi = configureProg verbosity lbi gccProgram + +configureLinker :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String]) +configureLinker verbosity lbi = configureProg verbosity lbi ldProgram + +configureProg :: Verbosity -> ProgramConfiguration -> Program + -> IO (FilePath, [String]) +configureProg verbosity programConfig prog = do + (p, _) <- requireProgram verbosity prog programConfig + let pInv = programInvocation p [] + return (progInvokePath pInv, progInvokeArgs pInv) + +-- | Helper function to split a string into a list of arguments. +-- It's supposed to handle quoted things sensibly, eg: +-- +-- > splitArgs "--foo=\"C:\Program Files\Bar\" --baz" +-- > = ["--foo=C:\Program Files\Bar", "--baz"] +-- +splitArgs :: String -> [String] +splitArgs = space [] + where + space :: String -> String -> [String] + space w [] = word w [] + space w ( c :s) + | isSpace c = word w (space [] s) + space w ('"':s) = string w s + space w s = nonstring w s + + string :: String -> String -> [String] + string w [] = word w [] + string w ('"':s) = space w s + string w ( c :s) = string (c:w) s + + nonstring :: String -> String -> [String] + nonstring w [] = word w [] + nonstring w ('"':s) = string w s + nonstring w ( c :s) = space (c:w) s + + word [] s = s + word w s = reverse w : s + +-- The test cases kinda have to be rewritten from the ground up... :/ +--hunitTests :: [Test] +--hunitTests = +-- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)] +-- (flags, commands', unkFlags, ers) +-- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"] +-- in [TestLabel "very basic option parsing" $ TestList [ +-- "getOpt flags" ~: "failed" ~: +-- [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag, +-- WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag] +-- ~=? flags, +-- "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands', +-- "getOpt unknown opts" ~: "failed" ~: +-- ["--unknown1", "--unknown2"] ~=? unkFlags, +-- "getOpt errors" ~: "failed" ~: [] ~=? ers], +-- +-- TestLabel "test location of various compilers" $ TestList +-- ["configure parsing for prefix and compiler flag" ~: "failed" ~: +-- (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), [])) +-- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"]) +-- | (name, comp) <- m], +-- +-- TestLabel "find the package tool" $ TestList +-- ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~: +-- (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), [])) +-- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, +-- "--with-compiler=/foo/comp", "configure"]) +-- | (name, comp) <- m], +-- +-- TestLabel "simpler commands" $ TestList +-- [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag]) +-- | (flag, flagCmd) <- [("build", BuildCmd), +-- ("install", InstallCmd Nothing False), +-- ("sdist", SDistCmd), +-- ("register", RegisterCmd False)] +-- ] +-- ] + +{- Testing ideas: + * IO to look for hugs and hugs-pkg (which hugs, etc) + * quickCheck to test permutations of arguments + * what other options can we over-ride with a command-line flag? +-} diff --git a/Distribution/Simple/SrcDist.hs b/Distribution/Simple/SrcDist.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/SrcDist.hs @@ -0,0 +1,491 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.SrcDist +-- Copyright : Simon Marlow 2004 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This handles the @sdist@ command. The module exports an 'sdist' action but +-- also some of the phases that make it up so that other tools can use just the +-- bits they need. In particular the preparation of the tree of files to go +-- into the source tarball is separated from actually building the source +-- tarball. +-- +-- The 'createArchive' action uses the external @tar@ program and assumes that +-- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows. +-- The 'sdist' action now also does some distribution QA checks. + +-- NOTE: FIX: we don't have a great way of testing this module, since +-- we can't easily look inside a tarball once its created. + +module Distribution.Simple.SrcDist ( + -- * The top level action + sdist, + + -- ** Parts of 'sdist' + printPackageProblems, + prepareTree, + createArchive, + + -- ** Snapshots + prepareSnapshotTree, + snapshotPackage, + snapshotVersion, + dateToSnapshotNumber, + + -- * Extracting the source files + listPackageSources + + ) where + +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) + , TestSuite(..), TestSuiteInterface(..), Benchmark(..) + , BenchmarkInterface(..) ) +import Distribution.PackageDescription.Check + ( PackageCheck(..), checkConfiguredPackage, checkPackageFiles ) +import Distribution.Package + ( PackageIdentifier(pkgVersion), Package(..), packageVersion ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Version + ( Version(versionBranch) ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File + , 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.LocalBuildInfo + ( LocalBuildInfo(..), withAllComponentsInBuildOrder ) +import Distribution.Simple.BuildPaths ( autogenModuleName ) +import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram, + runProgram, programProperties, tarProgram ) +import Distribution.Text + ( display ) + +import Control.Monad(when, unless, forM) +import Data.Char (toLower) +import Data.List (partition, isPrefixOf) +import qualified Data.Map as Map +import Data.Maybe (isNothing, catMaybes) +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 ) + +-- |Create a source distribution. +sdist :: PackageDescription -- ^information from the tarball + -> Maybe LocalBuildInfo -- ^Information from configure + -> SDistFlags -- ^verbosity & snapshot + -> (FilePath -> FilePath) -- ^build prefix (temp dir) + -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) + -> IO () +sdist pkg mb_lbi flags mkTmpDir pps = + + -- When given --list-sources, just output the list of sources to a file. + case (sDistListSources flags) of + Flag path -> withFile path WriteMode $ \outHandle -> do + (ordinary, maybeExecutable) <- listPackageSources verbosity pkg pps + mapM_ (hPutStrLn outHandle) ordinary + mapM_ (hPutStrLn outHandle) maybeExecutable + notice verbosity $ "List of package sources written to file '" + ++ path ++ "'" + NoFlag -> do + -- do some QA + printPackageProblems verbosity pkg + + when (isNothing mb_lbi) $ + warn verbosity "Cannot run preprocessors. Run 'configure' command first." + + date <- getCurrentTime + let pkg' | snapshot = snapshotPackage date pkg + | otherwise = pkg + + case flagToMaybe (sDistDirectory flags) of + Just targetDir -> do + generateSourceDir targetDir pkg' + info verbosity $ "Source directory created: " ++ targetDir + + Nothing -> do + createDirectoryIfMissingVerbose verbosity True tmpTargetDir + withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + let targetDir = tmpDir tarBallName pkg' + generateSourceDir targetDir pkg' + targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref + notice verbosity $ "Source tarball created: " ++ targzFile + + where + generateSourceDir targetDir pkg' = do + + setupMessage verbosity "Building source dist for" (packageId pkg') + prepareTree verbosity pkg' mb_lbi targetDir pps + when snapshot $ + overwriteSnapshotPackageDesc verbosity pkg' targetDir + + verbosity = fromFlag (sDistVerbosity flags) + snapshot = fromFlag (sDistSnapshot flags) + + distPref = fromFlag $ sDistDistPref flags + targetPref = distPref + tmpTargetDir = mkTmpDir distPref + +-- | List all source files of a package. Returns a tuple of lists: first +-- component is a list of ordinary files, second one is a list of those files +-- that may be executable. +listPackageSources :: Verbosity -- ^ verbosity + -> PackageDescription -- ^ info from the cabal file + -> [PPSuffixHandler] -- ^ extra preprocessors (include + -- suffixes) + -> IO ([FilePath], [FilePath]) +listPackageSources verbosity pkg_descr0 pps = do + -- Call helpers that actually do all work. + ordinary <- listPackageSourcesOrdinary verbosity pkg_descr pps + maybeExecutable <- listPackageSourcesMaybeExecutable pkg_descr + return (ordinary, maybeExecutable) + where + pkg_descr = filterAutogenModule pkg_descr0 + +-- | List those source files that may be executable (e.g. the configure script). +listPackageSourcesMaybeExecutable :: PackageDescription -> IO [FilePath] +listPackageSourcesMaybeExecutable pkg_descr = + -- Extra source files. + fmap concat . forM (extraSrcFiles pkg_descr) $ \fpath -> matchFileGlob fpath + +-- | List those source files that should be copied with ordinary permissions. +listPackageSourcesOrdinary :: Verbosity + -> PackageDescription + -> [PPSuffixHandler] + -> IO [FilePath] +listPackageSourcesOrdinary verbosity pkg_descr pps = + fmap concat . sequence $ + [ + -- Library sources. + withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } -> + allSourcesBuildInfo libBi pps modules + + -- Executables sources. + , fmap concat + . withExe $ \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 + let bi = testBuildInfo t + case testInterface t of + TestSuiteExeV10 _ mainPath -> do + biSrcs <- allSourcesBuildInfo bi pps [] + srcMainFile <- do + ppFile <- findFileWithExtension (ppSuffixes pps) + (hsSourceDirs bi) (dropExtension mainPath) + case ppFile of + Nothing -> findFile (hsSourceDirs bi) mainPath + Just pp -> return pp + return (srcMainFile:biSrcs) + TestSuiteLibV09 _ m -> + allSourcesBuildInfo bi pps [m] + TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " + ++ show tp + + -- Benchmarks sources. + , fmap concat + . withBenchmark $ \bm -> do + let bi = benchmarkBuildInfo bm + case benchmarkInterface bm of + BenchmarkExeV10 _ mainPath -> do + biSrcs <- allSourcesBuildInfo bi pps [] + srcMainFile <- do + ppFile <- findFileWithExtension (ppSuffixes pps) + (hsSourceDirs bi) (dropExtension mainPath) + case ppFile of + Nothing -> findFile (hsSourceDirs bi) mainPath + Just pp -> return pp + return (srcMainFile:biSrcs) + BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: " + ++ show tp + + -- Data files. + , fmap concat + . forM (dataFiles pkg_descr) $ \filename -> + matchFileGlob (dataDir pkg_descr filename) + + -- Extra doc files. + , fmap concat + . forM (extraDocFiles pkg_descr) $ \ filename -> + matchFileGlob filename + + -- License file(s). + , return (licenseFiles pkg_descr) + + -- Install-include files. + , withLib $ \ l -> do + let lbi = libBuildInfo l + relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) + mapM (fmap snd . findIncludeFile relincdirs) (installIncludes lbi) + + -- Setup script, if it exists. + , fmap (maybe [] (\f -> [f])) $ findSetupFile "" + + -- The .cabal file itself. + , fmap (\d -> [d]) (defaultPackageDesc verbosity) + + ] + where + -- We have to deal with all libs and executables, so we have local + -- versions of these functions that ignore the 'buildable' attribute: + withLib action = maybe (return []) action (library pkg_descr) + withExe action = mapM action (executables pkg_descr) + withTest action = mapM action (testSuites pkg_descr) + withBenchmark action = mapM action (benchmarks pkg_descr) + + +-- |Prepare a directory tree of source files. +prepareTree :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> Maybe LocalBuildInfo + -> FilePath -- ^source tree to populate + -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) + -> IO () +prepareTree verbosity pkg_descr0 mb_lbi targetDir pps = do + -- If the package was configured then we can run platform-independent + -- pre-processors and include those generated files. + case mb_lbi of + Just lbi | not (null pps) -> do + let lbi' = lbi{ buildDir = targetDir buildDir lbi } + withAllComponentsInBuildOrder pkg_descr lbi' $ \c _ -> + preprocessComponent pkg_descr c lbi' True verbosity pps + _ -> return () + + (ordinary, mExecutable) <- listPackageSources verbosity pkg_descr0 pps + installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary) + installMaybeExecutableFiles verbosity targetDir (zip (repeat []) mExecutable) + maybeCreateDefaultSetupScript targetDir + + where + pkg_descr = filterAutogenModule pkg_descr0 + +-- | Find the setup script file, if it exists. +findSetupFile :: FilePath -> IO (Maybe FilePath) +findSetupFile targetDir = do + hsExists <- doesFileExist setupHs + lhsExists <- doesFileExist setupLhs + if hsExists + then return (Just setupHs) + else if lhsExists + then return (Just setupLhs) + else return Nothing + where + setupHs = targetDir "Setup.hs" + setupLhs = targetDir "Setup.lhs" + +-- | Create a default setup script in the target directory, if it doesn't exist. +maybeCreateDefaultSetupScript :: FilePath -> IO () +maybeCreateDefaultSetupScript targetDir = do + mSetupFile <- findSetupFile targetDir + case mSetupFile of + Just _setupFile -> return () + Nothing -> do + writeUTF8File (targetDir "Setup.hs") $ unlines [ + "import Distribution.Simple", + "main = defaultMain"] + +-- | Find the main executable file. +findMainExeFile :: BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath +findMainExeFile exeBi pps mainPath = do + ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) + (dropExtension mainPath) + case ppFile of + Nothing -> findFile (hsSourceDirs exeBi) mainPath + Just pp -> return pp + +-- | Given a list of include paths, try to find the include file named +-- @f@. Return the name of the file and the full path, or exit with error if +-- there's no such file. +findIncludeFile :: [FilePath] -> String -> IO (String, FilePath) +findIncludeFile [] f = die ("can't find include file " ++ f) +findIncludeFile (d:ds) f = do + let path = (d f) + b <- doesFileExist path + if b then return (f,path) else findIncludeFile ds f + +-- | Remove the auto-generated module ('Paths_*') from 'exposed-modules' and +-- 'other-modules'. +filterAutogenModule :: PackageDescription -> PackageDescription +filterAutogenModule pkg_descr0 = mapLib filterAutogenModuleLib $ + mapAllBuildInfo filterAutogenModuleBI pkg_descr0 + where + mapLib f pkg = pkg { library = fmap f (library pkg) } + filterAutogenModuleLib lib = lib { + exposedModules = filter (/=autogenModule) (exposedModules lib) + } + filterAutogenModuleBI bi = bi { + otherModules = filter (/=autogenModule) (otherModules bi) + } + autogenModule = autogenModuleName pkg_descr0 + +-- | Prepare a directory tree of source files for a snapshot version. +-- It is expected that the appropriate snapshot version has already been set +-- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. +-- +prepareSnapshotTree :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> Maybe LocalBuildInfo + -> FilePath -- ^source tree to populate + -> [PPSuffixHandler] -- ^extra preprocessors (includes + -- suffixes) + -> IO () +prepareSnapshotTree verbosity pkg mb_lbi targetDir pps = do + prepareTree verbosity pkg mb_lbi targetDir pps + overwriteSnapshotPackageDesc verbosity pkg targetDir + +overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> FilePath -- ^source tree + -> IO () +overwriteSnapshotPackageDesc verbosity pkg targetDir = do + -- We could just writePackageDescription targetDescFile pkg_descr, + -- but that would lose comments and formatting. + descFile <- defaultPackageDesc verbosity + withUTF8FileContents descFile $ + writeUTF8File (targetDir descFile) + . unlines . map (replaceVersion (packageVersion pkg)) . lines + + where + replaceVersion :: Version -> String -> String + replaceVersion version line + | "version:" `isPrefixOf` map toLower line + = "version: " ++ display version + | otherwise = line + +-- | Modifies a 'PackageDescription' by appending a snapshot number +-- corresponding to the given date. +-- +snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription +snapshotPackage date pkg = + pkg { + package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) } + } + where pkgid = packageId pkg + +-- | Modifies a 'Version' by appending a snapshot number corresponding +-- to the given date. +-- +snapshotVersion :: UTCTime -> Version -> Version +snapshotVersion date version = version { + versionBranch = versionBranch version + ++ [dateToSnapshotNumber date] + } + +-- | Given a date produce a corresponding integer representation. +-- For example given a date @18/03/2008@ produce the number @20080318@. +-- +dateToSnapshotNumber :: UTCTime -> Int +dateToSnapshotNumber date = case toGregorian (utctDay date) of + (year, month, day) -> + fromIntegral year * 10000 + + month * 100 + + day + +-- | Callback type for use by sdistWith. +type CreateArchiveFun = Verbosity -- ^verbosity + -> PackageDescription -- ^info from cabal file + -> Maybe LocalBuildInfo -- ^info from configure + -> FilePath -- ^source tree to archive + -> FilePath -- ^name of archive to create + -> IO FilePath + +-- | Create an archive from a tree of source files, and clean up the tree. +createArchive :: CreateArchiveFun +createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do + let tarBallFilePath = targetPref tarBallName pkg_descr <.> "tar.gz" + + (tarProg, _) <- requireProgram verbosity tarProgram + (maybe defaultProgramConfiguration withPrograms mb_lbi) + let formatOptSupported = maybe False (== "YES") $ + Map.lookup "Supports --format" + (programProperties tarProg) + runProgram verbosity tarProg $ + -- Hmm: I could well be skating on thinner ice here by using the -C option + -- (=> seems to be supported at least by GNU and *BSD tar) [The + -- prev. solution used pipes and sub-command sequences to set up the paths + -- correctly, which is problematic in a Windows setting.] + ["-czf", tarBallFilePath, "-C", tmpDir] + ++ (if formatOptSupported then ["--format", "ustar"] else []) + ++ [tarBallName pkg_descr] + return tarBallFilePath + +-- | Given a buildinfo, return the names of all source files. +allSourcesBuildInfo :: BuildInfo + -> [PPSuffixHandler] -- ^ Extra preprocessors + -> [ModuleName] -- ^ Exposed modules + -> IO [FilePath] +allSourcesBuildInfo bi pps modules = do + let searchDirs = hsSourceDirs bi + sources <- sequence + [ let file = ModuleName.toFilePath module_ + in findFileWithExtension suffixes searchDirs file + >>= maybe (notFound module_) return + | module_ <- modules ++ otherModules bi ] + bootFiles <- sequence + [ let file = ModuleName.toFilePath module_ + fileExts = ["hs-boot", "lhs-boot"] + in findFileWithExtension fileExts (hsSourceDirs bi) file + | module_ <- modules ++ otherModules bi ] + + return $ sources ++ catMaybes bootFiles ++ cSources bi ++ jsSources bi + + where + suffixes = ppSuffixes pps ++ ["hs", "lhs"] + notFound m = die $ "Error: Could not find module: " ++ display m + ++ " with any suffix: " ++ show suffixes + + +printPackageProblems :: Verbosity -> PackageDescription -> IO () +printPackageProblems verbosity pkg_descr = do + ioChecks <- checkPackageFiles pkg_descr "." + let pureChecks = checkConfiguredPackage pkg_descr + isDistError (PackageDistSuspicious _) = False + isDistError (PackageDistSuspiciousWarn _) = False + isDistError _ = True + (errors, warnings) = partition isDistError (pureChecks ++ ioChecks) + unless (null errors) $ + notice verbosity $ "Distribution quality errors:\n" + ++ unlines (map explanation errors) + unless (null warnings) $ + notice verbosity $ "Distribution quality warnings:\n" + ++ unlines (map explanation warnings) + unless (null errors) $ + notice verbosity + "Note: the public hackage server would reject this package." + +------------------------------------------------------------ + +-- | The name of the tarball without extension +-- +tarBallName :: PackageDescription -> String +tarBallName = display . packageId + +mapAllBuildInfo :: (BuildInfo -> BuildInfo) + -> (PackageDescription -> PackageDescription) +mapAllBuildInfo f pkg = pkg { + library = fmap mapLibBi (library pkg), + executables = fmap mapExeBi (executables pkg), + testSuites = fmap mapTestBi (testSuites pkg), + benchmarks = fmap mapBenchBi (benchmarks pkg) + } + where + mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) } + mapExeBi exe = exe { buildInfo = f (buildInfo exe) } + mapTestBi t = t { testBuildInfo = f (testBuildInfo t) } + mapBenchBi bm = bm { benchmarkBuildInfo = f (benchmarkBuildInfo bm) } diff --git a/Distribution/Simple/Test.hs b/Distribution/Simple/Test.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Test.hs @@ -0,0 +1,136 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Test +-- Copyright : Thomas Tuegel 2010 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into testing a built package. It performs the +-- \"@.\/setup test@\" action. It runs test suites designated in the package +-- description and reports on the results. + +module Distribution.Simple.Test + ( test + ) 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.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 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.Text + +import Control.Monad ( when, unless, filterM ) +import System.Directory + ( createDirectoryIfMissing, doesFileExist, getDirectoryContents + , removeFile ) +import System.Exit ( ExitCode(..), exitFailure, exitWith ) +import System.FilePath ( () ) + +-- |Perform the \"@.\/setup test@\" action. +test :: Args -- ^positional command-line arguments + -> PD.PackageDescription -- ^information from the .cabal file + -> LBI.LocalBuildInfo -- ^information from the configure step + -> TestFlags -- ^flags sent to test + -> IO () +test args pkg_descr lbi flags = do + let verbosity = fromFlag $ testVerbosity flags + machineTemplate = fromFlag $ testMachineLog flags + distPref = fromFlag $ testDistPref flags + testLogDir = distPref "test" + testNames = args + pkgTests = PD.testSuites pkg_descr + enabledTests = [ t | t <- pkgTests + , PD.testEnabled t + , PD.buildable (PD.testBuildInfo t) ] + + doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog + doTest (suite, _) = + case PD.testInterface suite of + PD.TestSuiteExeV10 _ _ -> + ExeV10.runTest pkg_descr lbi flags suite + + PD.TestSuiteLibV09 _ _ -> + LibV09.runTest pkg_descr lbi flags suite + + _ -> return TestSuiteLog + { testSuiteName = PD.testName suite + , testLogs = TestLog + { testName = PD.testName suite + , testOptionsReturned = [] + , testResult = + Error $ "No support for running test suite type: " + ++ show (disp $ PD.testType suite) + } + , logFile = "" + } + + when (not $ PD.hasTests pkg_descr) $ do + notice verbosity "Package has no test suites." + exitWith ExitSuccess + + when (PD.hasTests pkg_descr && null enabledTests) $ + die $ "No test suites enabled. Did you remember to configure with " + ++ "\'--enable-tests\'?" + + testsToRun <- case testNames of + [] -> return $ zip enabledTests $ repeat Nothing + names -> flip mapM names $ \tName -> + let testMap = zip enabledNames enabledTests + enabledNames = map PD.testName enabledTests + allNames = map PD.testName pkgTests + in case lookup tName testMap of + Just t -> return (t, Nothing) + _ | tName `elem` allNames -> + die $ "Package configured with test suite " + ++ tName ++ " disabled." + | otherwise -> die $ "no such test: " ++ tName + + createDirectoryIfMissing True testLogDir + + -- Delete ordinary files from test log directory. + getDirectoryContents testLogDir + >>= filterM doesFileExist . map (testLogDir ) + >>= mapM_ removeFile + + let totalSuites = length testsToRun + notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." + suites <- mapM doTest testsToRun + let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites } + packageLogFile = () testLogDir + $ packageLogPath machineTemplate pkg_descr lbi + allOk <- summarizePackage verbosity packageLog + writeFile packageLogFile $ show packageLog + + let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi + when isCoverageEnabled $ + markupPackage verbosity lbi distPref (display $ PD.package pkg_descr) $ + map fst testsToRun + + unless allOk exitFailure + +packageLogPath :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> FilePath +packageLogPath template pkg_descr lbi = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (LBI.pkgKey lbi) + (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) diff --git a/Distribution/Simple/Test/ExeV10.hs b/Distribution/Simple/Test/ExeV10.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Test/ExeV10.hs @@ -0,0 +1,168 @@ +module Distribution.Simple.Test.ExeV10 + ( runTest + ) where + +import Distribution.Compat.CreatePipe ( createPipe ) +import Distribution.Compat.Environment ( getEnvironment ) +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.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.TestSuite +import Distribution.Text +import Distribution.Verbosity ( normal ) + +import Control.Concurrent (forkIO) +import Control.Monad ( unless, void, when ) +import System.Directory + ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist + , getCurrentDirectory, removeDirectoryRecursive ) +import System.Exit ( ExitCode(..) ) +import System.FilePath ( (), (<.>) ) +import System.IO ( hGetContents, hPutStr, stdout ) + +runTest :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> TestFlags + -> PD.TestSuite + -> IO TestSuiteLog +runTest pkg_descr lbi flags suite = do + let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi + way = guessWay lbi + tixDir_ = tixDir distPref way $ PD.testName suite + + pwd <- getCurrentDirectory + existingEnv <- getEnvironment + + let cmd = LBI.buildDir lbi PD.testName suite + PD.testName suite <.> exeExtension + -- Check that the test executable exists. + exists <- doesFileExist cmd + unless exists $ die $ "Error: Could not find test program \"" ++ cmd + ++ "\". Did you build the package first?" + + -- Remove old .tix files if appropriate. + unless (fromFlag $ testKeepTix flags) $ do + exists' <- doesDirectoryExist tixDir_ + when exists' $ removeDirectoryRecursive tixDir_ + + -- Create directory for HPC files. + createDirectoryIfMissing True tixDir_ + + -- Write summary notices indicating start of test suite + notice verbosity $ summarizeSuiteStart $ PD.testName suite + + (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 () + + -- '--show-details=streaming': print the log output in another thread + when (details == Streaming) $ void $ forkIO $ hPutStr stdout logText + + -- Run the test executable + 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) + : existingEnv + shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv + + -- Add (DY)LD_LIBRARY_PATH if needed + shellEnv' <- if LBI.withDynExe lbi + then do let (Platform _ os) = LBI.hostPlatform lbi + clbi = LBI.getComponentLocalBuildInfo lbi + (LBI.CTestName (PD.testName suite)) + paths <- LBI.depLibraryPaths True False lbi clbi + return (addLibraryPath os paths shellEnv) + else return shellEnv + + exit <- rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv') + -- these handles are automatically closed + Nothing (Just wOut) (Just wOut) + + -- Generate TestSuiteLog from executable exit code and a machine- + -- readable test log. + let suiteLog = buildLog exit + + -- 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 + appendFile (logFile suiteLog) logText + + -- Write end-of-suite summary notice to log file + appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog + + -- Show the contents of the human-readable log file on the terminal + -- if there is a failure and/or detailed output is requested + let whenPrinting = when $ + (details > Never) + && (not (suitePassed $ testLogs suiteLog) || details == Always) + -- 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 + notice verbosity $ summarizeSuiteFinish suiteLog + + when isCoverageEnabled $ + markupTest verbosity lbi distPref (display $ PD.package pkg_descr) suite + + return suiteLog + where + distPref = fromFlag $ testDistPref flags + verbosity = fromFlag $ testVerbosity flags + details = fromFlag $ testShowDetails flags + testLogDir = distPref "test" + + buildLog exit = + let r = case exit of + ExitSuccess -> Pass + ExitFailure c -> Fail $ "exit code: " ++ show c + n = PD.testName suite + l = TestLog + { testName = n + , testOptionsReturned = [] + , testResult = r + } + in TestSuiteLog + { testSuiteName = n + , testLogs = l + , logFile = + testLogDir + testSuiteLogPath (fromFlag $ testHumanLog flags) + pkg_descr lbi n l + } + +-- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't +-- necessarily a path. +testOption :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.TestSuite + -> PathTemplate + -> String +testOption pkg_descr lbi suite template = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (LBI.pkgKey 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 new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Test/LibV09.hs @@ -0,0 +1,258 @@ +module Distribution.Simple.Test.LibV09 + ( runTest + -- Test stub + , simpleTestStub + , stubFilePath, stubMain, stubName, stubWriteLog + , writeSimpleTestStub + ) where + +import Distribution.Compat.CreatePipe ( createPipe ) +import Distribution.Compat.Environment ( getEnvironment ) +import Distribution.Compat.TempFile ( openTempFile ) +import Distribution.ModuleName ( 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.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.TestSuite +import Distribution.Text +import Distribution.Verbosity ( normal ) + +import Control.Exception ( bracket ) +import Control.Monad ( when, unless ) +import Data.Maybe ( mapMaybe ) +import System.Directory + ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist + , getCurrentDirectory, removeDirectoryRecursive, removeFile + , setCurrentDirectory ) +import System.Exit ( ExitCode(..), exitWith ) +import System.FilePath ( (), (<.>) ) +import System.IO ( hClose, hGetContents, hPutStr ) + +runTest :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> TestFlags + -> PD.TestSuite + -> IO TestSuiteLog +runTest pkg_descr lbi flags suite = do + let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi + way = guessWay lbi + + pwd <- getCurrentDirectory + existingEnv <- getEnvironment + + let cmd = LBI.buildDir lbi stubName suite + stubName suite <.> exeExtension + -- Check that the test executable exists. + exists <- doesFileExist cmd + unless exists $ die $ "Error: Could not find test program \"" ++ cmd + ++ "\". Did you build the package first?" + + -- Remove old .tix files if appropriate. + unless (fromFlag $ testKeepTix flags) $ do + let tDir = tixDir distPref way $ PD.testName suite + exists' <- doesDirectoryExist tDir + when exists' $ removeDirectoryRecursive tDir + + -- Create directory for HPC files. + createDirectoryIfMissing True $ tixDir distPref way $ PD.testName suite + + -- Write summary notices indicating start of test suite + notice verbosity $ summarizeSuiteStart $ PD.testName suite + + 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 + dataDirPath = pwd PD.dataDir pkg_descr + tixFile = pwd tixFilePath distPref way (PD.testName suite) + pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) + : existingEnv + shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] + ++ pkgPathEnv + -- Add (DY)LD_LIBRARY_PATH if needed + shellEnv' <- if LBI.withDynExe lbi + then do + let (Platform _ os) = LBI.hostPlatform lbi + clbi = LBI.getComponentLocalBuildInfo + lbi + (LBI.CTestName + (PD.testName suite)) + paths <- LBI.depLibraryPaths + 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) + + -- Generate final log file name + let finalLogName l = testLogDir + testSuiteLogPath + (fromFlag $ testHumanLog flags) pkg_descr lbi + (testSuiteName l) (testLogs l) + -- Generate TestSuiteLog from executable exit code and a machine- + -- readable test log + suiteLog <- fmap ((\l -> l { logFile = finalLogName l }) . read) + $ readFile tempLog + + -- 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 + appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog + + -- Show the contents of the human-readable log file on the terminal + -- if there is a failure and/or detailed output is requested + let details = fromFlag $ testShowDetails flags + whenPrinting = when $ (details > Never) + && (not (suitePassed $ testLogs suiteLog) || details == Always) + && verbosity >= normal + whenPrinting $ putStr $ unlines $ lines logText + + return suiteLog + + -- Write summary notice to terminal indicating end of test suite + notice verbosity $ summarizeSuiteFinish suiteLog + + when isCoverageEnabled $ + markupTest verbosity lbi distPref (display $ PD.package pkg_descr) suite + + return suiteLog + where + deleteIfExists file = do + exists <- doesFileExist file + when exists $ removeFile file + + testLogDir = distPref "test" + openCabalTemp = do + (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log" + hClose h >> return f + + distPref = fromFlag $ testDistPref flags + verbosity = fromFlag $ testVerbosity flags + +-- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't +-- necessarily a path. +testOption :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.TestSuite + -> PathTemplate + -> String +testOption pkg_descr lbi suite template = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (LBI.pkgKey lbi) + (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ + [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)] + +-- Test stub ---------- + +-- | The name of the stub executable associated with a library 'TestSuite'. +stubName :: PD.TestSuite -> FilePath +stubName t = PD.testName t ++ "Stub" + +-- | The filename of the source file for the stub executable associated with a +-- library 'TestSuite'. +stubFilePath :: PD.TestSuite -> FilePath +stubFilePath t = stubName t <.> "hs" + +-- | Write the source file for a library 'TestSuite' stub executable. +writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub + -- is being created + -> FilePath -- ^ path to directory where stub source + -- should be located + -> IO () +writeSimpleTestStub t dir = do + createDirectoryIfMissing True dir + let filename = dir stubFilePath t + PD.TestSuiteLibV09 _ m = PD.testInterface t + writeFile filename $ simpleTestStub m + +-- | Source code for library test suite stub executable +simpleTestStub :: ModuleName -> String +simpleTestStub m = unlines + [ "module Main ( main ) where" + , "import Distribution.Simple.Test.LibV09 ( stubMain )" + , "import " ++ show (disp m) ++ " ( tests )" + , "main :: IO ()" + , "main = stubMain tests" + ] + +-- | Main function for test stubs. Once, it was written directly into the stub, +-- but minimizing the amount of code actually in the stub maximizes the number +-- of detectable errors when Cabal is compiled. +stubMain :: IO [Test] -> IO () +stubMain tests = do + (f, n) <- fmap read getContents + dir <- getCurrentDirectory + results <- tests >>= stubRunTests + setCurrentDirectory dir + stubWriteLog f n results + +-- | The test runner used in library "TestSuite" stub executables. Runs a list +-- of 'Test's. An executable calling this function is meant to be invoked as +-- the child of a Cabal process during @.\/setup test@. A 'TestSuiteLog', +-- provided by Cabal, is read from the standard input; it supplies the name of +-- the test suite and the location of the machine-readable test suite log file. +-- Human-readable log information is written to the standard output for capture +-- by the calling Cabal process. +stubRunTests :: [Test] -> IO TestLogs +stubRunTests tests = do + logs <- mapM stubRunTests' tests + return $ GroupLogs "Default" logs + where + stubRunTests' (Test t) = do + l <- run t >>= finish + summarizeTest normal Always l + return l + where + finish (Finished result) = + return TestLog + { testName = name t + , testOptionsReturned = defaultOptions t + , testResult = result + } + finish (Progress _ next) = next >>= finish + stubRunTests' g@(Group {}) = do + logs <- mapM stubRunTests' $ groupTests g + return $ GroupLogs (groupName g) logs + stubRunTests' (ExtraOptions _ t) = stubRunTests' t + maybeDefaultOption opt = + maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt + defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst + +-- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling +-- Cabal process to read. +stubWriteLog :: FilePath -> String -> TestLogs -> IO () +stubWriteLog f n logs = do + let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f } + writeFile (logFile testLog) $ show testLog + when (suiteError logs) $ exitWith $ ExitFailure 2 + when (suiteFailed logs) $ exitWith $ ExitFailure 1 + exitWith ExitSuccess diff --git a/Distribution/Simple/Test/Log.hs b/Distribution/Simple/Test/Log.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Test/Log.hs @@ -0,0 +1,161 @@ +module Distribution.Simple.Test.Log + ( PackageLog(..) + , TestLogs(..) + , TestSuiteLog(..) + , countTestResults + , localPackageLog + , summarizePackage + , summarizeSuiteFinish, summarizeSuiteStart + , summarizeTest + , suiteError, suiteFailed, suitePassed + , testSuiteLogPath + ) where + +import Distribution.Package ( PackageId ) +import qualified Distribution.PackageDescription as PD +import Distribution.Simple.Compiler ( Compiler(..), compilerInfo, CompilerId ) +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 Control.Monad ( when ) +import Data.Char ( toUpper ) + +-- | Logs all test results for a package, broken down first by test suite and +-- then by test case. +data PackageLog = PackageLog + { package :: PackageId + , compiler :: CompilerId + , platform :: Platform + , testSuites :: [TestSuiteLog] + } + deriving (Read, Show, Eq) + +-- | A 'PackageLog' with package and platform information specified. +localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog +localPackageLog pkg_descr lbi = PackageLog + { package = PD.package pkg_descr + , compiler = compilerId $ LBI.compiler lbi + , platform = LBI.hostPlatform lbi + , testSuites = [] + } + +-- | Logs test suite results, itemized by test case. +data TestSuiteLog = TestSuiteLog + { testSuiteName :: String + , testLogs :: TestLogs + , logFile :: FilePath -- path to human-readable log file + } + deriving (Read, Show, Eq) + +data TestLogs + = TestLog + { testName :: String + , testOptionsReturned :: Options + , testResult :: Result + } + | GroupLogs String [TestLogs] + deriving (Read, Show, Eq) + +-- | Count the number of pass, fail, and error test results in a 'TestLogs' +-- tree. +countTestResults :: TestLogs + -> (Int, Int, Int) -- ^ Passes, fails, and errors, + -- respectively. +countTestResults = go (0, 0, 0) + where + go (p, f, e) (TestLog { testResult = r }) = + case r of + Pass -> (p + 1, f, e) + Fail _ -> (p, f + 1, e) + Error _ -> (p, f, e + 1) + go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts + +-- | From a 'TestSuiteLog', determine if the test suite passed. +suitePassed :: TestLogs -> Bool +suitePassed l = + case countTestResults l of + (_, 0, 0) -> True + _ -> False + +-- | From a 'TestSuiteLog', determine if the test suite failed. +suiteFailed :: TestLogs -> Bool +suiteFailed l = + case countTestResults l of + (_, 0, _) -> False + _ -> True + +-- | From a 'TestSuiteLog', determine if the test suite encountered errors. +suiteError :: TestLogs -> Bool +suiteError l = + case countTestResults l of + (_, _, 0) -> False + _ -> True + +resultString :: TestLogs -> String +resultString l | suiteError l = "error" + | suiteFailed l = "fail" + | otherwise = "pass" + +testSuiteLogPath :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> String -- ^ test suite name + -> TestLogs -- ^ test suite results + -> FilePath +testSuiteLogPath template pkg_descr lbi name result = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (LBI.pkgKey lbi) + (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) + ++ [ (TestSuiteNameVar, toPathTemplate name) + , (TestSuiteResultVar, toPathTemplate $ resultString result) + ] + +-- | Print a summary to the console after all test suites have been run +-- indicating the number of successful test suites and cases. Returns 'True' if +-- all test suites passed and 'False' otherwise. +summarizePackage :: Verbosity -> PackageLog -> IO Bool +summarizePackage verbosity packageLog = do + let counts = map (countTestResults . testLogs) $ testSuites packageLog + (passed, failed, errors) = foldl1 addTriple counts + totalCases = passed + failed + errors + passedSuites = length + $ filter (suitePassed . testLogs) + $ testSuites packageLog + totalSuites = length $ testSuites packageLog + notice verbosity $ show passedSuites ++ " of " ++ show totalSuites + ++ " test suites (" ++ show passed ++ " of " + ++ show totalCases ++ " test cases) passed." + return $! passedSuites == totalSuites + where + addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2) + +-- | Print a summary of a single test case's result to the console, supressing +-- output for certain verbosity or test filter levels. +summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO () +summarizeTest _ _ (GroupLogs {}) = return () +summarizeTest verbosity details t = + when shouldPrint $ notice verbosity $ "Test case " ++ testName t + ++ ": " ++ show (testResult t) + where shouldPrint = (details > Never) && (notPassed || details == Always) + notPassed = testResult t /= Pass + +-- | Print a summary of the test suite's results on the console, suppressing +-- output for certain verbosity or test filter levels. +summarizeSuiteFinish :: TestSuiteLog -> String +summarizeSuiteFinish testLog = unlines + [ "Test suite " ++ testSuiteName testLog ++ ": " ++ resStr + , "Test suite logged to: " ++ logFile testLog + ] + where resStr = map toUpper (resultString $ testLogs testLog) + +summarizeSuiteStart :: String -> String +summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n" diff --git a/Distribution/Simple/UHC.hs b/Distribution/Simple/UHC.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/UHC.hs @@ -0,0 +1,276 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.UHC +-- Copyright : Andres Loeh 2009 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains most of the UHC-specific code for configuring, building +-- and installing packages. +-- +-- Thanks to the authors of the other implementation-specific files, in +-- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for +-- inspiration on how to design this module. + +module Distribution.Simple.UHC ( + configure, getInstalledPackages, + buildLib, buildExe, installLib, registerPackage + ) 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.PackageDescription +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler as C +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Text +import Distribution.Verbosity +import Distribution.Version +import Language.Haskell.Extension +import System.Directory +import System.FilePath +import Distribution.System ( Platform ) + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (_uhcProg, uhcVersion, conf') <- + requireProgramVersion verbosity uhcProgram + (orLaterVersion (Version [1,0,2] [])) + (userMaybeSpecifyPath "uhc" hcPath conf) + + let comp = Compiler { + compilerId = CompilerId UHC uhcVersion, + compilerAbiTag = C.NoAbiTag, + compilerCompat = [], + compilerLanguages = uhcLanguages, + compilerExtensions = uhcLanguageExtensions, + compilerProperties = M.empty + } + compPlatform = Nothing + return (comp, compPlatform, conf') + +uhcLanguages :: [(Language, C.Flag)] +uhcLanguages = [(Haskell98, "")] + +-- | The flags for the supported extensions. +uhcLanguageExtensions :: [(Extension, C.Flag)] +uhcLanguageExtensions = + let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), + (DisableExtension f, disable)] + alwaysOn = ("", ""{- wrong -}) + in concatMap doFlag + [(CPP, ("--cpp", ""{- wrong -})), + (PolymorphicComponents, alwaysOn), + (ExistentialQuantification, alwaysOn), + (ForeignFunctionInterface, alwaysOn), + (UndecidableInstances, alwaysOn), + (MultiParamTypeClasses, alwaysOn), + (Rank2Types, alwaysOn), + (PatternSignatures, alwaysOn), + (EmptyDataDecls, alwaysOn), + (ImplicitPrelude, ("", "--no-prelude"{- wrong -})), + (TypeOperators, alwaysOn), + (OverlappingInstances, alwaysOn), + (FlexibleInstances, alwaysOn)] + +getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp packagedbs conf = do + let compilerid = compilerId comp + systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram conf ["--meta-pkgdir-system"] + userPkgDir <- getUserPackageDir + let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) + -- putStrLn $ "pkgdirs: " ++ show pkgDirs + -- call to "lines" necessary, because pkgdir contains an extra newline at the end + pkgs <- liftM (map addBuiltinVersions . concat) . + mapM (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d)) . + concatMap lines $ pkgDirs + -- putStrLn $ "pkgs: " ++ show pkgs + let iPkgs = + map mkInstalledPackageInfo $ + concatMap parsePackage $ + pkgs + -- putStrLn $ "installed pkgs: " ++ show iPkgs + return (fromList iPkgs) + +getUserPackageDir :: IO FilePath +getUserPackageDir = + do + homeDir <- getHomeDirectory + return $ homeDir ".cabal" "lib" -- TODO: determine in some other way + +packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] +packageDbPaths user system db = + case db of + GlobalPackageDB -> [ system ] + UserPackageDB -> [ user ] + SpecificPackageDB path -> [ path ] + +-- | Hack to add version numbers to UHC-built-in packages. This should sooner or +-- later be fixed on the UHC side. +addBuiltinVersions :: String -> String +{- +addBuiltinVersions "uhcbase" = "uhcbase-1.0" +addBuiltinVersions "base" = "base-3.0" +addBuiltinVersions "array" = "array-0.2" +-} +addBuiltinVersions xs = xs + +-- | Name of the installed package config file. +installedPkgConfig :: String +installedPkgConfig = "installed-pkg-config" + +-- | Check if a certain dir contains a valid package. Currently, we are +-- looking only for the presence of an installed package configuration. +-- TODO: Actually make use of the information provided in the file. +isPkgDir :: String -> String -> String -> IO Bool +isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . +isPkgDir c dir xs = do + let candidate = dir uhcPackageDir xs c + -- putStrLn $ "trying: " ++ candidate + doesFileExist (candidate installedPkgConfig) + +parsePackage :: String -> [PackageId] +parsePackage x = map fst (filter (\ (_,y) -> null y) (readP_to_S parse x)) + +-- | Create a trivial package info from a directory name. +mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo +mkInstalledPackageInfo p = emptyInstalledPackageInfo + { installedPackageId = InstalledPackageId (display p), + sourcePackageId = p } + + +-- ----------------------------------------------------------------------------- +-- Building + +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + + systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] + userPkgDir <- getUserPackageDir + let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) + let uhcArgs = -- set package name + ["--pkg-build=" ++ display (packageId pkg_descr)] + -- common flags lib/exe + ++ constructUHCCmdLine userPkgDir systemPkgDir + lbi (libBuildInfo lib) clbi + (buildDir lbi) verbosity + -- source files + -- suboptimal: UHC does not understand module names, so + -- we replace periods by path separators + ++ map (map (\ c -> if c == '.' then pathSeparator else c)) + (map display (libModules lib)) + + runUhcProg uhcArgs + + return () + +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi exe clbi = do + systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] + userPkgDir <- getUserPackageDir + let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) + let uhcArgs = -- common flags lib/exe + constructUHCCmdLine userPkgDir systemPkgDir + lbi (buildInfo exe) clbi + (buildDir lbi) verbosity + -- output file + ++ ["--output", buildDir lbi exeName exe] + -- main source module + ++ [modulePath exe] + runUhcProg uhcArgs + +constructUHCCmdLine :: FilePath -> FilePath + -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> Verbosity -> [String] +constructUHCCmdLine user system lbi bi clbi odir verbosity = + -- verbosity + (if verbosity >= deafening then ["-v4"] + else if verbosity >= normal then [] + else ["-v0"]) + ++ hcOptions UHC bi + -- flags for language extensions + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + -- packages + ++ ["--hide-all-packages"] + ++ uhcPackageDbOptions user system (withPackageDB lbi) + ++ ["--package=uhcbase"] + ++ ["--package=" ++ display (pkgName pkgid) | (_, pkgid) <- componentPackageDeps clbi ] + -- search paths + ++ ["-i" ++ odir] + ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ autogenModulesDir lbi] + -- cpp options + ++ ["--optP=" ++ opt | opt <- cppOptions bi] + -- output path + ++ ["--odir=" ++ odir] + -- optimization + ++ (case withOptimization lbi of + NoOptimisation -> ["-O0"] + NormalOptimisation -> ["-O1"] + MaximumOptimisation -> ["-O2"]) + +uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] +uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x) + (concatMap (packageDbPaths user system) db) + +-- ----------------------------------------------------------------------------- +-- Installation + +installLib :: Verbosity -> LocalBuildInfo + -> FilePath -> FilePath -> FilePath + -> PackageDescription -> Library -> IO () +installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library = do + -- putStrLn $ "dest: " ++ targetDir + -- putStrLn $ "built: " ++ builtDir + installDirectoryContents verbosity (builtDir display (packageId pkg)) targetDir + +-- currently hard-coded UHC code generator and variant to use +uhcTarget, uhcTargetVariant :: String +uhcTarget = "bc" +uhcTargetVariant = "plain" + +-- root directory for a package in UHC +uhcPackageDir :: String -> String -> FilePath +uhcPackageSubDir :: String -> FilePath +uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid +uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do + let installDirs = absoluteInstallDirs pkg lbi NoCopyDest + pkgdir | inplace = buildDir lbi uhcPackageDir (display pkgid) (display compilerid) + | otherwise = libdir installDirs uhcPackageSubDir (display compilerid) + createDirectoryIfMissingVerbose verbosity True pkgdir + writeUTF8File (pkgdir installedPkgConfig) + (showInstalledPackageInfo installedPkgInfo) + where + pkgid = packageId pkg + compilerid = compilerId (compiler lbi) diff --git a/Distribution/Simple/UserHooks.hs b/Distribution/Simple/UserHooks.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/UserHooks.hs @@ -0,0 +1,211 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.UserHooks +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines the API that @Setup.hs@ scripts can use to customise the way +-- the build works. This module just defines the 'UserHooks' type. The +-- predefined sets of hooks that implement the @Simple@, @Make@ and @Configure@ +-- build systems are defined in "Distribution.Simple". The 'UserHooks' is a big +-- record of functions. There are 3 for each action, a pre, post and the action +-- itself. There are few other miscellaneous hooks, ones to extend the set of +-- programs and preprocessors and one to override the function used to read the +-- @.cabal@ file. +-- +-- This hooks type is widely agreed to not be the right solution. Partly this +-- is because changes to it usually break custom @Setup.hs@ files and yet many +-- internal code changes do require changes to the hooks. For example we cannot +-- pass any extra parameters to most of the functions that implement the +-- various phases because it would involve changing the types of the +-- corresponding hook. At some point it will have to be replaced. + +module Distribution.Simple.UserHooks ( + UserHooks(..), Args, + emptyUserHooks, + ) where + +import Distribution.PackageDescription + (PackageDescription, GenericPackageDescription, + HookedBuildInfo, emptyHookedBuildInfo) +import Distribution.Simple.Program (Program) +import Distribution.Simple.Command (noExtraFlags) +import Distribution.Simple.PreProcess (PPSuffixHandler) +import Distribution.Simple.Setup + (ConfigFlags, BuildFlags, ReplFlags, CleanFlags, CopyFlags, + InstallFlags, SDistFlags, RegisterFlags, HscolourFlags, + HaddockFlags, TestFlags, BenchmarkFlags) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) + +type Args = [String] + +-- | Hooks allow authors to add specific functionality before and after a +-- command is run, and also to specify additional preprocessors. +-- +-- * WARNING: The hooks interface is under rather constant flux as we try to +-- understand users needs. Setup files that depend on this interface may +-- break in future releases. +data UserHooks = UserHooks { + + -- | Used for @.\/setup test@ + runTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO (), + -- | Read the description file + readDesc :: IO (Maybe GenericPackageDescription), + -- | Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. + hookedPreProcessors :: [ PPSuffixHandler ], + -- | These programs are detected at configure time. Arguments for them are + -- added to the configure command. + hookedPrograms :: [Program], + + -- |Hook to run before configure command + preConf :: Args -> ConfigFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during configure. + confHook :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags -> IO LocalBuildInfo, + -- |Hook to run after configure command + postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before build command. Second arg indicates verbosity level. + preBuild :: Args -> BuildFlags -> IO HookedBuildInfo, + + -- |Over-ride this hook to get different behavior during build. + buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (), + -- |Hook to run after build command. Second arg indicates verbosity level. + postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before repl command. Second arg indicates verbosity level. + preRepl :: Args -> ReplFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during interpretation. + replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO (), + -- |Hook to run after repl command. Second arg indicates verbosity level. + postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before clean command. Second arg indicates verbosity level. + preClean :: Args -> CleanFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during clean. + cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO (), + -- |Hook to run after clean command. Second arg indicates verbosity level. + postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO (), + + -- |Hook to run before copy command + preCopy :: Args -> CopyFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during copy. + copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (), + -- |Hook to run after copy command + postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before install command + preInst :: Args -> InstallFlags -> IO HookedBuildInfo, + + -- |Over-ride this hook to get different behavior during install. + instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (), + -- |Hook to run after install command. postInst should be run + -- on the target, not on the build machine. + postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before sdist command. Second arg indicates verbosity level. + preSDist :: Args -> SDistFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during sdist. + sDistHook :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO (), + -- |Hook to run after sdist command. Second arg indicates verbosity level. + postSDist :: Args -> SDistFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO (), + + -- |Hook to run before register command + preReg :: Args -> RegisterFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during registration. + regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), + -- |Hook to run after register command + postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before unregister command + preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during unregistration. + unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), + -- |Hook to run after unregister command + postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before hscolour command. Second arg indicates verbosity level. + preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during hscolour. + hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (), + -- |Hook to run after hscolour command. Second arg indicates verbosity level. + postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before haddock command. Second arg indicates verbosity level. + preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during haddock. + haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (), + -- |Hook to run after haddock command. Second arg indicates verbosity level. + postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before test command. + preTest :: Args -> TestFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during test. + testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (), + -- |Hook to run after test command. + postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before bench command. + preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during bench. + benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO (), + -- |Hook to run after bench command. + postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO () + } + +{-# DEPRECATED runTests "Please use the new testing interface instead!" #-} + +-- |Empty 'UserHooks' which do nothing. +emptyUserHooks :: UserHooks +emptyUserHooks + = UserHooks { + runTests = ru, + readDesc = return Nothing, + hookedPreProcessors = [], + hookedPrograms = [], + preConf = rn, + confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")), + postConf = ru, + preBuild = rn', + buildHook = ru, + postBuild = ru, + preRepl = \_ _ -> return emptyHookedBuildInfo, + replHook = \_ _ _ _ _ -> return (), + postRepl = ru, + preClean = rn, + cleanHook = ru, + postClean = ru, + preCopy = rn, + copyHook = ru, + postCopy = ru, + preInst = rn, + instHook = ru, + postInst = ru, + preSDist = rn, + sDistHook = ru, + postSDist = ru, + preReg = rn, + regHook = ru, + postReg = ru, + preUnreg = rn, + unregHook = ru, + postUnreg = ru, + preHscolour = rn, + hscolourHook = ru, + postHscolour = ru, + preHaddock = rn, + haddockHook = ru, + postHaddock = ru, + preTest = rn', + testHook = \_ -> ru, + postTest = ru, + preBench = rn', + benchHook = \_ -> ru, + postBench = ru + } + where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo + rn' _ _ = return emptyHookedBuildInfo + ru _ _ _ _ = return () diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Utils.hs @@ -0,0 +1,1370 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Utils +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- License : BSD3 +-- portions Copyright (c) 2007, Galois Inc. +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A large and somewhat miscellaneous collection of utility functions used +-- throughout the rest of the Cabal lib and in other tools that use the Cabal +-- lib like @cabal-install@. It has a very simple set of logging actions. It +-- has low level functions for running programs, a bunch of wrappers for +-- various directory and file functions that do extra logging. + +module Distribution.Simple.Utils ( + cabalVersion, + + -- * logging and errors + die, + dieWithLocation, + topHandler, topHandlerWith, + warn, notice, setupMessage, info, debug, + debugNoWrap, chattyTry, + printRawCommandAndArgs, printRawCommandAndArgsAndEnv, + + -- * running programs + rawSystemExit, + rawSystemExitCode, + rawSystemExitWithEnv, + rawSystemStdout, + rawSystemStdInOut, + rawSystemIOWithEnv, + maybeExit, + xargs, + findProgramLocation, + findProgramVersion, + + -- * copying files + smartCopySources, + createDirectoryIfMissingVerbose, + copyFileVerbose, + copyDirectoryRecursiveVerbose, + copyFiles, + copyFileTo, + + -- * installing files + installOrdinaryFile, + installExecutableFile, + installMaybeExecutableFile, + installOrdinaryFiles, + installExecutableFiles, + installMaybeExecutableFiles, + installDirectoryContents, + copyDirectoryRecursive, + + -- * File permissions + doesExecutableExist, + setFileOrdinary, + setFileExecutable, + + -- * file names + currentDir, + shortRelativePath, + + -- * finding files + findFile, + findFirstFile, + findFileWithExtension, + findFileWithExtension', + findModuleFile, + findModuleFiles, + getDirectoryContentsRecursive, + + -- * environment variables + isInSearchPath, + addLibraryPath, + + -- * simple file globbing + matchFileGlob, + matchDirFileGlob, + parseFileGlob, + FileGlob(..), + + -- * modification time + moreRecentFile, + existsAndIsMoreRecentThan, + + -- * temp files and dirs + TempFileOptions(..), defaultTempFileOptions, + withTempFile, withTempFileEx, + withTempDirectory, withTempDirectoryEx, + + -- * .cabal and .buildinfo files + defaultPackageDesc, + findPackageDesc, + tryFindPackageDesc, + defaultHookedPackageDesc, + findHookedPackageDesc, + + -- * reading and writing files safely + withFileContents, + writeFileAtomic, + rewriteFile, + + -- * Unicode + fromUTF8, + toUTF8, + readUTF8File, + withUTF8FileContents, + writeUTF8File, + normaliseLineEndings, + + -- * generic utils + dropWhileEndLE, + takeWhileEndLE, + equating, + comparing, + isInfixOf, + intercalate, + lowercase, + listUnion, + listUnionRight, + ordNub, + ordNubRight, + wrapText, + wrapLine, + ) where + +import Control.Monad + ( join, 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 qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import qualified Data.Set as Set + +import System.Directory + ( Permissions(executable), getDirectoryContents, getPermissions + , doesDirectoryExist, doesFileExist, removeFile, findExecutable + , getModificationTime ) +import System.Environment + ( getProgName ) +import System.Exit + ( exitWith, ExitCode(..) ) +import System.FilePath + ( normalise, (), (<.>) + , getSearchPath, joinPath, takeDirectory, splitFileName + , splitExtension, splitExtensions, splitDirectories + , searchPathSeparator ) +import System.Directory + ( createDirectory, renameFile, removeDirectoryRecursive ) +import System.IO + ( Handle, openFile, openBinaryFile, openBinaryTempFileWithDefaultPermissions + , IOMode(ReadMode), hSetBinaryMode + , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) +import System.IO.Error as IO.Error + ( isDoesNotExistError, isAlreadyExistsError + , ioeSetFileName, ioeGetFileName, ioeGetErrorString ) +import System.IO.Error + ( ioeSetLocation, ioeGetLocation ) +import System.IO.Unsafe + ( unsafeInterleaveIO ) +import qualified Control.Exception as Exception + +import Distribution.Text + ( display, simpleParse ) +import Distribution.Package + ( PackageIdentifier ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.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 + , 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_ide_backend (version) +#endif + +-- We only get our own version number when we're building with ourselves +cabalVersion :: Version +#if defined(VERSION_base) +cabalVersion = Paths_Cabal_ide_backend.version +#elif defined(CABAL_VERSION) +cabalVersion = Version [CABAL_VERSION] [] +#else +cabalVersion = Version [1,9999] [] --used when bootstrapping +#endif + +-- ---------------------------------------------------------------------------- +-- Exception and logging utils + +dieWithLocation :: FilePath -> Maybe Int -> String -> IO a +dieWithLocation filename lineno msg = + ioError . setLocation lineno + . flip ioeSetFileName (normalise filename) + $ userError msg + where + setLocation Nothing err = err + setLocation (Just n) err = ioeSetLocation err (show n) + +die :: String -> IO a +die msg = ioError (userError msg) + +topHandlerWith :: (Exception.IOException -> IO a) -> IO a -> IO a +topHandlerWith cont prog = catchIO prog handle + where + handle ioe = do + hFlush stdout + pname <- getProgName + hPutStr stderr (mesage pname) + 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 + +topHandler :: IO a -> IO a +topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog + +-- | Non fatal conditions that may be indicative of an error or problem. +-- +-- We display these at the 'normal' verbosity level. +-- +warn :: Verbosity -> String -> IO () +warn verbosity msg = + when (verbosity >= normal) $ do + hFlush stdout + hPutStr stderr (wrapText ("Warning: " ++ msg)) + +-- | Useful status messages. +-- +-- We display these at the 'normal' verbosity level. +-- +-- This is for the ordinary helpful status messages that users see. Just +-- enough information to know that things are working but not floods of detail. +-- +notice :: Verbosity -> String -> IO () +notice verbosity msg = + when (verbosity >= normal) $ + putStr (wrapText msg) + +setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () +setupMessage verbosity msg pkgid = + notice verbosity (msg ++ ' ': display pkgid ++ "...") + +-- | More detail on the operation of some action. +-- +-- We display these messages when the verbosity level is 'verbose' +-- +info :: Verbosity -> String -> IO () +info verbosity msg = + when (verbosity >= verbose) $ + putStr (wrapText msg) + +-- | Detailed internal debugging information +-- +-- We display these messages when the verbosity level is 'deafening' +-- +debug :: Verbosity -> String -> IO () +debug verbosity msg = + when (verbosity >= deafening) $ do + putStr (wrapText msg) + hFlush stdout + +-- | A variant of 'debug' that doesn't perform the automatic line +-- wrapping. Produces better output in some cases. +debugNoWrap :: Verbosity -> String -> IO () +debugNoWrap verbosity msg = + when (verbosity >= deafening) $ do + putStrLn msg + hFlush stdout + +-- | Perform an IO action, catching any IO exceptions and printing an error +-- if one occurs. +chattyTry :: String -- ^ a description of the action we were attempting + -> IO () -- ^ the action itself + -> IO () +chattyTry desc action = + catchIO action $ \exception -> + putStrLn $ "Error while " ++ desc ++ ": " ++ show exception + +-- ----------------------------------------------------------------------------- +-- Helper functions + +-- | Wraps text to the default line width. Existing newlines are preserved. +wrapText :: String -> String +wrapText = unlines + . map (intercalate "\n" + . map unwords + . wrapLine 79 + . words) + . lines + +-- | Wraps a list of words to a list of lines of words of a particular width. +wrapLine :: Int -> [String] -> [[String]] +wrapLine width = wrap 0 [] + where wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w:ws) + | length w + 1 > width + = wrap (length w) [w] ws + wrap col line (w:ws) + | col + length w + 1 > width + = reverse line : wrap 0 [] (w:ws) + wrap col line (w:ws) + = let col' = col + length w + 1 + in wrap col' (w:line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +-- ----------------------------------------------------------------------------- +-- rawSystem variants +maybeExit :: IO ExitCode -> IO () +maybeExit cmd = do + res <- cmd + unless (res == ExitSuccess) $ exitWith res + +printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () +printRawCommandAndArgs verbosity path args = + printRawCommandAndArgsAndEnv verbosity path args Nothing + +printRawCommandAndArgsAndEnv :: Verbosity + -> FilePath + -> [String] + -> Maybe [(String, String)] + -> IO () +printRawCommandAndArgsAndEnv verbosity path args menv + | verbosity >= deafening = do + maybe (return ()) (putStrLn . ("Environment: " ++) . show) menv + print (path, args) + | verbosity >= verbose = putStrLn $ showCommandForUser path args + | otherwise = return () + + +-- Exit with the same exit code if the subcommand fails +rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () +rawSystemExit verbosity path args = do + printRawCommandAndArgs verbosity path args + hFlush stdout + exitcode <- rawSystem path args + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + exitWith exitcode + +rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode +rawSystemExitCode verbosity path args = do + printRawCommandAndArgs verbosity path args + hFlush stdout + exitcode <- rawSystem path args + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + return exitcode + +rawSystemExitWithEnv :: Verbosity + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +rawSystemExitWithEnv verbosity path args env = do + printRawCommandAndArgsAndEnv verbosity path args (Just env) + hFlush stdout + (_,_,_,ph) <- createProcess $ + (Process.proc path args) { Process.env = (Just env) +#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 +#endif +#endif + } + exitcode <- waitForProcess ph + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + exitWith exitcode + +-- Closes the passed in handles before returning. +rawSystemIOWithEnv :: Verbosity + -> FilePath + -> [String] + -> Maybe FilePath -- ^ New working dir or inherit + -> Maybe [(String, String)] -- ^ New environment or inherit + -> Maybe Handle -- ^ stdin + -> Maybe Handle -- ^ stdout + -> Maybe Handle -- ^ stderr + -> IO ExitCode +rawSystemIOWithEnv verbosity path args mcwd menv inp out err = do + 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 +#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 +#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 + +-- | Run a command and return its output. +-- +-- The output is assumed to be text in the locale encoding. +-- +rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String +rawSystemStdout verbosity path args = do + (output, errors, exitCode) <- rawSystemStdInOut verbosity path args + Nothing Nothing + Nothing False + when (exitCode /= ExitSuccess) $ + die errors + return output + +-- | Run a command and return its output, errors and exit status. Optionally +-- also supply some input. Also provides control over whether the binary/text +-- mode of the input and output. +-- +rawSystemStdInOut :: Verbosity + -> FilePath -- ^ Program location + -> [String] -- ^ Arguments + -> Maybe FilePath -- ^ New working dir or inherit + -> Maybe [(String, String)] -- ^ New environment or inherit + -> Maybe (String, Bool) -- ^ input text and binary mode + -> Bool -- ^ output in binary mode + -> IO (String, String, ExitCode) -- ^ output, errors, exit +rawSystemStdInOut verbosity path args mcwd menv input outputBinary = do + printRawCommandAndArgs verbosity path args + + Exception.bracket + (runInteractiveProcess path args mcwd menv) + (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) + $ \(inh,outh,errh,pid) -> do + + -- output mode depends on what the caller wants + hSetBinaryMode outh outputBinary + -- but the errors are always assumed to be text (in the current locale) + hSetBinaryMode errh False + + -- fork off a couple threads to pull on the stderr and stdout + -- so if the process writes to stderr we do not block. + + err <- hGetContents errh + out <- hGetContents outh + + mv <- newEmptyMVar + let force str = (evaluate (length str) >> return ()) + `Exception.finally` putMVar mv () + --TODO: handle exceptions like text decoding. + _ <- forkIO $ force out + _ <- forkIO $ force err + + -- push all the input, if any + case input of + Nothing -> return () + Just (inputStr, inputBinary) -> do + -- input mode depends on what the caller wants + hSetBinaryMode inh inputBinary + hPutStr inh inputStr + hClose inh + --TODO: this probably fails if the process refuses to consume + -- or if it closes stdin (eg if it exits) + + -- wait for both to finish, in either order + takeMVar mv + takeMVar mv + + -- wait for the program to terminate + exitcode <- waitForProcess pid + unless (exitcode == ExitSuccess) $ + debug verbosity $ path ++ " returned " ++ show exitcode + ++ if null err then "" else + " with error message:\n" ++ err + ++ case input of + Nothing -> "" + Just ("", _) -> "" + Just (inp, _) -> "\nstdin input:\n" ++ inp + + return (out, err, exitcode) + + +-- | Look for a program on the path. +findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath) +findProgramLocation verbosity prog = do + debug verbosity $ "searching for " ++ prog ++ " in path." + res <- findExecutable prog + case res of + Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") + Just path -> debug verbosity ("found " ++ prog ++ " at "++ path) + return res + + +-- | Look for a program and try to find it's version number. It can accept +-- either an absolute path or the name of a program binary, in which case we +-- will look for the program on the path. +-- +findProgramVersion :: String -- ^ version args + -> (String -> String) -- ^ function to select version + -- number from program output + -> Verbosity + -> FilePath -- ^ location + -> IO (Maybe Version) +findProgramVersion versionArg selectVersion verbosity path = do + str <- rawSystemStdout verbosity path [versionArg] + `catchIO` (\_ -> return "") + `catchExit` (\_ -> return "") + let version :: Maybe Version + version = simpleParse (selectVersion str) + case version of + Nothing -> warn verbosity $ "cannot determine version of " ++ path + ++ " :\n" ++ show str + Just v -> debug verbosity $ path ++ " is version " ++ display v + return version + + +-- | Like the Unix xargs program. Useful for when we've got very long command +-- lines that might overflow an OS limit on command line length and so you +-- need to invoke a command multiple times to get all the args in. +-- +-- Use it with either of the rawSystem variants above. For example: +-- +-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs +-- +xargs :: Int -> ([String] -> IO ()) + -> [String] -> [String] -> IO () +xargs maxSize rawSystemFun fixedArgs bigArgs = + let fixedArgSize = sum (map length fixedArgs) + length fixedArgs + chunkSize = maxSize - fixedArgSize + in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) + + where chunks len = unfoldr $ \s -> + if null s then Nothing + else Just (chunk [] len s) + + chunk acc _ [] = (reverse acc,[]) + chunk acc len (s:ss) + | len' < len = chunk (s:acc) (len-len'-1) ss + | otherwise = (reverse acc, s:ss) + where len' = length s + +-- ------------------------------------------------------------ +-- * File Utilities +-- ------------------------------------------------------------ + +---------------- +-- Finding files + +-- | Find a file by looking in a search path. The file path must match exactly. +-- +findFile :: [FilePath] -- ^search locations + -> FilePath -- ^File Name + -> IO FilePath +findFile searchPath fileName = + findFirstFile id + [ path fileName + | path <- nub searchPath] + >>= maybe (die $ fileName ++ " doesn't exist") return + +-- | Find a file by looking in a search path with one of a list of possible +-- file extensions. The file base name should be given and it will be tried +-- with each of the extensions in each element of the search path. +-- +findFileWithExtension :: [String] + -> [FilePath] + -> FilePath + -> IO (Maybe FilePath) +findFileWithExtension extensions searchPath baseName = + findFirstFile id + [ path baseName <.> ext + | path <- nub searchPath + , ext <- nub extensions ] + +-- | Like 'findFileWithExtension' but returns which element of the search path +-- the file was found in, and the file path relative to that base directory. +-- +findFileWithExtension' :: [String] + -> [FilePath] + -> FilePath + -> IO (Maybe (FilePath, FilePath)) +findFileWithExtension' extensions searchPath baseName = + findFirstFile (uncurry ()) + [ (path, baseName <.> ext) + | path <- nub searchPath + , ext <- nub extensions ] + +findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) +findFirstFile file = findFirst + where findFirst [] = return Nothing + findFirst (x:xs) = do exists <- doesFileExist (file x) + if exists + then return (Just x) + else findFirst xs + +-- | Finds the files corresponding to a list of Haskell module names. +-- +-- As 'findModuleFile' but for a list of module names. +-- +findModuleFiles :: [FilePath] -- ^ build prefix (location of objects) + -> [String] -- ^ search suffixes + -> [ModuleName] -- ^ modules + -> IO [(FilePath, FilePath)] +findModuleFiles searchPath extensions moduleNames = + mapM (findModuleFile searchPath extensions) moduleNames + +-- | Find the file corresponding to a Haskell module name. +-- +-- This is similar to 'findFileWithExtension'' but specialised to a module +-- name. The function fails if the file corresponding to the module is missing. +-- +findModuleFile :: [FilePath] -- ^ build prefix (location of objects) + -> [String] -- ^ search suffixes + -> ModuleName -- ^ module + -> IO (FilePath, FilePath) +findModuleFile searchPath extensions moduleName = + maybe notFound return + =<< findFileWithExtension' extensions searchPath + (ModuleName.toFilePath moduleName) + where + notFound = die $ "Error: Could not find module: " ++ display moduleName + ++ " with any suffix: " ++ show extensions + ++ " in the search path: " ++ show searchPath + +-- | List all the files in a directory and all subdirectories. +-- +-- The order places files in sub-directories after all the files in their +-- parent directories. The list is generated lazily so is not well defined if +-- the source directory structure changes before the list is used. +-- +getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive topdir = recurseDirectories [""] + where + recurseDirectories :: [FilePath] -> IO [FilePath] + recurseDirectories [] = return [] + recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) + files' <- recurseDirectories (dirs' ++ dirs) + return (files ++ files') + + where + collect files dirs' [] = return (reverse files + ,reverse dirs') + collect files dirs' (entry:entries) | ignore entry + = collect files dirs' entries + collect files dirs' (entry:entries) = do + let dirEntry = dir entry + isDirectory <- doesDirectoryExist (topdir dirEntry) + if isDirectory + then collect files (dirEntry:dirs') entries + else collect (dirEntry:files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + +------------------------ +-- Environment variables + +-- | Is this directory in the system search path? +isInSearchPath :: FilePath -> IO Bool +isInSearchPath path = fmap (elem path) getSearchPath + +addLibraryPath :: OS + -> [FilePath] + -> [(String,String)] + -> [(String,String)] +addLibraryPath os paths = addEnv + where + pathsString = intercalate [searchPathSeparator] paths + ldPath = case os of + OSX -> "DYLD_LIBRARY_PATH" + _ -> "LD_LIBRARY_PATH" + + addEnv [] = [(ldPath,pathsString)] + addEnv ((key,value):xs) + | key == ldPath = + if null value + then (key,pathsString):xs + else (key,value ++ (searchPathSeparator:pathsString)):xs + | otherwise = (key,value):addEnv xs + +---------------- +-- File globbing + +data FileGlob + -- | No glob at all, just an ordinary file + = NoGlob FilePath + + -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to + -- @FileGlob \"foo\/bar\" \".baz\"@ + | FileGlob FilePath String + +parseFileGlob :: FilePath -> Maybe FileGlob +parseFileGlob filepath = case splitExtensions filepath of + (filepath', ext) -> case splitFileName filepath' of + (dir, "*") | '*' `elem` dir + || '*' `elem` ext + || null ext -> Nothing + | null dir -> Just (FileGlob "." ext) + | otherwise -> Just (FileGlob dir ext) + _ | '*' `elem` filepath -> Nothing + | otherwise -> Just (NoGlob filepath) + +matchFileGlob :: FilePath -> IO [FilePath] +matchFileGlob = matchDirFileGlob "." + +matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath] +matchDirFileGlob dir filepath = case parseFileGlob filepath of + Nothing -> die $ "invalid file glob '" ++ filepath + ++ "'. Wildcards '*' are only allowed in place of the file" + ++ " name, not in the directory name or file extension." + ++ " If a wildcard is used it must be with an file extension." + Just (NoGlob filepath') -> return [filepath'] + Just (FileGlob dir' ext) -> do + files <- getDirectoryContents (dir dir') + case [ dir' file + | file <- files + , let (name, ext') = splitExtensions file + , not (null name) && ext' == ext ] of + [] -> die $ "filepath wildcard '" ++ filepath + ++ "' does not match any files." + matches -> return matches + +-------------------- +-- Modification time + +-- | Compare the modification times of two files to see if the first is newer +-- than the second. The first file must exist but the second need not. +-- The expected use case is when the second file is generated using the first. +-- In this use case, if the result is True then the second file is out of date. +-- +moreRecentFile :: FilePath -> FilePath -> IO Bool +moreRecentFile a b = do + exists <- doesFileExist b + if not exists + then return True + else do tb <- getModificationTime b + ta <- getModificationTime a + return (ta > tb) + +-- | Like 'moreRecentFile', but also checks that the first file exists. +existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool +existsAndIsMoreRecentThan a b = do + exists <- doesFileExist a + if not exists + then return False + else a `moreRecentFile` b + +---------------------------------------- +-- Copying and installing files and dirs + +-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. +-- +createDirectoryIfMissingVerbose :: Verbosity + -> Bool -- ^ Create its parents too? + -> FilePath + -> IO () +createDirectoryIfMissingVerbose verbosity create_parents path0 + | create_parents = createDirs (parents path0) + | otherwise = createDirs (take 1 (parents path0)) + where + parents = reverse . scanl1 () . splitDirectories . normalise + + createDirs [] = return () + createDirs (dir:[]) = createDir dir throwIO + createDirs (dir:dirs) = + createDir dir $ \_ -> do + createDirs dirs + createDir dir throwIO + + createDir :: FilePath -> (IOException -> IO ()) -> IO () + createDir dir notExistHandler = do + r <- tryIO $ createDirectoryVerbose verbosity dir + case (r :: Either IOException ()) of + Right () -> return () + Left e + | isDoesNotExistError e -> notExistHandler e + -- createDirectory (and indeed POSIX mkdir) does not distinguish + -- between a dir already existing and a file already existing. So we + -- check for it here. Unfortunately there is a slight race condition + -- here, but we think it is benign. It could report an exception in + -- the case that the dir did exist but another process deletes the + -- directory and creates a file in its place before we can check + -- that the directory did indeed exist. + | isAlreadyExistsError e -> (do + isDir <- doesDirectoryExist dir + if isDir then return () + else throwIO e + ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) + | otherwise -> throwIO e + +createDirectoryVerbose :: Verbosity -> FilePath -> IO () +createDirectoryVerbose verbosity dir = do + info verbosity $ "creating " ++ dir + createDirectory dir + setDirOrdinary dir + +-- | Copies a file without copying file permissions. The target file is created +-- with default permissions. Any existing target file is replaced. +-- +-- At higher verbosity levels it logs an info message. +-- +copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyFileVerbose verbosity src dest = do + info verbosity ("copy " ++ src ++ " to " ++ dest) + copyFile src dest + +-- | Install an ordinary file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" +-- while on Windows it uses the default permissions for the target directory. +-- +installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () +installOrdinaryFile verbosity src dest = do + info verbosity ("Installing " ++ src ++ " to " ++ dest) + copyOrdinaryFile src dest + +-- | Install an executable file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" +-- while on Windows it uses the default permissions for the target directory. +-- +installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () +installExecutableFile verbosity src dest = do + info verbosity ("Installing executable " ++ src ++ " to " ++ dest) + copyExecutableFile src dest + +-- | Install a file that may or not be executable, preserving permissions. +installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () +installMaybeExecutableFile verbosity src dest = do + perms <- getPermissions src + if (executable perms) --only checks user x bit + then installExecutableFile verbosity src dest + else installOrdinaryFile verbosity src dest + +-- | Given a relative path to a file, copy it to the given directory, preserving +-- the relative path and creating the parent directories if needed. +copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () +copyFileTo verbosity dir file = do + let targetFile = dir file + createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) + installOrdinaryFile verbosity file targetFile + +-- | Common implementation of 'copyFiles', 'installOrdinaryFiles', +-- 'installExecutableFiles' and 'installMaybeExecutableFiles'. +copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ()) + -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +copyFilesWith doCopy verbosity targetDir srcFiles = do + + -- Create parent directories for everything + let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles + mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs + + -- Copy all the files + sequence_ [ let src = srcBase srcFile + dest = targetDir srcFile + in doCopy verbosity src dest + | (srcBase, srcFile) <- srcFiles ] + +-- | Copies a bunch of files to a target directory, preserving the directory +-- structure in the target location. The target directories are created if they +-- do not exist. +-- +-- The files are identified by a pair of base directory and a path relative to +-- that base. It is only the relative part that is preserved in the +-- destination. +-- +-- For example: +-- +-- > copyFiles normal "dist/src" +-- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] +-- +-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and +-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". +-- +-- This operation is not atomic. Any IO failure during the copy (including any +-- missing source files) leaves the target in an unknown state so it is best to +-- use it with a freshly created directory so that it can be simply deleted if +-- anything goes wrong. +-- +copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +copyFiles = copyFilesWith copyFileVerbose + +-- | This is like 'copyFiles' but uses 'installOrdinaryFile'. +-- +installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +installOrdinaryFiles = copyFilesWith installOrdinaryFile + +-- | This is like 'copyFiles' but uses 'installExecutableFile'. +-- +installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] + -> IO () +installExecutableFiles = copyFilesWith installExecutableFile + +-- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'. +-- +installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] + -> IO () +installMaybeExecutableFiles = copyFilesWith installMaybeExecutableFile + +-- | This installs all the files in a directory to a target location, +-- preserving the directory layout. All the files are assumed to be ordinary +-- rather than executable files. +-- +installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () +installDirectoryContents verbosity srcDir destDir = do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] + +-- | Recursively copy the contents of one directory to another path. +copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO () +copyDirectoryRecursive verbosity srcDir destDir = do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f) | f <- srcFiles ] + +------------------- +-- File permissions + +-- | Like 'doesFileExist', but also checks that the file is executable. +doesExecutableExist :: FilePath -> IO Bool +doesExecutableExist f = do + exists <- doesFileExist f + if exists + then do perms <- getPermissions f + return (executable perms) + else return False + +--------------------------------- +-- Deprecated file copy functions + +{-# DEPRECATED smartCopySources + "Use findModuleFiles and copyFiles or installOrdinaryFiles" #-} +smartCopySources :: Verbosity -> [FilePath] -> FilePath + -> [ModuleName] -> [String] -> IO () +smartCopySources verbosity searchPath targetDir moduleNames extensions = + findModuleFiles searchPath extensions moduleNames + >>= copyFiles verbosity targetDir + +{-# DEPRECATED copyDirectoryRecursiveVerbose + "You probably want installDirectoryContents instead" #-} +copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyDirectoryRecursiveVerbose verbosity srcDir destDir = do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] + +--------------------------- +-- Temporary files and dirs + +-- | Advanced options for 'withTempFile' and 'withTempDirectory'. +data TempFileOptions = TempFileOptions { + optKeepTempFiles :: Bool -- ^ Keep temporary files? + } + +defaultTempFileOptions :: TempFileOptions +defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False } + +-- | Use a temporary filename that doesn't already exist. +-- +withTempFile :: FilePath -- ^ Temp dir to create the file in + -> String -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> IO a) -> IO a +withTempFile tmpDir template action = + withTempFileEx defaultTempFileOptions tmpDir template action + +-- | A version of 'withTempFile' that additionally takes a 'TempFileOptions' +-- argument. +withTempFileEx :: TempFileOptions + -> FilePath -- ^ Temp dir to create the file in + -> String -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> IO a) -> IO a +withTempFileEx opts tmpDir template action = + Exception.bracket + (openTempFile tmpDir template) + (\(name, handle) -> do hClose handle + unless (optKeepTempFiles opts) $ removeFile name) + (uncurry action) + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +-- +withTempDirectory :: Verbosity + -> FilePath -> String -> (FilePath -> IO a) -> IO a +withTempDirectory verbosity targetDir template = + withTempDirectoryEx verbosity defaultTempFileOptions targetDir template + +-- | A version of 'withTempDirectory' that additionally takes a +-- 'TempFileOptions' argument. +withTempDirectoryEx :: Verbosity + -> TempFileOptions + -> FilePath -> String -> (FilePath -> IO a) -> IO a +withTempDirectoryEx _verbosity opts targetDir template = + Exception.bracket + (createTempDirectory targetDir template) + (unless (optKeepTempFiles opts) . removeDirectoryRecursive) + +----------------------------------- +-- Safely reading and writing files + +-- | Gets the contents of a file, but guarantee that it gets closed. +-- +-- The file is read lazily but if it is not fully consumed by the action then +-- the remaining input is truncated and the file is closed. +-- +withFileContents :: FilePath -> (String -> IO a) -> IO a +withFileContents name action = + Exception.bracket (openFile name ReadMode) hClose + (\hnd -> hGetContents hnd >>= action) + +-- | Writes a file atomically. +-- +-- The file is either written successfully or an IO exception is raised and +-- the original file is left unchanged. +-- +-- On windows it is not possible to delete a file that is open by a process. +-- This case will give an IO exception but the atomic property is not affected. +-- +writeFileAtomic :: FilePath -> BS.ByteString -> IO () +writeFileAtomic targetPath content = do + let (targetDir, targetFile) = splitFileName targetPath + Exception.bracketOnError + (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") + (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) + (\(tmpPath, handle) -> do + BS.hPut handle content + hClose handle + renameFile tmpPath targetPath) + +-- | Write a file but only if it would have new content. If we would be writing +-- the same as the existing content then leave the file as is so that we do not +-- update the file's modification time. +-- +-- NB: the file is assumed to be ASCII-encoded. +rewriteFile :: FilePath -> String -> IO () +rewriteFile path newContent = + flip catchIO mightNotExist $ do + existingContent <- readFile path + _ <- evaluate (length existingContent) + unless (existingContent == newContent) $ + writeFileAtomic path (BS.Char8.pack newContent) + where + mightNotExist e | isDoesNotExistError e = writeFileAtomic path + (BS.Char8.pack newContent) + | otherwise = ioError e + +-- | The path name that represents the current directory. +-- In Unix, it's @\".\"@, but this is system-specific. +-- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) +currentDir :: FilePath +currentDir = "." + +shortRelativePath :: FilePath -> FilePath -> FilePath +shortRelativePath from to = + case dropCommonPrefix (splitDirectories from) (splitDirectories to) of + (stuff, path) -> joinPath (map (const "..") stuff ++ path) + where + dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a]) + dropCommonPrefix (x:xs) (y:ys) + | x == y = dropCommonPrefix xs ys + dropCommonPrefix xs ys = (xs,ys) + +-- ------------------------------------------------------------ +-- * Finding the description file +-- ------------------------------------------------------------ + +-- |Package description file (/pkgname/@.cabal@) +defaultPackageDesc :: Verbosity -> IO FilePath +defaultPackageDesc _verbosity = tryFindPackageDesc currentDir + +-- |Find a package description file in the given directory. Looks for +-- @.cabal@ files. +findPackageDesc :: FilePath -- ^Where to look + -> IO (Either String FilePath) -- ^.cabal +findPackageDesc dir + = do files <- getDirectoryContents dir + -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal + -- file we filter to exclude dirs and null base file names: + cabalFiles <- filterM doesFileExist + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == ".cabal" ] + case cabalFiles of + [] -> return (Left noDesc) + [cabalFile] -> return (Right cabalFile) + multiple -> return (Left $ 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 + +-- |Like 'findPackageDesc', but calls 'die' in case of error. +tryFindPackageDesc :: FilePath -> IO FilePath +tryFindPackageDesc dir = join . fmap (either die return) $ findPackageDesc dir + +-- |Optional auxiliary package information file (/pkgname/@.buildinfo@) +defaultHookedPackageDesc :: IO (Maybe FilePath) +defaultHookedPackageDesc = findHookedPackageDesc currentDir + +-- |Find auxiliary package information in the given directory. +-- Looks for @.buildinfo@ files. +findHookedPackageDesc + :: FilePath -- ^Directory to search + -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present +findHookedPackageDesc dir = do + files <- getDirectoryContents dir + buildInfoFiles <- filterM doesFileExist + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == buildInfoExt ] + case buildInfoFiles of + [] -> return Nothing + [f] -> return (Just f) + _ -> die ("Multiple files with extension " ++ buildInfoExt) + +buildInfoExt :: String +buildInfoExt = ".buildinfo" + +-- ------------------------------------------------------------ +-- * Unicode stuff +-- ------------------------------------------------------------ + +-- This is a modification of the UTF8 code from gtk2hs and the +-- utf8-string package. + +fromUTF8 :: String -> String +fromUTF8 [] = [] +fromUTF8 (c:cs) + | c <= '\x7F' = c : fromUTF8 cs + | c <= '\xBF' = replacementChar : fromUTF8 cs + | c <= '\xDF' = twoBytes c cs + | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF) + | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7) + | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3) + | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1) + | otherwise = replacementChar : fromUTF8 cs + where + twoBytes c0 (c1:cs') + | ord c1 .&. 0xC0 == 0x80 + = let d = ((ord c0 .&. 0x1F) `shiftL` 6) + .|. (ord c1 .&. 0x3F) + in if d >= 0x80 + then chr d : fromUTF8 cs' + else replacementChar : fromUTF8 cs' + twoBytes _ cs' = replacementChar : fromUTF8 cs' + + moreBytes :: Int -> Int -> [Char] -> Int -> [Char] + moreBytes 1 overlong cs' acc + | overlong <= acc && acc <= 0x10FFFF + && (acc < 0xD800 || 0xDFFF < acc) + && (acc < 0xFFFE || 0xFFFF < acc) + = chr acc : fromUTF8 cs' + + | otherwise + = replacementChar : fromUTF8 cs' + + moreBytes byteCount overlong (cn:cs') acc + | ord cn .&. 0xC0 == 0x80 + = moreBytes (byteCount-1) overlong cs' + ((acc `shiftL` 6) .|. ord cn .&. 0x3F) + + moreBytes _ _ cs' _ + = replacementChar : fromUTF8 cs' + + replacementChar = '\xfffd' + +toUTF8 :: String -> String +toUTF8 [] = [] +toUTF8 (c:cs) + | c <= '\x07F' = c + : toUTF8 cs + | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6)) + : chr (0x80 .|. (w .&. 0x3F)) + : toUTF8 cs + | c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12)) + : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) + : chr (0x80 .|. (w .&. 0x3F)) + : toUTF8 cs + | otherwise = chr (0xf0 .|. (w `shiftR` 18)) + : chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F)) + : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) + : chr (0x80 .|. (w .&. 0x3F)) + : toUTF8 cs + where w = ord c + +-- | Ignore a Unicode byte order mark (BOM) at the beginning of the input +-- +ignoreBOM :: String -> String +ignoreBOM ('\xFEFF':string) = string +ignoreBOM string = string + +-- | Reads a UTF8 encoded text file as a Unicode String +-- +-- Reads lazily using ordinary 'readFile'. +-- +readUTF8File :: FilePath -> IO String +readUTF8File f = fmap (ignoreBOM . fromUTF8) + . hGetContents =<< openBinaryFile f ReadMode + +-- | Reads a UTF8 encoded text file as a Unicode String +-- +-- Same behaviour as 'withFileContents'. +-- +withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a +withUTF8FileContents name action = + Exception.bracket + (openBinaryFile name ReadMode) + hClose + (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8) + +-- | Writes a Unicode String as a UTF8 encoded text file. +-- +-- Uses 'writeFileAtomic', so provides the same guarantees. +-- +writeUTF8File :: FilePath -> String -> IO () +writeUTF8File path = writeFileAtomic path . BS.Char8.pack . toUTF8 + +-- | Fix different systems silly line ending conventions +normaliseLineEndings :: String -> String +normaliseLineEndings [] = [] +normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows +normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old OS X +normaliseLineEndings ( c :s) = c : normaliseLineEndings s + +-- ------------------------------------------------------------ +-- * Common utils +-- ------------------------------------------------------------ + +-- | @dropWhileEndLE p@ is equivalent to @reverse . dropWhile p . reverse@, but +-- quite a bit faster. The difference between "Data.List.dropWhileEnd" and this +-- version is that the one in "Data.List" is strict in elements, but spine-lazy, +-- while this one is spine-strict but lazy in elements. That's what @LE@ stands +-- for - "lazy in elements". +-- +-- Example: +-- +-- @ +-- > tail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1] +-- *** Exception: Prelude.undefined +-- > tail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1] +-- [5,4,3] +-- > take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined] +-- [5,4,3] +-- > take 3 $ dropWhileEndLE (<3) [5, 4, 3, 2, 1, undefined] +-- *** Exception: Prelude.undefined +-- @ +dropWhileEndLE :: (a -> Bool) -> [a] -> [a] +dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] + +-- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but +-- is usually faster (as well as being easier to read). +takeWhileEndLE :: (a -> Bool) -> [a] -> [a] +takeWhileEndLE p = fst . foldr go ([], False) + where + go x (rest, done) + | not done && p x = (x:rest, False) + | otherwise = (rest, True) + +-- | Like "Data.List.nub", but has @O(n log n)@ complexity instead of +-- @O(n^2)@. Code for 'ordNub' and 'listUnion' taken from Niklas Hambüchen's +-- package. +ordNub :: (Ord a) => [a] -> [a] +ordNub l = go Set.empty l + where + go _ [] = [] + go s (x:xs) = if x `Set.member` s then go s xs + else x : go (Set.insert x s) xs + +-- | Like "Data.List.union", but has @O(n log n)@ complexity instead of +-- @O(n^2)@. +listUnion :: (Ord a) => [a] -> [a] -> [a] +listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b) + where + aSet = Set.fromList a + +-- | A right-biased version of 'ordNub'. +-- +-- Example: +-- +-- @ +-- > ordNub [1,2,1] +-- [1,2] +-- > ordNubRight [1,2,1] +-- [2,1] +-- @ +ordNubRight :: (Ord a) => [a] -> [a] +ordNubRight = fst . foldr go ([], Set.empty) + where + go x p@(l, s) = if x `Set.member` s then p + else (x:l, Set.insert x s) + +-- | A right-biased version of 'listUnion'. +-- +-- Example: +-- +-- @ +-- > listUnion [1,2,3,4,3] [2,1,1] +-- [1,2,3,4,3] +-- > listUnionRight [1,2,3,4,3] [2,1,1] +-- [4,3,2,1,1] +-- @ +listUnionRight :: (Ord a) => [a] -> [a] -> [a] +listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b + where + bSet = Set.fromList b + +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 new file mode 100644 --- /dev/null +++ b/Distribution/System.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.System +-- Copyright : Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Cabal often needs to do slightly different things on specific platforms. You +-- probably know about the 'System.Info.os' however using that is very +-- inconvenient because it is a string and different Haskell implementations +-- do not agree on using the same strings for the same platforms! (In +-- particular see the controversy over \"windows\" vs \"ming32\"). So to make it +-- more consistent and easy to use we have an 'OS' enumeration. +-- +module Distribution.System ( + -- * Operating System + OS(..), + buildOS, + + -- * Machine Architecture + Arch(..), + buildArch, + + -- * Platform is a pair of arch and OS + Platform(..), + buildPlatform, + platformFromTriple + ) where + +import qualified System.Info (os, arch) +import qualified Data.Char as Char (toLower, isAlphaNum) + +import Distribution.Compat.Binary (Binary) +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 ((<>)) + +-- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. +-- +-- The reason we have multiple ways to do the classification is because there +-- are two situations where we need to do it. +-- +-- For parsing OS and arch names in .cabal files we really want everyone to be +-- referring to the same or or arch by the same name. Variety is not a virtue +-- in this case. We don't mind about case though. +-- +-- For the System.Info.os\/arch different Haskell implementations use different +-- names for the same or\/arch. Also they tend to distinguish versions of an +-- OS\/arch which we just don't care about. +-- +-- The 'Compat' classification allows us to recognise aliases that are already +-- in common use but it allows us to distinguish them from the canonical name +-- which enables us to warn about such deprecated aliases. +-- +data ClassificationStrictness = Permissive | Compat | Strict + +-- ------------------------------------------------------------ +-- * Operating System +-- ------------------------------------------------------------ + +data OS = Linux | Windows | OSX -- tier 1 desktop OSs + | FreeBSD | OpenBSD | NetBSD -- other free Unix OSs + | DragonFly + | Solaris | AIX | HPUX | IRIX -- ageing Unix OSs + | HaLVM -- bare metal / VMs / hypervisors + | Hurd -- GNU's microkernel + | IOS | Android -- mobile OSs + | Ghcjs + | OtherOS String + deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) + +instance Binary OS + +knownOSs :: [OS] +knownOSs = [Linux, Windows, OSX + ,FreeBSD, OpenBSD, NetBSD, DragonFly + ,Solaris, AIX, HPUX, IRIX + ,HaLVM + ,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"] +osAliases Compat Solaris = ["solaris2"] +osAliases _ _ = [] + +instance Text OS where + disp (OtherOS name) = Disp.text name + disp other = Disp.text (lowercase (show other)) + + parse = fmap (classifyOS Compat) ident + +classifyOS :: ClassificationStrictness -> String -> OS +classifyOS strictness s = + fromMaybe (OtherOS s) $ lookup (lowercase s) osMap + where + osMap = [ (name, os) + | os <- knownOSs + , name <- display os : osAliases strictness os ] + +buildOS :: OS +buildOS = classifyOS Permissive System.Info.os + +-- ------------------------------------------------------------ +-- * Machine Architecture +-- ------------------------------------------------------------ + +data Arch = I386 | X86_64 | PPC | PPC64 | Sparc + | Arm | Mips | SH + | IA64 | S390 + | Alpha | Hppa | Rs6000 + | M68k | Vax + | JavaScript + | OtherArch String + deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) + +instance Binary Arch + +knownArches :: [Arch] +knownArches = [I386, X86_64, PPC, PPC64, Sparc + ,Arm, Mips, SH + ,IA64, S390 + ,Alpha, Hppa, Rs6000 + ,M68k, Vax + ,JavaScript] + +archAliases :: ClassificationStrictness -> Arch -> [String] +archAliases Strict _ = [] +archAliases Compat _ = [] +archAliases _ PPC = ["powerpc"] +archAliases _ PPC64 = ["powerpc64"] +archAliases _ Sparc = ["sparc64", "sun4"] +archAliases _ Mips = ["mipsel", "mipseb"] +archAliases _ Arm = ["armeb", "armel"] +archAliases _ _ = [] + +instance Text Arch where + disp (OtherArch name) = Disp.text name + disp other = Disp.text (lowercase (show other)) + + parse = fmap (classifyArch Strict) ident + +classifyArch :: ClassificationStrictness -> String -> Arch +classifyArch strictness s = + fromMaybe (OtherArch s) $ lookup (lowercase s) archMap + where + archMap = [ (name, arch) + | arch <- knownArches + , name <- display arch : archAliases strictness arch ] + +buildArch :: Arch +buildArch = classifyArch Permissive System.Info.arch + +-- ------------------------------------------------------------ +-- * Platform +-- ------------------------------------------------------------ + +data Platform = Platform Arch OS + deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) + +instance Binary Platform + +instance Text Platform where + disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os + parse = do + arch <- parse + _ <- Parse.char '-' + os <- parse + return (Platform arch os) + +-- | The platform Cabal was compiled on. In most cases, +-- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're +-- targeting). +buildPlatform :: Platform +buildPlatform = Platform buildArch buildOS + +-- Utils: + +ident :: Parse.ReadP r String +ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') + --TODO: probably should disallow starting with a number + +lowercase :: String -> String +lowercase = map Char.toLower + +platformFromTriple :: String -> Maybe Platform +platformFromTriple triple = + fmap fst (listToMaybe $ Parse.readP_to_S parseTriple triple) + where parseWord = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_') + parseTriple = do + arch <- fmap (classifyArch Strict) parseWord + _ <- Parse.char '-' + _ <- parseWord -- Skip vendor + _ <- Parse.char '-' + os <- fmap (classifyOS Compat) ident -- OS may have hyphens, like + -- 'nto-qnx' + return $ Platform arch os diff --git a/Distribution/TestSuite.hs b/Distribution/TestSuite.hs new file mode 100644 --- /dev/null +++ b/Distribution/TestSuite.hs @@ -0,0 +1,96 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.TestSuite +-- Copyright : Thomas Tuegel 2010 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module defines the detailed test suite interface which makes it +-- possible to expose individual tests to Cabal or other test agents. + +module Distribution.TestSuite + ( TestInstance(..) + , OptionDescr(..) + , OptionType(..) + , Test(..) + , Options + , Progress(..) + , Result(..) + , testGroup + ) where + +data TestInstance = TestInstance + { run :: IO Progress -- ^ Perform the test. + , name :: String -- ^ A name for the test, unique within a + -- test suite. + , tags :: [String] -- ^ Users can select groups of tests by + -- their tags. + , options :: [OptionDescr] -- ^ Descriptions of the options recognized + -- by this test. + , setOption :: String -> String -> Either String TestInstance + -- ^ Try to set the named option to the given value. Returns an error + -- message if the option is not supported or the value could not be + -- correctly parsed; otherwise, a 'TestInstance' with the option set to + -- the given value is returned. + } + +data OptionDescr = OptionDescr + { optionName :: String + , optionDescription :: String -- ^ A human-readable description of the + -- option to guide the user setting it. + , optionType :: OptionType + , optionDefault :: Maybe String + } + deriving (Eq, Read, Show) + +data OptionType + = OptionFile + { optionFileMustExist :: Bool + , optionFileIsDir :: Bool + , optionFileExtensions :: [String] + } + | OptionString + { optionStringMultiline :: Bool + } + | OptionNumber + { optionNumberIsInt :: Bool + , optionNumberBounds :: (Maybe String, Maybe String) + } + | OptionBool + | OptionEnum [String] + | OptionSet [String] + | OptionRngSeed + deriving (Eq, Read, Show) + +data Test + = Test TestInstance + | Group + { groupName :: String + , concurrently :: Bool + -- ^ If true, then children of this group may be run in parallel. + -- Note that this setting is not inherited by children. In + -- particular, consider a group F with "concurrently = False" that + -- has some children, including a group T with "concurrently = + -- True". The children of group T may be run concurrently with each + -- other, as long as none are run at the same time as any of the + -- direct children of group F. + , groupTests :: [Test] + } + | ExtraOptions [OptionDescr] Test + +type Options = [(String, String)] + +data Progress = Finished Result + | Progress String (IO Progress) + +data Result = Pass + | Fail String + | Error String + deriving (Eq, Read, Show) + +-- | Create a named group of tests, which are assumed to be safe to run in +-- parallel. +testGroup :: String -> [Test] -> Test +testGroup n ts = Group { groupName = n, concurrently = True, groupTests = ts } diff --git a/Distribution/Text.hs b/Distribution/Text.hs new file mode 100644 --- /dev/null +++ b/Distribution/Text.hs @@ -0,0 +1,68 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Text +-- Copyright : Duncan Coutts 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines a 'Text' class which is a bit like the 'Read' and 'Show' +-- classes. The difference is that is uses a modern pretty printer and parser +-- system and the format is not expected to be Haskell concrete syntax but +-- rather the external human readable representation used by Cabal. +-- +module Distribution.Text ( + Text(..), + display, + simpleParse, + ) where + +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp + +import Data.Version (Version(Version)) +import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace) + +class Text a where + disp :: a -> Disp.Doc + parse :: Parse.ReadP r a + +display :: Text a => a -> String +display = Disp.renderStyle style . disp + where style = Disp.Style { + Disp.mode = Disp.PageMode, + Disp.lineLength = 79, + Disp.ribbonsPerLine = 1.0 + } + +simpleParse :: Text a => String -> Maybe a +simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str + , all Char.isSpace s ] of + [] -> Nothing + (p:_) -> Just p + +-- ----------------------------------------------------------------------------- +-- Instances for types from the base package + +instance Text Bool where + disp = Disp.text . show + parse = Parse.choice [ (Parse.string "True" Parse.+++ + Parse.string "true") >> return True + , (Parse.string "False" Parse.+++ + Parse.string "false") >> return False ] + +instance Text Version where + disp (Version branch _tags) -- Death to version tags!! + = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch)) + + parse = do + branch <- Parse.sepBy1 digits (Parse.char '.') + tags <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum) + return (Version branch tags) --TODO: should we ignore the tags? + where + digits = do + first <- Parse.satisfy Char.isDigit + if first == '0' + then return 0 + else do rest <- Parse.munch Char.isDigit + return (read (first : rest)) diff --git a/Distribution/Utils/NubList.hs b/Distribution/Utils/NubList.hs new file mode 100644 --- /dev/null +++ b/Distribution/Utils/NubList.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE CPP #-} +module Distribution.Utils.NubList + ( NubList -- opaque + , toNubList -- smart construtor + , fromNubList + , overNubList + + , NubListR + , toNubListR + , fromNubListR + , overNubListR + ) where + +import Distribution.Compat.Binary +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid +#endif + +import Distribution.Simple.Utils (ordNub, listUnion, ordNubRight, listUnionRight) + +import qualified Text.Read as R + +-- | NubList : A de-duplicated list that maintains the original order. +newtype NubList a = + NubList { fromNubList :: [a] } + deriving Eq + +-- NubList assumes that nub retains the list order while removing duplicate +-- elements (keeping the first occurence). Documentation for "Data.List.nub" +-- does not specifically state that ordering is maintained so we will add a test +-- for that to the test suite. + +-- | Smart constructor for the NubList type. +toNubList :: Ord a => [a] -> NubList a +toNubList list = NubList $ ordNub list + +-- | Lift a function over lists to a function over NubLists. +overNubList :: Ord a => ([a] -> [a]) -> NubList a -> NubList a +overNubList f (NubList list) = toNubList . f $ list + +-- | Monoid operations on NubLists. +-- For a valid Monoid instance we need to satistfy the required monoid laws; +-- identity, associativity and closure. +-- +-- Identity : by inspection: +-- mempty `mappend` NubList xs == NubList xs `mappend` mempty +-- +-- Associativity : by inspection: +-- (NubList xs `mappend` NubList ys) `mappend` NubList zs +-- == NubList xs `mappend` (NubList ys `mappend` NubList zs) +-- +-- Closure : appending two lists of type a and removing duplicates obviously +-- does not change the type. + +instance Ord a => Monoid (NubList a) where + mempty = NubList [] + mappend (NubList xs) (NubList ys) = NubList $ xs `listUnion` ys + +instance Show a => Show (NubList a) where + show (NubList list) = show list + +instance (Ord a, Read a) => Read (NubList a) where + readPrec = readNubList toNubList + +-- | Helper used by NubList/NubListR's Read instances. +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 +-- just pull off constructor and put the list. For 'get', we get the list and +-- make a 'NubList' out of it using 'toNubList'. +instance (Ord a, Binary a) => Binary (NubList a) where + put (NubList l) = put l + get = fmap toNubList get + +-- | NubListR : A right-biased version of 'NubList'. That is @toNubListR +-- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@, +-- unlike the normal 'NubList', which is left-biased. Built on top of +-- 'ordNubRight' and 'listUnionRight'. +newtype NubListR a = + NubListR { fromNubListR :: [a] } + deriving Eq + +-- | Smart constructor for the NubListR type. +toNubListR :: Ord a => [a] -> NubListR a +toNubListR list = NubListR $ ordNubRight list + +-- | Lift a function over lists to a function over NubListRs. +overNubListR :: Ord a => ([a] -> [a]) -> NubListR a -> NubListR a +overNubListR f (NubListR list) = toNubListR . f $ list + +instance Ord a => Monoid (NubListR a) where + mempty = NubListR [] + mappend (NubListR xs) (NubListR ys) = NubListR $ xs `listUnionRight` ys + +instance Show a => Show (NubListR a) where + show (NubListR list) = show list + +instance (Ord a, Read a) => Read (NubListR a) where + readPrec = readNubList toNubListR diff --git a/Distribution/Verbosity.hs b/Distribution/Verbosity.hs new file mode 100644 --- /dev/null +++ b/Distribution/Verbosity.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Verbosity +-- Copyright : Ian Lynagh 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A simple 'Verbosity' type with associated utilities. There are 4 standard +-- verbosity levels from 'silent', 'normal', 'verbose' up to 'deafening'. This +-- is used for deciding what logging messages to print. + +-- Verbosity for Cabal functions. + +module Distribution.Verbosity ( + -- * Verbosity + Verbosity, + silent, normal, verbose, deafening, + moreVerbose, lessVerbose, + intToVerbosity, flagToVerbosity, + showForCabal, showForGHC + ) where + +import Distribution.Compat.Binary (Binary) +import Data.List (elemIndex) +import Distribution.ReadE +import GHC.Generics + +data Verbosity = Silent | Normal | Verbose | Deafening + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded) + +instance Binary Verbosity + +-- We shouldn't print /anything/ unless an error occurs in silent mode +silent :: Verbosity +silent = Silent + +-- Print stuff we want to see by default +normal :: Verbosity +normal = Normal + +-- Be more verbose about what's going on +verbose :: Verbosity +verbose = Verbose + +-- Not only are we verbose ourselves (perhaps even noisier than when +-- being "verbose"), but we tell everything we run to be verbose too +deafening :: Verbosity +deafening = Deafening + +moreVerbose :: Verbosity -> Verbosity +moreVerbose Silent = Silent --silent should stay silent +moreVerbose Normal = Verbose +moreVerbose Verbose = Deafening +moreVerbose Deafening = Deafening + +lessVerbose :: Verbosity -> Verbosity +lessVerbose Deafening = Deafening +lessVerbose Verbose = Normal +lessVerbose Normal = Silent +lessVerbose Silent = Silent + +intToVerbosity :: Int -> Maybe Verbosity +intToVerbosity 0 = Just Silent +intToVerbosity 1 = Just Normal +intToVerbosity 2 = Just Verbose +intToVerbosity 3 = Just Deafening +intToVerbosity _ = Nothing + +flagToVerbosity :: ReadE Verbosity +flagToVerbosity = ReadE $ \s -> + case reads s of + [(i, "")] -> + case intToVerbosity i of + Just v -> Right v + Nothing -> Left ("Bad verbosity: " ++ show i ++ + ". Valid values are 0..3") + _ -> Left ("Can't parse verbosity " ++ s) + +showForCabal, showForGHC :: Verbosity -> String + +showForCabal v = maybe (error "unknown verbosity") show $ + elemIndex v [silent,normal,verbose,deafening] +showForGHC v = maybe (error "unknown verbosity") show $ + elemIndex v [silent,normal,__,verbose,deafening] + where __ = silent -- this will be always ignored by elemIndex diff --git a/Distribution/Version.hs b/Distribution/Version.hs new file mode 100644 --- /dev/null +++ b/Distribution/Version.hs @@ -0,0 +1,757 @@ +{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +#if __GLASGOW_HASKELL__ < 707 +{-# LANGUAGE StandaloneDeriving #-} +#endif +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Version +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- Duncan Coutts 2008 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Exports the 'Version' type along with a parser and pretty printer. A version +-- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data +-- types. Version ranges are like @\">= 1.2 && < 2\"@. + +module Distribution.Version ( + -- * Package versions + Version(..), + + -- * Version ranges + VersionRange(..), + + -- ** Constructing + anyVersion, noVersion, + thisVersion, notThisVersion, + laterVersion, earlierVersion, + orLaterVersion, orEarlierVersion, + unionVersionRanges, intersectVersionRanges, + withinVersion, + betweenVersionsInclusive, + + -- ** Inspection + withinRange, + isAnyVersion, + isNoVersion, + isSpecificVersion, + simplifyVersionRange, + foldVersionRange, + foldVersionRange', + + -- ** Modification + removeUpperBound, + + -- * Version intervals view + asVersionIntervals, + VersionInterval, + LowerBound(..), + UpperBound(..), + Bound(..), + + -- ** 'VersionIntervals' abstract type + -- | The 'VersionIntervals' type and the accompanying functions are exposed + -- primarily for completeness and testing purposes. In practice + -- 'asVersionIntervals' is the main function to use to + -- view a 'VersionRange' as a bunch of 'VersionInterval's. + -- + VersionIntervals, + toVersionIntervals, + fromVersionIntervals, + withinIntervals, + versionIntervals, + mkVersionIntervals, + unionVersionIntervals, + intersectVersionIntervals, + + ) where + +import Distribution.Compat.Binary ( Binary(..) ) +import Data.Data ( Data ) +import Data.Typeable ( Typeable ) +import Data.Version ( Version(..) ) +import GHC.Generics ( Generic ) + +import Distribution.Text ( Text(..) ) +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Compat.ReadP ((+++)) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>), (<+>)) +import qualified Data.Char as Char (isDigit) +import Control.Exception (assert) + +-- ----------------------------------------------------------------------------- +-- Version ranges + +-- Todo: maybe move this to Distribution.Package.Version? +-- (package-specific versioning scheme). + +data VersionRange + = AnyVersion + | ThisVersion Version -- = version + | LaterVersion Version -- > version (NB. not >=) + | EarlierVersion Version -- < version + | WildcardVersion Version -- == ver.* (same as >= ver && < ver+1) + | UnionVersionRanges VersionRange VersionRange + | IntersectVersionRanges VersionRange VersionRange + | VersionRangeParens VersionRange -- just '(exp)' parentheses syntax + deriving (Data, Eq, Generic, Read, Show, Typeable) + +instance Binary VersionRange + +#if __GLASGOW_HASKELL__ < 707 +-- starting with ghc-7.7/base-4.7 this instance is provided in "Data.Data" +deriving instance Data Version +#endif + +-- Deriving this instance from Generic gives trouble on GHC 7.2 because the +-- Generic instance has to be standalone-derived. So, we hand-roll our own. +-- We can't use a generic Binary instance on later versions because we must +-- maintain compatibility between compiler versions. +instance Binary Version where + get = do + br <- get + tags <- get + return $ Version br tags + put (Version br tags) = put br >> put tags + +{-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED LaterVersion "use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED EarlierVersion "use 'earlierVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED WildcardVersion "use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED UnionVersionRanges "use 'unionVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED IntersectVersionRanges "use 'intersectVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} + +-- | The version range @-any@. That is, a version range containing all +-- versions. +-- +-- > withinRange v anyVersion = True +-- +anyVersion :: VersionRange +anyVersion = AnyVersion + +-- | The empty version range, that is a version range containing no versions. +-- +-- This can be constructed using any unsatisfiable version range expression, +-- for example @> 1 && < 1@. +-- +-- > withinRange v noVersion = False +-- +noVersion :: VersionRange +noVersion = IntersectVersionRanges (LaterVersion v) (EarlierVersion v) + where v = Version [1] [] + +-- | The version range @== v@ +-- +-- > withinRange v' (thisVersion v) = v' == v +-- +thisVersion :: Version -> VersionRange +thisVersion = ThisVersion + +-- | The version range @< v || > v@ +-- +-- > withinRange v' (notThisVersion v) = v' /= v +-- +notThisVersion :: Version -> VersionRange +notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) + +-- | The version range @> v@ +-- +-- > withinRange v' (laterVersion v) = v' > v +-- +laterVersion :: Version -> VersionRange +laterVersion = LaterVersion + +-- | The version range @>= v@ +-- +-- > withinRange v' (orLaterVersion v) = v' >= v +-- +orLaterVersion :: Version -> VersionRange +orLaterVersion v = UnionVersionRanges (ThisVersion v) (LaterVersion v) + +-- | The version range @< v@ +-- +-- > withinRange v' (earlierVersion v) = v' < v +-- +earlierVersion :: Version -> VersionRange +earlierVersion = EarlierVersion + +-- | The version range @<= v@ +-- +-- > withinRange v' (orEarlierVersion v) = v' <= v +-- +orEarlierVersion :: Version -> VersionRange +orEarlierVersion v = UnionVersionRanges (ThisVersion v) (EarlierVersion v) + +-- | The version range @vr1 || vr2@ +-- +-- > withinRange v' (unionVersionRanges vr1 vr2) +-- > = withinRange v' vr1 || withinRange v' vr2 +-- +unionVersionRanges :: VersionRange -> VersionRange -> VersionRange +unionVersionRanges = UnionVersionRanges + +-- | The version range @vr1 && vr2@ +-- +-- > withinRange v' (intersectVersionRanges vr1 vr2) +-- > = withinRange v' vr1 && withinRange v' vr2 +-- +intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange +intersectVersionRanges = IntersectVersionRanges + +-- | The version range @== v.*@. +-- +-- For example, for version @1.2@, the version range @== 1.2.*@ is the same as +-- @>= 1.2 && < 1.3@ +-- +-- > withinRange v' (laterVersion v) = v' >= v && v' < upper v +-- > where +-- > upper (Version lower t) = Version (init lower ++ [last lower + 1]) t +-- +withinVersion :: Version -> VersionRange +withinVersion = WildcardVersion + +-- | The version range @>= v1 && <= v2@. +-- +-- In practice this is not very useful because we normally use inclusive lower +-- bounds and exclusive upper bounds. +-- +-- > withinRange v' (laterVersion v) = v' > v +-- +betweenVersionsInclusive :: Version -> Version -> VersionRange +betweenVersionsInclusive v1 v2 = + IntersectVersionRanges (orLaterVersion v1) (orEarlierVersion v2) + +{-# DEPRECATED betweenVersionsInclusive + "In practice this is not very useful because we normally use inclusive lower bounds and exclusive upper bounds" #-} + +-- | Given a version range, remove the highest upper bound. Example: @(>= 1 && < +-- 3) || (>= 4 && < 5)@ is converted to @(>= 1 && < 3) || (>= 4)@. +removeUpperBound :: VersionRange -> VersionRange +removeUpperBound = fromVersionIntervals . relaxLastInterval . toVersionIntervals + where + relaxLastInterval (VersionIntervals intervals) = + VersionIntervals (relaxLastInterval' intervals) + + relaxLastInterval' [] = [] + relaxLastInterval' [(l,_)] = [(l, NoUpperBound)] + relaxLastInterval' (i:is) = i : relaxLastInterval' is + +-- | Fold over the basic syntactic structure of a 'VersionRange'. +-- +-- This provides a syntactic view of the expression defining the version range. +-- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented +-- in terms of the other basic syntax. +-- +-- For a semantic view use 'asVersionIntervals'. +-- +foldVersionRange :: a -- ^ @\"-any\"@ version + -> (Version -> a) -- ^ @\"== v\"@ + -> (Version -> a) -- ^ @\"> v\"@ + -> (Version -> a) -- ^ @\"< v\"@ + -> (a -> a -> a) -- ^ @\"_ || _\"@ union + -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection + -> VersionRange -> a +foldVersionRange anyv this later earlier union intersect = fold + where + fold AnyVersion = anyv + fold (ThisVersion v) = this v + fold (LaterVersion v) = later v + fold (EarlierVersion v) = earlier v + fold (WildcardVersion v) = fold (wildcard v) + fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) + fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) + fold (VersionRangeParens v) = fold v + + wildcard v = intersectVersionRanges + (orLaterVersion v) + (earlierVersion (wildcardUpperBound v)) + +-- | An extended variant of 'foldVersionRange' that also provides a view of +-- in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented +-- explicitly rather than in terms of the other basic syntax. +-- +foldVersionRange' :: a -- ^ @\"-any\"@ version + -> (Version -> a) -- ^ @\"== v\"@ + -> (Version -> a) -- ^ @\"> v\"@ + -> (Version -> a) -- ^ @\"< v\"@ + -> (Version -> a) -- ^ @\">= v\"@ + -> (Version -> a) -- ^ @\"<= v\"@ + -> (Version -> Version -> a) -- ^ @\"== v.*\"@ wildcard. The + -- function is passed the + -- inclusive lower bound and the + -- exclusive upper bounds of the + -- range defined by the wildcard. + -> (a -> a -> a) -- ^ @\"_ || _\"@ union + -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection + -> (a -> a) -- ^ @\"(_)\"@ parentheses + -> VersionRange -> a +foldVersionRange' anyv this later earlier orLater orEarlier + wildcard union intersect parens = fold + where + fold AnyVersion = anyv + fold (ThisVersion v) = this v + fold (LaterVersion v) = later v + fold (EarlierVersion v) = earlier v + + fold (UnionVersionRanges (ThisVersion v) + (LaterVersion v')) | v==v' = orLater v + fold (UnionVersionRanges (LaterVersion v) + (ThisVersion v')) | v==v' = orLater v + fold (UnionVersionRanges (ThisVersion v) + (EarlierVersion v')) | v==v' = orEarlier v + fold (UnionVersionRanges (EarlierVersion v) + (ThisVersion v')) | v==v' = orEarlier v + + fold (WildcardVersion v) = wildcard v (wildcardUpperBound v) + fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) + fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) + fold (VersionRangeParens v) = parens (fold v) + + +-- | Does this version fall within the given range? +-- +-- This is the evaluation function for the 'VersionRange' type. +-- +withinRange :: Version -> VersionRange -> Bool +withinRange v = foldVersionRange + True + (\v' -> versionBranch v == versionBranch v') + (\v' -> versionBranch v > versionBranch v') + (\v' -> versionBranch v < versionBranch v') + (||) + (&&) + +-- | View a 'VersionRange' as a union of intervals. +-- +-- This provides a canonical view of the semantics of a 'VersionRange' as +-- opposed to the syntax of the expression used to define it. For the syntactic +-- view use 'foldVersionRange'. +-- +-- Each interval is non-empty. The sequence is in increasing order and no +-- intervals overlap or touch. Therefore only the first and last can be +-- unbounded. The sequence can be empty if the range is empty +-- (e.g. a range expression like @< 1 && > 2@). +-- +-- Other checks are trivial to implement using this view. For example: +-- +-- > isNoVersion vr | [] <- asVersionIntervals vr = True +-- > | otherwise = False +-- +-- > isSpecificVersion vr +-- > | [(LowerBound v InclusiveBound +-- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr +-- > , v == v' = Just v +-- > | otherwise = Nothing +-- +asVersionIntervals :: VersionRange -> [VersionInterval] +asVersionIntervals = versionIntervals . toVersionIntervals + +-- | Does this 'VersionRange' place any restriction on the 'Version' or is it +-- in fact equivalent to 'AnyVersion'. +-- +-- Note this is a semantic check, not simply a syntactic check. So for example +-- the following is @True@ (for all @v@). +-- +-- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v) +-- +isAnyVersion :: VersionRange -> Bool +isAnyVersion vr = case asVersionIntervals vr of + [(LowerBound v InclusiveBound, NoUpperBound)] | isVersion0 v -> True + _ -> False + +-- | This is the converse of 'isAnyVersion'. It check if the version range is +-- empty, if there is no possible version that satisfies the version range. +-- +-- For example this is @True@ (for all @v@): +-- +-- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v) +-- +isNoVersion :: VersionRange -> Bool +isNoVersion vr = case asVersionIntervals vr of + [] -> True + _ -> False + +-- | Is this version range in fact just a specific version? +-- +-- For example the version range @\">= 3 && <= 3\"@ contains only the version +-- @3@. +-- +isSpecificVersion :: VersionRange -> Maybe Version +isSpecificVersion vr = case asVersionIntervals vr of + [(LowerBound v InclusiveBound + ,UpperBound v' InclusiveBound)] + | v == v' -> Just v + _ -> Nothing + +-- | Simplify a 'VersionRange' expression. For non-empty version ranges +-- this produces a canonical form. Empty or inconsistent version ranges +-- are left as-is because that provides more information. +-- +-- If you need a canonical form use +-- @fromVersionIntervals . toVersionIntervals@ +-- +-- It satisfies the following properties: +-- +-- > withinRange v (simplifyVersionRange r) = withinRange v r +-- +-- > withinRange v r = withinRange v r' +-- > ==> simplifyVersionRange r = simplifyVersionRange r' +-- > || isNoVersion r +-- > || isNoVersion r' +-- +simplifyVersionRange :: VersionRange -> VersionRange +simplifyVersionRange vr + -- If the version range is inconsistent then we just return the + -- original since that has more information than ">1 && < 1", which + -- is the canonical inconsistent version range. + | null (versionIntervals vi) = vr + | otherwise = fromVersionIntervals vi + where + vi = toVersionIntervals vr + +---------------------------- +-- Wildcard range utilities +-- + +wildcardUpperBound :: Version -> Version +wildcardUpperBound (Version lowerBound ts) = Version upperBound ts + where + upperBound = init lowerBound ++ [last lowerBound + 1] + +isWildcardRange :: Version -> Version -> Bool +isWildcardRange (Version branch1 _) (Version branch2 _) = check branch1 branch2 + where check (n:[]) (m:[]) | n+1 == m = True + check (n:ns) (m:ms) | n == m = check ns ms + check _ _ = False + +------------------ +-- Intervals view +-- + +-- | A complementary representation of a 'VersionRange'. Instead of a boolean +-- version predicate it uses an increasing sequence of non-overlapping, +-- non-empty intervals. +-- +-- The key point is that this representation gives a canonical representation +-- for the semantics of 'VersionRange's. This makes it easier to check things +-- like whether a version range is empty, covers all versions, or requires a +-- certain minimum or maximum version. It also makes it easy to check equality +-- or containment. It also makes it easier to identify \'simple\' version +-- predicates for translation into foreign packaging systems that do not +-- support complex version range expressions. +-- +newtype VersionIntervals = VersionIntervals [VersionInterval] + deriving (Eq, Show) + +-- | Inspect the list of version intervals. +-- +versionIntervals :: VersionIntervals -> [VersionInterval] +versionIntervals (VersionIntervals is) = is + +type VersionInterval = (LowerBound, UpperBound) +data LowerBound = LowerBound Version !Bound deriving (Eq, Show) +data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show) +data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) + +minLowerBound :: LowerBound +minLowerBound = LowerBound (Version [0] []) InclusiveBound + +isVersion0 :: Version -> Bool +isVersion0 (Version [0] _) = True +isVersion0 _ = False + +instance Ord LowerBound where + LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of + LT -> True + EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound) + GT -> False + +instance Ord UpperBound where + _ <= NoUpperBound = True + NoUpperBound <= UpperBound _ _ = False + UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of + LT -> True + EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound) + GT -> False + +invariant :: VersionIntervals -> Bool +invariant (VersionIntervals intervals) = all validInterval intervals + && all doesNotTouch' adjacentIntervals + where + doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool + doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' + + adjacentIntervals :: [(VersionInterval, VersionInterval)] + adjacentIntervals + | null intervals = [] + | otherwise = zip intervals (tail intervals) + +checkInvariant :: VersionIntervals -> VersionIntervals +checkInvariant is = assert (invariant is) is + +-- | Directly construct a 'VersionIntervals' from a list of intervals. +-- +-- Each interval must be non-empty. The sequence must be in increasing order +-- and no intervals may overlap or touch. If any of these conditions are not +-- satisfied the function returns @Nothing@. +-- +mkVersionIntervals :: [VersionInterval] -> Maybe VersionIntervals +mkVersionIntervals intervals + | invariant (VersionIntervals intervals) = Just (VersionIntervals intervals) + | otherwise = Nothing + +validVersion :: Version -> Bool +validVersion (Version [] _) = False +validVersion (Version vs _) = all (>=0) vs + +validInterval :: (LowerBound, UpperBound) -> Bool +validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i + where + validLower (LowerBound v _) = validVersion v + validUpper NoUpperBound = True + validUpper (UpperBound v _) = validVersion v + +-- Check an interval is non-empty +-- +nonEmpty :: VersionInterval -> Bool +nonEmpty (_, NoUpperBound ) = True +nonEmpty (LowerBound l lb, UpperBound u ub) = + (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) + +-- Check an upper bound does not intersect, or even touch a lower bound: +-- +-- ---| or ---) but not ---] or ---) or ---] +-- |--- (--- (--- [--- [--- +-- +doesNotTouch :: UpperBound -> LowerBound -> Bool +doesNotTouch NoUpperBound _ = False +doesNotTouch (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) + +-- | Check an upper bound does not intersect a lower bound: +-- +-- ---| or ---) or ---] or ---) but not ---] +-- |--- (--- (--- [--- [--- +-- +doesNotIntersect :: UpperBound -> LowerBound -> Bool +doesNotIntersect NoUpperBound _ = False +doesNotIntersect (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) + +-- | Test if a version falls within the version intervals. +-- +-- It exists mostly for completeness and testing. It satisfies the following +-- properties: +-- +-- > withinIntervals v (toVersionIntervals vr) = withinRange v vr +-- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs) +-- +withinIntervals :: Version -> VersionIntervals -> Bool +withinIntervals v (VersionIntervals intervals) = any withinInterval intervals + where + withinInterval (lowerBound, upperBound) = withinLower lowerBound + && withinUpper upperBound + withinLower (LowerBound v' ExclusiveBound) = v' < v + withinLower (LowerBound v' InclusiveBound) = v' <= v + + withinUpper NoUpperBound = True + withinUpper (UpperBound v' ExclusiveBound) = v' > v + withinUpper (UpperBound v' InclusiveBound) = v' >= v + +-- | Convert a 'VersionRange' to a sequence of version intervals. +-- +toVersionIntervals :: VersionRange -> VersionIntervals +toVersionIntervals = foldVersionRange + ( chkIvl (minLowerBound, NoUpperBound)) + (\v -> chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)) + (\v -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound)) + (\v -> if isVersion0 v then VersionIntervals [] else + chkIvl (minLowerBound, UpperBound v ExclusiveBound)) + unionVersionIntervals + intersectVersionIntervals + where + chkIvl interval = checkInvariant (VersionIntervals [interval]) + +-- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression +-- representing the version intervals. +-- +fromVersionIntervals :: VersionIntervals -> VersionRange +fromVersionIntervals (VersionIntervals []) = noVersion +fromVersionIntervals (VersionIntervals intervals) = + foldr1 UnionVersionRanges [ interval l u | (l, u) <- intervals ] + + where + interval (LowerBound v InclusiveBound) + (UpperBound v' InclusiveBound) | v == v' + = ThisVersion v + interval (LowerBound v InclusiveBound) + (UpperBound v' ExclusiveBound) | isWildcardRange v v' + = WildcardVersion v + interval l u = lowerBound l `intersectVersionRanges'` upperBound u + + lowerBound (LowerBound v InclusiveBound) + | isVersion0 v = AnyVersion + | otherwise = orLaterVersion v + lowerBound (LowerBound v ExclusiveBound) = LaterVersion v + + upperBound NoUpperBound = AnyVersion + upperBound (UpperBound v InclusiveBound) = orEarlierVersion v + upperBound (UpperBound v ExclusiveBound) = EarlierVersion v + + intersectVersionRanges' vr AnyVersion = vr + intersectVersionRanges' AnyVersion vr = vr + intersectVersionRanges' vr vr' = IntersectVersionRanges vr vr' + +unionVersionIntervals :: VersionIntervals -> VersionIntervals + -> VersionIntervals +unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = + checkInvariant (VersionIntervals (union is0 is'0)) + where + union is [] = is + union [] is' = is' + union (i:is) (i':is') = case unionInterval i i' of + Left Nothing -> i : union is (i' :is') + Left (Just i'') -> union is (i'':is') + Right Nothing -> i' : union (i :is) is' + Right (Just i'') -> union (i'':is) is' + +unionInterval :: VersionInterval -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +unionInterval (lower , upper ) (lower', upper') + + -- Non-intersecting intervals with the left interval ending first + | upper `doesNotTouch` lower' = Left Nothing + + -- Non-intersecting intervals with the right interval first + | upper' `doesNotTouch` lower = Right Nothing + + -- Complete or partial overlap, with the left interval ending first + | upper <= upper' = lowerBound `seq` + Left (Just (lowerBound, upper')) + + -- Complete or partial overlap, with the left interval ending first + | otherwise = lowerBound `seq` + Right (Just (lowerBound, upper)) + where + lowerBound = min lower lower' + +intersectVersionIntervals :: VersionIntervals -> VersionIntervals + -> VersionIntervals +intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = + checkInvariant (VersionIntervals (intersect is0 is'0)) + where + intersect _ [] = [] + intersect [] _ = [] + intersect (i:is) (i':is') = case intersectInterval i i' of + Left Nothing -> intersect is (i':is') + Left (Just i'') -> i'' : intersect is (i':is') + Right Nothing -> intersect (i:is) is' + Right (Just i'') -> i'' : intersect (i:is) is' + +intersectInterval :: VersionInterval -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +intersectInterval (lower , upper ) (lower', upper') + + -- Non-intersecting intervals with the left interval ending first + | upper `doesNotIntersect` lower' = Left Nothing + + -- Non-intersecting intervals with the right interval first + | upper' `doesNotIntersect` lower = Right Nothing + + -- Complete or partial overlap, with the left interval ending first + | upper <= upper' = lowerBound `seq` + Left (Just (lowerBound, upper)) + + -- Complete or partial overlap, with the right interval ending first + | otherwise = lowerBound `seq` + Right (Just (lowerBound, upper')) + where + lowerBound = max lower lower' + +------------------------------- +-- Parsing and pretty printing +-- + +instance Text VersionRange where + disp = fst + . foldVersionRange' -- precedence: + ( Disp.text "-any" , 0 :: Int) + (\v -> (Disp.text "==" <> disp v , 0)) + (\v -> (Disp.char '>' <> disp v , 0)) + (\v -> (Disp.char '<' <> disp v , 0)) + (\v -> (Disp.text ">=" <> disp v , 0)) + (\v -> (Disp.text "<=" <> disp v , 0)) + (\v _ -> (Disp.text "==" <> dispWild v , 0)) + (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) + (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) + (\(r, p) -> (Disp.parens r, p)) + + where dispWild (Version b _) = + Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) + <> Disp.text ".*" + punct p p' | p < p' = Disp.parens + | otherwise = id + + parse = expr + where + expr = do Parse.skipSpaces + t <- term + Parse.skipSpaces + (do _ <- Parse.string "||" + Parse.skipSpaces + e <- expr + return (UnionVersionRanges t e) + +++ + return t) + term = do f <- factor + Parse.skipSpaces + (do _ <- Parse.string "&&" + Parse.skipSpaces + t <- term + return (IntersectVersionRanges f t) + +++ + return f) + factor = Parse.choice $ parens expr + : parseAnyVersion + : parseNoVersion + : parseWildcardRange + : map parseRangeOp rangeOps + parseAnyVersion = Parse.string "-any" >> return AnyVersion + parseNoVersion = Parse.string "-none" >> return noVersion + + parseWildcardRange = do + _ <- Parse.string "==" + Parse.skipSpaces + branch <- Parse.sepBy1 digits (Parse.char '.') + _ <- Parse.char '.' + _ <- Parse.char '*' + return (WildcardVersion (Version branch [])) + + parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces) + (Parse.char ')' >> Parse.skipSpaces) + (do a <- p + Parse.skipSpaces + return (VersionRangeParens a)) + + digits = do + first <- Parse.satisfy Char.isDigit + if first == '0' + then return 0 + else do rest <- Parse.munch Char.isDigit + return (read (first : rest)) + + parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse + rangeOps = [ ("<", EarlierVersion), + ("<=", orEarlierVersion), + (">", LaterVersion), + (">=", orLaterVersion), + ("==", ThisVersion) ] diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,34 @@ +Copyright (c) 2003-2014, Isaac Jones, Simon Marlow, Martin Sjögren, + Bjorn Bringert, Krasimir Angelov, + Malcolm Wallace, Ross Patterson, Ian Lynagh, + Duncan Coutts, Thomas Schilling, + Johan Tibell, Mikhail Glushenkov +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Language/Haskell/Extension.hs b/Language/Haskell/Extension.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Extension.hs @@ -0,0 +1,795 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.Extension +-- Copyright : Isaac Jones 2003-2004 +-- License : BSD3 +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- Haskell language dialects and extensions + +module Language.Haskell.Extension ( + Language(..), + knownLanguages, + + Extension(..), + KnownExtension(..), + knownExtensions, + deprecatedExtensions + ) where + +import Distribution.Text (Text(..)) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import qualified Data.Char as Char (isAlphaNum) +import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) +import Distribution.Compat.Binary (Binary) +import Data.Data (Data) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) + +-- ------------------------------------------------------------ +-- * Language +-- ------------------------------------------------------------ + +-- | This represents a Haskell language dialect. +-- +-- Language 'Extension's are interpreted relative to one of these base +-- languages. +-- +data Language = + + -- | The Haskell 98 language as defined by the Haskell 98 report. + -- + Haskell98 + + -- | The Haskell 2010 language as defined by the Haskell 2010 report. + -- + | Haskell2010 + + -- | An unknown language, identified by its name. + | UnknownLanguage String + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary Language + +knownLanguages :: [Language] +knownLanguages = [Haskell98, Haskell2010] + +instance Text Language where + disp (UnknownLanguage other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + lang <- Parse.munch1 Char.isAlphaNum + return (classifyLanguage lang) + +classifyLanguage :: String -> Language +classifyLanguage = \str -> case lookup str langTable of + Just lang -> lang + Nothing -> UnknownLanguage str + where + langTable = [ (show lang, lang) + | lang <- knownLanguages ] + +-- ------------------------------------------------------------ +-- * Extension +-- ------------------------------------------------------------ + +-- Note: if you add a new 'KnownExtension': +-- +-- * also add it to the Distribution.Simple.X.languageExtensions lists +-- (where X is each compiler: GHC, JHC, LHC, UHC, HaskellSuite) +-- +-- | This represents language extensions beyond a base 'Language' definition +-- (such as 'Haskell98') that are supported by some implementations, usually +-- in some special mode. +-- +-- Where applicable, references are given to an implementation's +-- official documentation. + +data Extension = + -- | Enable a known extension + EnableExtension KnownExtension + + -- | Disable a known extension + | DisableExtension KnownExtension + + -- | An unknown extension, identified by the name of its @LANGUAGE@ + -- pragma. + | UnknownExtension String + + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) + +instance Binary Extension + +data KnownExtension = + + -- | Allow overlapping class instances, provided there is a unique + -- most specific instance for each use. + -- + -- * + OverlappingInstances + + -- | Ignore structural rules guaranteeing the termination of class + -- instance resolution. Termination is guaranteed by a fixed-depth + -- recursion stack, and compilation may fail if this depth is + -- exceeded. + -- + -- * + | UndecidableInstances + + -- | Implies 'OverlappingInstances'. Allow the implementation to + -- choose an instance even when it is possible that further + -- instantiation of types will lead to a more specific instance + -- being applicable. + -- + -- * + | IncoherentInstances + + -- | /(deprecated)/ Allow recursive bindings in @do@ blocks, using the @rec@ + -- keyword. See also 'RecursiveDo'. + | DoRec + + -- | Allow recursive bindings using @mdo@, a variant of @do@. + -- @DoRec@ provides a different, preferred syntax. + -- + -- * + | RecursiveDo + + -- | Provide syntax for writing list comprehensions which iterate + -- over several lists together, like the 'zipWith' family of + -- functions. + -- + -- * + | ParallelListComp + + -- | Allow multiple parameters in a type class. + -- + -- * + | MultiParamTypeClasses + + -- | Enable the dreaded monomorphism restriction. + -- + -- * + | MonomorphismRestriction + + -- | Allow a specification attached to a multi-parameter type class + -- which indicates that some parameters are entirely determined by + -- others. The implementation will check that this property holds + -- for the declared instances, and will use this property to reduce + -- ambiguity in instance resolution. + -- + -- * + | FunctionalDependencies + + -- | Like 'RankNTypes' but does not allow a higher-rank type to + -- itself appear on the left of a function arrow. + -- + -- * + | Rank2Types + + -- | Allow a universally-quantified type to occur on the left of a + -- function arrow. + -- + -- * + | RankNTypes + + -- | Allow data constructors to have polymorphic arguments. Unlike + -- 'RankNTypes', does not allow this for ordinary functions. + -- + -- * + | PolymorphicComponents + + -- | Allow existentially-quantified data constructors. + -- + -- * + | ExistentialQuantification + + -- | Cause a type variable in a signature, which has an explicit + -- @forall@ quantifier, to scope over the definition of the + -- accompanying value declaration. + -- + -- * + | ScopedTypeVariables + + -- | Deprecated, use 'ScopedTypeVariables' instead. + | PatternSignatures + + -- | Enable implicit function parameters with dynamic scope. + -- + -- * + | ImplicitParams + + -- | Relax some restrictions on the form of the context of a type + -- signature. + -- + -- * + | FlexibleContexts + + -- | Relax some restrictions on the form of the context of an + -- instance declaration. + -- + -- * + | FlexibleInstances + + -- | Allow data type declarations with no constructors. + -- + -- * + | EmptyDataDecls + + -- | Run the C preprocessor on Haskell source code. + -- + -- * + | CPP + + -- | Allow an explicit kind signature giving the kind of types over + -- which a type variable ranges. + -- + -- * + | KindSignatures + + -- | Enable a form of pattern which forces evaluation before an + -- attempted match, and a form of strict @let@/@where@ binding. + -- + -- * + | BangPatterns + + -- | Allow type synonyms in instance heads. + -- + -- * + | TypeSynonymInstances + + -- | Enable Template Haskell, a system for compile-time + -- metaprogramming. + -- + -- * + | TemplateHaskell + + -- | Enable the Foreign Function Interface. In GHC, implements the + -- standard Haskell 98 Foreign Function Interface Addendum, plus + -- some GHC-specific extensions. + -- + -- * + | ForeignFunctionInterface + + -- | Enable arrow notation. + -- + -- * + | Arrows + + -- | /(deprecated)/ Enable generic type classes, with default instances defined in + -- terms of the algebraic structure of a type. + -- + -- * + | Generics + + -- | Enable the implicit importing of the module "Prelude". When + -- disabled, when desugaring certain built-in syntax into ordinary + -- identifiers, use whatever is in scope rather than the "Prelude" + -- -- version. + -- + -- * + | ImplicitPrelude + + -- | Enable syntax for implicitly binding local names corresponding + -- to the field names of a record. Puns bind specific names, unlike + -- 'RecordWildCards'. + -- + -- * + | NamedFieldPuns + + -- | Enable a form of guard which matches a pattern and binds + -- variables. + -- + -- * + | PatternGuards + + -- | Allow a type declared with @newtype@ to use @deriving@ for any + -- class with an instance for the underlying type. + -- + -- * + | GeneralizedNewtypeDeriving + + -- | Enable the \"Trex\" extensible records system. + -- + -- * + | ExtensibleRecords + + -- | Enable type synonyms which are transparent in some definitions + -- and opaque elsewhere, as a way of implementing abstract + -- datatypes. + -- + -- * + | RestrictedTypeSynonyms + + -- | Enable an alternate syntax for string literals, + -- with string templating. + -- + -- * + | HereDocuments + + -- | Allow the character @#@ as a postfix modifier on identifiers. + -- Also enables literal syntax for unboxed values. + -- + -- * + | MagicHash + + -- | Allow data types and type synonyms which are indexed by types, + -- i.e. ad-hoc polymorphism for types. + -- + -- * + | TypeFamilies + + -- | Allow a standalone declaration which invokes the type class + -- @deriving@ mechanism. + -- + -- * + | StandaloneDeriving + + -- | Allow certain Unicode characters to stand for certain ASCII + -- character sequences, e.g. keywords and punctuation. + -- + -- * + | UnicodeSyntax + + -- | Allow the use of unboxed types as foreign types, e.g. in + -- @foreign import@ and @foreign export@. + -- + -- * + | UnliftedFFITypes + + -- | Enable interruptible FFI. + -- + -- * + | InterruptibleFFI + + -- | Allow use of CAPI FFI calling convention (@foreign import capi@). + -- + -- * + | CApiFFI + + -- | Defer validity checking of types until after expanding type + -- synonyms, relaxing the constraints on how synonyms may be used. + -- + -- * + | LiberalTypeSynonyms + + -- | Allow the name of a type constructor, type class, or type + -- variable to be an infix operator. + | TypeOperators + + -- | Enable syntax for implicitly binding local names corresponding + -- to the field names of a record. A wildcard binds all unmentioned + -- names, unlike 'NamedFieldPuns'. + -- + -- * + | RecordWildCards + + -- | Deprecated, use 'NamedFieldPuns' instead. + | RecordPuns + + -- | Allow a record field name to be disambiguated by the type of + -- the record it's in. + -- + -- * + | DisambiguateRecordFields + + -- | Enable traditional record syntax (as supported by Haskell 98) + -- + -- * + | TraditionalRecordSyntax + + -- | Enable overloading of string literals using a type class, much + -- like integer literals. + -- + -- * + | OverloadedStrings + + -- | Enable generalized algebraic data types, in which type + -- variables may be instantiated on a per-constructor basis. Implies + -- 'GADTSyntax'. + -- + -- * + | GADTs + + -- | Enable GADT syntax for declaring ordinary algebraic datatypes. + -- + -- * + | GADTSyntax + + -- | Make pattern bindings monomorphic. + -- + -- * + | MonoPatBinds + + -- | Relax the requirements on mutually-recursive polymorphic + -- functions. + -- + -- * + | RelaxedPolyRec + + -- | Allow default instantiation of polymorphic types in more + -- situations. + -- + -- * + | ExtendedDefaultRules + + -- | Enable unboxed tuples. + -- + -- * + | UnboxedTuples + + -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and + -- 'Data.Generics.Data'. + -- + -- * + | DeriveDataTypeable + + -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'. + -- + -- * + | DeriveGeneric + + -- | Enable support for default signatures. + -- + -- * + | DefaultSignatures + + -- | Allow type signatures to be specified in instance declarations. + -- + -- * + | InstanceSigs + + -- | Allow a class method's type to place additional constraints on + -- a class type variable. + -- + -- * + | ConstrainedClassMethods + + -- | Allow imports to be qualified by the package name the module is + -- intended to be imported from, e.g. + -- + -- > import "network" Network.Socket + -- + -- * + | PackageImports + + -- | /(deprecated)/ Allow a type variable to be instantiated at a + -- polymorphic type. + -- + -- * + | ImpredicativeTypes + + -- | /(deprecated)/ Change the syntax for qualified infix operators. + -- + -- * + | NewQualifiedOperators + + -- | Relax the interpretation of left operator sections to allow + -- unary postfix operators. + -- + -- * + | PostfixOperators + + -- | Enable quasi-quotation, a mechanism for defining new concrete + -- syntax for expressions and patterns. + -- + -- * + | QuasiQuotes + + -- | Enable generalized list comprehensions, supporting operations + -- such as sorting and grouping. + -- + -- * + | TransformListComp + + -- | Enable monad comprehensions, which generalise the list + -- comprehension syntax to work for any monad. + -- + -- * + | MonadComprehensions + + -- | Enable view patterns, which match a value by applying a + -- function and matching on the result. + -- + -- * + | ViewPatterns + + -- | Allow concrete XML syntax to be used in expressions and patterns, + -- as per the Haskell Server Pages extension language: + -- . The ideas behind it are + -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\" + -- by Niklas Broberg, from Haskell Workshop '05. + | XmlSyntax + + -- | Allow regular pattern matching over lists, as discussed in the + -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre + -- and Josef Svenningsson, from ICFP '04. + | RegularPatterns + + -- | Enable the use of tuple sections, e.g. @(, True)@ desugars into + -- @\x -> (x, True)@. + -- + -- * + | TupleSections + + -- | Allow GHC primops, written in C--, to be imported into a Haskell + -- file. + | GHCForeignImportPrim + + -- | Support for patterns of the form @n + k@, where @k@ is an + -- integer literal. + -- + -- * + | NPlusKPatterns + + -- | Improve the layout rule when @if@ expressions are used in a @do@ + -- block. + | DoAndIfThenElse + + -- | Enable support for multi-way @if@-expressions. + -- + -- * + | MultiWayIf + + -- | Enable support lambda-@case@ expressions. + -- + -- * + | LambdaCase + + -- | Makes much of the Haskell sugar be desugared into calls to the + -- function with a particular name that is in scope. + -- + -- * + | RebindableSyntax + + -- | Make @forall@ a keyword in types, which can be used to give the + -- generalisation explicitly. + -- + -- * + | ExplicitForAll + + -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in + -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. + -- + -- * + | DatatypeContexts + + -- | Local (@let@ and @where@) bindings are monomorphic. + -- + -- * + | MonoLocalBinds + + -- | Enable @deriving@ for the 'Data.Functor.Functor' class. + -- + -- * + | DeriveFunctor + + -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class. + -- + -- * + | DeriveTraversable + + -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class. + -- + -- * + | DeriveFoldable + + -- | Enable non-decreasing indentation for @do@ blocks. + -- + -- * + | NondecreasingIndentation + + -- | Allow imports to be qualified with a safe keyword that requires + -- the imported module be trusted as according to the Safe Haskell + -- definition of trust. + -- + -- > import safe Network.Socket + -- + -- * + | SafeImports + + -- | Compile a module in the Safe, Safe Haskell mode -- a restricted + -- form of the Haskell language to ensure type safety. + -- + -- * + | Safe + + -- | Compile a module in the Trustworthy, Safe Haskell mode -- no + -- restrictions apply but the module is marked as trusted as long as + -- the package the module resides in is trusted. + -- + -- * + | Trustworthy + + -- | Compile a module in the Unsafe, Safe Haskell mode so that + -- modules compiled using Safe, Safe Haskell mode can't import it. + -- + -- * + | Unsafe + + -- | Allow type class/implicit parameter/equality constraints to be + -- used as types with the special kind constraint. Also generalise + -- the @(ctxt => ty)@ syntax so that any type of kind constraint can + -- occur before the arrow. + -- + -- * + | ConstraintKinds + + -- | Enable kind polymorphism. + -- + -- * + | PolyKinds + + -- | Enable datatype promotion. + -- + -- * + | DataKinds + + -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/. + -- + -- * + | ParallelArrays + + -- | Enable explicit role annotations, like in (@type role Foo representational representational@). + -- + -- * + | RoleAnnotations + + -- | Enable overloading of list literals, arithmetic sequences and + -- list patterns using the 'IsList' type class. + -- + -- * + | OverloadedLists + + -- | Enable case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled. + -- + -- * + | EmptyCase + + -- | Triggers the generation of derived 'Typeable' instances for every + -- datatype and type class declaration. + -- + -- * + | AutoDeriveTypeable + + -- | Desugars negative literals directly (without using negate). + -- + -- * + | NegativeLiterals + + -- | Allow the use of binary integer literal syntax (e.g. @0b11001001@ to denote @201@). + -- + -- * + | BinaryLiterals + + -- | Allow the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'. + -- + -- * + | NumDecimals + + -- | Enable support for type classes with no type parameter. + -- + -- * + | NullaryTypeClasses + + -- | Enable explicit namespaces in module import/export lists. + -- + -- * + | ExplicitNamespaces + + -- | Allow the user to write ambiguous types, and the type inference engine to infer them. + -- + -- * + | AllowAmbiguousTypes + + -- | Enable @foreign import javascript@. + | JavaScriptFFI + + -- | Allow giving names to and abstracting over patterns. + -- + -- * + | PatternSynonyms + + -- | Allow anonymous placeholders (underscore) inside type signatures. The + -- type inference engine will generate a message describing the type inferred + -- at the hole's location. + -- + -- * + | PartialTypeSignatures + + -- | Allow named placeholders written with a leading underscore inside type + -- signatures. Wildcards with the same name unify to the same type. + -- + -- * + | NamedWildCards + + -- | Enable @deriving@ for any class. + -- + -- * + | DeriveAnyClass + + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data) + +instance Binary KnownExtension + +{-# DEPRECATED knownExtensions + "KnownExtension is an instance of Enum and Bounded, use those instead." #-} +knownExtensions :: [KnownExtension] +knownExtensions = [minBound..maxBound] + +-- | Extensions that have been deprecated, possibly paired with another +-- extension that replaces it. +-- +deprecatedExtensions :: [(Extension, Maybe Extension)] +deprecatedExtensions = + [ (EnableExtension RecordPuns, Just (EnableExtension NamedFieldPuns)) + , (EnableExtension PatternSignatures, Just (EnableExtension ScopedTypeVariables)) + ] +-- NOTE: when adding deprecated extensions that have new alternatives +-- we must be careful to make sure that the deprecation messages are +-- valid. We must not recommend aliases that cannot be used with older +-- compilers, perhaps by adding support in Cabal to translate the new +-- name to the old one for older compilers. Otherwise we are in danger +-- of the scenario in ticket #689. + +instance Text Extension where + disp (UnknownExtension other) = Disp.text other + disp (EnableExtension ke) = Disp.text (show ke) + disp (DisableExtension ke) = Disp.text ("No" ++ show ke) + + parse = do + extension <- Parse.munch1 Char.isAlphaNum + return (classifyExtension extension) + +instance Text KnownExtension where + disp ke = Disp.text (show ke) + + parse = do + extension <- Parse.munch1 Char.isAlphaNum + case classifyKnownExtension extension of + Just ke -> + return ke + Nothing -> + fail ("Can't parse " ++ show extension ++ " as KnownExtension") + +classifyExtension :: String -> Extension +classifyExtension string + = case classifyKnownExtension string of + Just ext -> EnableExtension ext + Nothing -> + case string of + 'N':'o':string' -> + case classifyKnownExtension string' of + Just ext -> DisableExtension ext + Nothing -> UnknownExtension string + _ -> UnknownExtension string + +-- | 'read' for 'KnownExtension's is really really slow so for the Text +-- instance +-- what we do is make a simple table indexed off the first letter in the +-- extension name. The extension names actually cover the range @'A'-'Z'@ +-- pretty densely and the biggest bucket is 7 so it's not too bad. We just do +-- a linear search within each bucket. +-- +-- This gives an order of magnitude improvement in parsing speed, and it'll +-- also allow us to do case insensitive matches in future if we prefer. +-- +classifyKnownExtension :: String -> Maybe KnownExtension +classifyKnownExtension "" = Nothing +classifyKnownExtension string@(c : _) + | inRange (bounds knownExtensionTable) c + = lookup string (knownExtensionTable ! c) + | otherwise = Nothing + +knownExtensionTable :: Array Char [(String, KnownExtension)] +knownExtensionTable = + accumArray (flip (:)) [] ('A', 'Z') + [ (head str, (str, extension)) + | extension <- [toEnum 0 ..] + , let str = show extension ] diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,182 @@ +The Cabal library package +========================= + +See the [Cabal web site] for more information. + +If you also want the `cabal` command-line program, you need the +[cabal-install] package in addition to this library. + +[cabal-install]: ../cabal-install/README.md + +Installing the Cabal library +============================ + +If you already have the `cabal` program +--------------------------------------- + +In this case run: + + $ cabal install + +However, if you do not have an existing version of the `cabal` program, +you first must install the Cabal library. To avoid this bootstrapping +problem, you can install the Cabal library directly as described below. + + +Installing as a user (no root or administrator access) +------------------------------------------------------ + + ghc -threaded --make Setup + ./Setup configure --user + ./Setup build + ./Setup install + +Note the use of the `--user` flag at the configure step. + +Compiling 'Setup' rather than using `runghc Setup` is much faster and +works on Windows. For all packages other than Cabal itself, it is fine +to use `runghc`. + +This will install into `$HOME/.cabal/` on Unix and into +`Documents and Settings\$User\Application Data\cabal\` on Windows. +If you want to install elsewhere, use the `--prefix=` flag at the +configure step. + + +Installing as root or Administrator +----------------------------------- + + ghc -threaded --make Setup + ./Setup configure + ./Setup build + sudo ./Setup install + +Compiling Setup rather than using `runghc Setup` is much faster and +works on Windows. For all packages other than Cabal itself, it is fine +to use `runghc`. + +This will install into `/usr/local` on Unix, and on Windows it will +install into `$ProgramFiles/Haskell`. If you want to install elsewhere, +use the `--prefix=` flag at the configure step. + + +Using older versions of GHC and Cabal +====================================== + +It is recommended that you leave any pre-existing version of Cabal +installed. In particular, it is *essential* you keep the version that +came with GHC itself, since other installed packages require it (for +instance, the "ghc" API package). + +Prior to GHC 6.4.2, however, GHC did not deal particularly well with +having multiple versions of packages installed at once. So if you are +using GHC 6.4.1 or older and you have an older version of Cabal +installed, you should probably remove it by running: + + $ ghc-pkg unregister Cabal + +or, if you had Cabal installed only for your user account, run: + + $ ghc-pkg unregister Cabal --user + +The `filepath` dependency +========================= + +Cabal uses the [filepath] package, so it must be installed first. +GHC version 6.6.1 and later come with `filepath`, however, earlier +versions do not by default. If you do not already have `filepath`, +you need to install it. You can use any existing version of Cabal to do +that. If you have neither Cabal nor `filepath`, it is slightly +harder but still possible. + +Unpack Cabal and `filepath` into separate directories. For example: + + tar -xzf filepath-1.1.0.0.tar.gz + tar -xzf Cabal-1.6.0.0.tar.gz + + # rename to make the following instructions simpler: + mv filepath-1.1.0.0/ filepath/ + mv Cabal-1.6.0.0/ Cabal/ + + cd Cabal + ghc -i../filepath -cpp --make Setup.hs -o ../filepath/setup + cd ../filepath/ + ./setup configure --user + ./setup build + ./setup install + +This installs `filepath` so that you can install Cabal with the normal +method. + +[filepath]: http://hackage.haskell.org/package/filepath + +More information +================ + +Please see the [Cabal web site] for the [user guide] and [API +documentation]. There is additional information available on the +[development wiki]. + +[user guide]: http://www.haskell.org/cabal/users-guide +[API documentation]: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html +[development wiki]: https://github.com/haskell/cabal/wiki + + +Bugs +==== + +Please report bugs and feature requests to Cabal's [bug tracker]. + + +Your help +--------- + +To help Cabal's development, it is enormously helpful to know from +Cabal's users what their most pressing problems are with Cabal and +[Hackage]. You may have a favourite Cabal bug or limitation. Look at +Cabal's [bug tracker]. Ensure that the problem is reported there and +adequately described. Comment on the issue to report how much of a +problem the bug is for you. Subscribe to the issues's notifications to +discussed requirements and keep informed on progress. For feature +requests, it is helpful if there is a description of how you would +expect to interact with the new feature. + +[Hackage]: http://hackage.haskell.org + + +Source code +=========== + +You can get the master development branch using: + + $ git clone https://github.com/haskell/cabal.git + + +Credits +======= + +Cabal developers (in alphabetical order): + +- Krasimir Angelov +- Bjorn Bringert +- Duncan Coutts +- Isaac Jones +- David Himmelstrup ("Lemmih") +- Simon Marlow +- Ross Patterson +- Thomas Schilling +- Martin Sjögren +- Malcolm Wallace +- and nearly 30 other people have contributed occasional patches + +Cabal specification authors: + +- Isaac Jones +- Simon Marlow +- Ross Patterson +- Simon Peyton Jones +- Malcolm Wallace + + +[bug tracker]: https://github.com/haskell/cabal/issues +[Cabal web site]: http://www.haskell.org/cabal/ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,10 @@ +import Distribution.Simple +main :: IO () +main = defaultMain + +-- Although this looks like the Simple build type, it is in fact vital that +-- we use this Setup.hs because it'll get compiled against the local copy +-- of the Cabal lib, thus enabling Cabal to bootstrap itself without relying +-- on any previous installation. This also means we can use any new features +-- immediately because we never have to worry about building Cabal with an +-- older version of itself. diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,443 @@ +-*-change-log-*- + +1.22.0.0 Johan Tibell January 2015 + * Support GHC 7.10. + * Experimental support for emitting DWARF debug info. + * Preliminary support for relocatable packages. + * Allow cabal to be used inside cabal exec enviroments. + * hpc: support mutliple "ways" (e.g. profiling and vanilla). + * Support GHCJS. + * Improved command line documentation. + * Add '-none' constraint syntax for version ranges (#2093). + * Make the default doc index file path compiler/arch/os-dependent + (#2136). + * Warn instead of dying when generating documentation and hscolour + isn't installed (455f51622fa38347db62197a04bb0fa5b928ff17). + * Support the new BinaryLiterals extension + (1f25ab3c5eff311ada73c6c987061b80e9bbebd9). + * Warn about 'ghc-prof-options: -auto-all' in 'cabal check' (#2162). + * Add preliminary support for multiple instances of the same package + version installed side-by-side (#2002). + * New binary build config format - faster build times (#2076). + * Support module thinning and renaming (#2038). + * Add a new license type: UnspecifiedLicense (#2141). + * Remove support for Hugs and nhc98 (#2168). + * Invoke 'tar' with '--formar ustar' if possible in 'sdist' (#1903). + * Replace --enable-library-coverage with --enable-coverage, which + enables program coverage for all components (#1945). + * Suggest that `ExitFailure 9` is probably due to memory + exhaustion (#1522). + * Drop support for Haddock < 2.0 (#1808, #1718). + * Make 'cabal test'/'cabal bench' build only what's needed for + running tests/benchmarks (#1821). + * Build shared libraries by default when linking executables dynamically. + * Build profiled libraries by default when profiling executables. + +1.20.0.1 Johan Tibell May 2014 + * Fix streaming test output. + +1.20.0.0 Johan Tibell April 2014 + * Rewrite user guide + * Fix repl Ctrl+C handling + * Add haskell-suite compiler support + * Add __HADDOCK_VERSION__ define + * Allow specifying exact dependency version using hash + * Rename extra-html-files to extra-doc-files + * Add parallel build support for GHC 7.8 and later + * Don't call ranlib on OS X + * Avoid re-linking executables, test suites, and benchmarks + unnecessarily, shortening build times + * Add --allow-newer which allows upper version bounds to be + ignored + * Add --enable-library-stripping + * Add command for freezing dependencies + * Allow repl to be used outside Cabal packages + * Add --require-sandbox + * Don't use --strip-unneeded on OS X or iOS + * Add new license-files field got additional licenses + * Fix if(solaris) on some Solaris versions + * Don't use -dylib-install-name on OS X with GHC > 7.8 + * Add DragonFly as a known OS + * Improve pretty-printing of Cabal files + * Add test flag --show-details=streaming for real-time test output + * Add exec command + +1.10.2.0 Duncan Coutts June 2011 + * Include test suites in cabal sdist + * Fix for conditionals in test suite stanzas in .cabal files + * Fix permissions of directories created during install + * Fix for global builds when $HOME env var is not set + +1.10.1.0 Duncan Coutts February 2011 + * Improved error messages when test suites are not enabled + * Template parameters allowed in test --test-option(s) flag + * Improved documentation of the test feature + * Relaxed QA check on cabal-version when using test-suite sections + * haddock command now allows both --hoogle and --html at the same time + * Find ghc-version-specific instances of the hsc2hs program + * Preserve file executable permissions in sdist tarballs + * Pass gcc location and flags to ./configure scripts + * Get default gcc flags from ghc + +1.10.0.0 Duncan Coutts November 2010 + * New cabal test feature + * Initial support for UHC + * New default-language and other-languages fields (e.g. Haskell98/2010) + * New default-extensions and other-extensions fields + * Deprecated extensions field (for packages using cabal-version >=1.10) + * Cabal-version field must now only be of the form ">= x.y" + * Removed deprecated --copy-prefix= feature + * Auto-reconfigure when .cabal file changes + * Workaround for haddock overwriting .hi and .o files when using TH + * Extra cpp flags used with hsc2hs and c2hs (-D${os}_BUILD_OS etc) + * New cpp define VERSION_ gives string version of dependencies + * User guide source now in markdown format for easier editing + * Improved checks and error messages for C libraries and headers + * Removed BSD4 from the list of suggested licenses + * Updated list of known language extensions + * Fix for include paths to allow C code to import FFI stub.h files + * Fix for intra-package dependencies on OSX + * Stricter checks on various bits of .cabal file syntax + * Minor fixes for c2hs + +1.8.0.6 Duncan Coutts June 2010 + * Fix 'register --global/--user' + +1.8.0.4 Duncan Coutts March 2010 + * Set dylib-install-name for dynalic libs on OSX + * Stricter configure check that compiler supports a package's extensions + * More configure-time warnings + * Hugs can compile Cabal lib again + * Default datadir now follows prefix on Windows + * Support for finding installed packages for hugs + * Cabal version macros now have proper parenthesis + * Reverted change to filter out deps of non-buildable components + * Fix for registering implace when using a specific package db + * Fix mismatch between $os and $arch path template variables + * Fix for finding ar.exe on Windows, always pick ghc's version + * Fix for intra-package dependencies with ghc-6.12 + +1.8.0.2 Duncan Coutts December 2009 + * Support for GHC-6.12 + * New unique installed package IDs which use a package hash + * Allow executables to depend on the lib within the same package + * Dependencies for each component apply only to that component + (previously applied to all the other components too) + * Added new known license MIT and versioned GPL and LGPL + * More liberal package version range syntax + * Package registration files are now UTF8 + * Support for LHC and JHC-0.7.2 + * Deprecated RecordPuns extension in favour of NamedFieldPuns + * Deprecated PatternSignatures extension in favor of ScopedTypeVariables + * New VersionRange semantic view as a sequence of intervals + * Improved package quality checks + * Minor simplification in a couple Setup.hs hooks + * Beginnings of a unit level testsuite using QuickCheck + * Various bug fixes + * Various internal cleanups + +1.6.0.2 Duncan Coutts February 2009 + * New configure-time check for C headers and libraries + * Added language extensions present in ghc-6.10 + * Added support for NamedFieldPuns extension in ghc-6.8 + * Fix in configure step for ghc-6.6 on Windows + * Fix warnings in Path_pkgname.hs module on Windows + * Fix for exotic flags in ld-options field + * Fix for using pkg-config in a package with a lib and an executable + * Fix for building haddock docs for exes that use the Paths module + * Fix for installing header files in subdirectories + * Fix for the case of building profiling libs but not ordinary libs + * Fix read-only attribute of installed files on Windows + * Ignore ghc -threaded flag when profiling in ghc-6.8 and older + +1.6.0.1 Duncan Coutts October 2008 + * Export a compat function to help alex and happy + +1.6.0.0 Duncan Coutts October 2008 + * Support for ghc-6.10 + * Source control repositories can now be specified in .cabal files + * Bug report URLs can be now specified in .cabal files + * Wildcards now allowed in data-files and extra-source-files fields + * New syntactic sugar for dependencies "build-depends: foo ==1.2.*" + * New cabal_macros.h provides macros to test versions of dependencies + * Relocatable bindists now possible on unix via env vars + * New 'exposed' field allows packages to be not exposed by default + * Install dir flags can now use $os and $arch variables + * New --builddir flag allows multiple builds from a single sources dir + * cc-options now only apply to .c files, not for -fvia-C + * cc-options are not longer propagated to dependent packages + * The cpp/cc/ld-options fields no longer use ',' as a separator + * hsc2hs is now called using gcc instead of using ghc as gcc + * New api for manipulating sets and graphs of packages + * Internal api improvements and code cleanups + * Minor improvements to the user guide + * Miscellaneous minor bug fixes + +1.4.0.2 Duncan Coutts August 2008 + * Fix executable stripping default + * Fix striping exes on OSX that export dynamic symbols (like ghc) + * Correct the order of arguments given by --prog-options= + * Fix corner case with overlapping user and global packages + * Fix for modules that use pre-processing and .hs-boot files + * Clarify some points in the user guide and readme text + * Fix verbosity flags passed to sub-command like haddock + * Fix sdist --snapshot + * Allow meta-packages that contain no modules or C code + * Make the generated Paths module -Wall clean on Windows + +1.4.0.1 Duncan Coutts June 2008 + * Fix a bug which caused '.' to always be in the sources search path + * Haddock-2.2 and later do now support the --hoogle flag + +1.4.0.0 Duncan Coutts June 2008 + * Rewritten command line handling support + * Command line completion with bash + * Better support for Haddock 2 + * Improved support for nhc98 + * Removed support for ghc-6.2 + * Haddock markup in .lhs files now supported + * Default colour scheme for highlighted source code + * Default prefix for --user installs is now $HOME/.cabal + * All .cabal files are treaded as UTF-8 and must be valid + * Many checks added for common mistakes + * New --package-db= option for specific package databases + * Many internal changes to support cabal-install + * Stricter parsing for version strings, eg dissalows "1.05" + * Improved user guide introduction + * Programatica support removed + * New options --program-prefix/suffix allows eg versioned programs + * Support packages that use .hs-boot files + * Fix sdist for Main modules that require preprocessing + * New configure -O flag with optimisation level 0--2 + * Provide access to "x-" extension fields through the Cabal api + * Added check for broken installed packages + * Added warning about using inconsistent versions of dependencies + * Strip binary executable files by default with an option to disable + * New options to add site-specific include and library search paths + * Lift the restriction that libraries must have exposed-modules + * Many bugs fixed. + * Many internal structural improvements and code cleanups + +1.2.4.0 Duncan Coutts June 2008 + * Released with GHC 6.8.3 + * Backported several fixes and minor improvements from Cabal-1.4 + * Use a default colour scheme for sources with hscolour >=1.9 + * Support --hyperlink-source for Haddock >= 2.0 + * Fix for running in a non-writable directory + * Add OSX -framework arguments when linking executables + * Updates to the user guide + * Allow build-tools names to include + and _ + * Export autoconfUserHooks and simpleUserHooks + * Export ccLdOptionsBuildInfo for Setup.hs scripts + * Export unionBuildInfo and make BuildInfo an instance of Monoid + * Fix to allow the 'main-is' module to use a pre-processor + +1.2.3.0 Duncan Coutts Nov 2007 + * Released with GHC 6.8.2 + * Includes full list of GHC language extensions + * Fix infamous "dist/conftest.c" bug + * Fix configure --interfacedir= + * Find ld.exe on Windows correctly + * Export PreProcessor constructor and mkSimplePreProcessor + * Fix minor bug in unlit code + * Fix some markup in the haddock docs + +1.2.2.0 Duncan Coutts Nov 2007 + * Released with GHC 6.8.1 + * Support haddock-2.0 + * Support building DSOs with GHC + * Require reconfiguring if the .cabal file has changed + * Fix os(windows) configuration test + * Fix building documentation + * Fix building packages on Solaris + * Other minor bug fixes + +1.2.1 Duncan Coutts Oct 2007 + * To be included in GHC 6.8.1 + * New field "cpp-options" used when preprocessing Haskell modules + * Fixes for hsc2hs when using ghc + * C source code gets compiled with -O2 by default + * OS aliases, to allow os(windows) rather than requiring os(mingw32) + * Fix cleaning of 'stub' files + * Fix cabal-setup, command line ui that replaces "runhaskell Setup.hs" + * Build docs even when dependent packages docs are missing + * Allow the --html-dir to be specified at configure time + * Fix building with ghc-6.2 + * Other minor bug fixes and build fixes + +1.2.0 Duncan Coutts Sept 2007 + * To be included in GHC 6.8.x + * New configurations feature + * Can make haddock docs link to hilighted sources (with hscolour) + * New flag to allow linking to haddock docs on the web + * Supports pkg-config + * New field "build-tools" for tool dependencies + * Improved c2hs support + * Preprocessor output no longer clutters source dirs + * Separate "includes" and "install-includes" fields + * Makefile command to generate makefiles for building libs with GHC + * New --docdir configure flag + * Generic --with-prog --prog-args configure flags + * Better default installation paths on Windows + * Install paths can be specified relative to each other + * License files now installed + * Initial support for NHC (incomplete) + * Consistent treatment of verbosity + * Reduced verbosity of configure step by default + * Improved helpfulness of output messages + * Help output now clearer and fits in 80 columns + * New setup register --gen-pkg-config flag for distros + * Major internal refactoring, hooks api has changed + * Dozens of bug fixes + +1.1.6.2 Duncan Coutts May 2007 + * Released with GHC 6.6.1 + * Handle windows text file encoding for .cabal files + * Fix compiling a executable for profiling that uses Template Haskell + * Other minor bug fixes and user guide clarifications + +1.1.6.1 Duncan Coutts Oct 2006 + * fix unlit code + * fix escaping in register.sh + +1.1.6 Duncan Coutts Oct 2006 + * Released with GHC 6.6 + * Added support for hoogle + * Allow profiling and normal builds of libs to be chosen indepentantly + * Default installation directories on Win32 changed + * Register haddock docs with ghc-pkg + * Get haddock to make hyperlinks to dependent package docs + * Added BangPatterns language extension + * Various bug fixes + +1.1.4 Duncan Coutts May 2006 + * Released with GHC 6.4.2 + * Better support for packages that need to install header files + * cabal-setup added, but not installed by default yet + * Implemented "setup register --inplace" + * Have packages exposed by default with ghc-6.2 + * It is no longer necessary to run 'configure' before 'clean' or 'sdist' + * Added support for ghc's -split-objs + * Initial support for JHC + * Ignore extension fields in .cabal files (fields begining with "x-") + * Some changes to command hooks API to improve consistency + * Hugs support improvements + * Added GeneralisedNewtypeDeriving language extension + * Added cabal-version field + * Support hidden modules with haddock + * Internal code refactoring + * More bug fixes + +1.1.3 Isaac Jones Sept 2005 + * WARNING: Interfaces not documented in the user's guide may + change in future releases. + * Move building of GHCi .o libs to the build phase rather than + register phase. (from Duncan Coutts) + * Use .tar.gz for source package extension + * Uses GHC instead of cpphs if the latter is not available + * Added experimental "command hooks" which completely override the + default behavior of a command. + * Some bugfixes + +1.1.1 Isaac Jones July 2005 + * WARNING: Interfaces not documented in the user's guide may + change in future releases. + * Handles recursive modules for GHC 6.2 and GHC 6.4. + * Added "setup test" command (Used with UserHook) + * implemented handling of _stub.{c,h,o} files + * Added support for profiling + * Changed install prefix of libraries (pref/pkgname-version + to prefix/pkgname-version/compname-version) + * Added pattern guards as a language extension + * Moved some functionality to Language.Haskell.Extension + * Register / unregister .bat files for windows + * Exposed more of the API + * Added support for the hide-all-packages flag in GHC > 6.4 + * Several bug fixes + +1.0 Isaac Jones March 11 2005 + * Released with GHC 6.4, Hugs March 2005, and nhc98 1.18 + * Some sanity checking + +0.5 Isaac Jones Wed Feb 19 2005 + * WARNING: this is a pre-release and the interfaces are still + likely to change until we reach a 1.0 release. + * Hooks interfaces changed + * Added preprocessors to user hooks + * No more executable-modules or hidden-modules. Use + "other-modules" instead. + * Certain fields moved into BuildInfo, much refactoring + * extra-libs -> extra-libraries + * Added --gen-script to configure and unconfigure. + * modules-ghc (etc) now ghc-modules (etc) + * added new fields including "synopsis" + * Lots of bug fixes + * spaces can sometimes be used instead of commas + * A user manual has appeared (Thanks, ross!) + * for ghc 6.4, configures versionsed depends properly + * more features to ./setup haddock + +0.4 Isaac Jones Sun Jan 16 2005 + + * Much thanks to all the awesome fptools hackers who have been + working hard to build the Haskell Cabal! + + * Interface Changes: + + ** WARNING: this is a pre-release and the interfaces are still + likely to change until we reach a 1.0 release. + + ** Instead of Package.description, you should name your + description files .cabal. In particular, we suggest + that you name it .cabal, but this is not enforced + (yet). Multiple .cabal files in the same directory is an error, + at least for now. + + ** ./setup install --install-prefix is gone. Use ./setup copy + --copy-prefix instead. + + ** The "Modules" field is gone. Use "hidden-modules", + "exposed-modules", and "executable-modules". + + ** Build-depends is now a package-only field, and can't go into + executable stanzas. Build-depends is a package-to-package + relationship. + + ** Some new fields. Use the Source. + + * New Features + + ** Cabal is now included as a package in the CVS version of + fptools. That means it'll be released as "-package Cabal" in + future versions of the compilers, and if you are a bleeding-edge + user, you can grab it from the CVS repository with the compilers. + + ** Hugs compatibility and NHC98 compatibility should both be + improved. + + ** Hooks Interface / Autoconf compatibility: Most of the hooks + interface is hidden for now, because it's not finalized. I have + exposed only "defaultMainWithHooks" and "defaultUserHooks". This + allows you to use a ./configure script to preprocess + "foo.buildinfo", which gets merged with "foo.cabal". In future + releases, we'll expose UserHooks, but we're definitely going to + change the interface to those. The interface to the two functions + I've exposed should stay the same, though. + + ** ./setup haddock is a baby feature which pre-processes the + source code with hscpp and runs haddock on it. This is brand new + and hardly tested, so you get to knock it around and see what you + think. + + ** Some commands now actually implement verbosity. + + ** The preprocessors have been tested a bit more, and seem to work + OK. Please give feedback if you use these. + +0.3 Isaac Jones Sun Jan 16 2005 + * Unstable snapshot release + * From now on, stable releases are even. + +0.2 Isaac Jones + + * Adds more HUGS support and preprocessor support. diff --git a/doc/developing-packages.markdown b/doc/developing-packages.markdown new file mode 100644 --- /dev/null +++ b/doc/developing-packages.markdown @@ -0,0 +1,2146 @@ +% Cabal User Guide: Developing Cabal packages + + +# Quickstart # + + +Lets assume we have created a project directory and already have a +Haskell module or two. + +Every project needs a name, we'll call this example "proglet". + +~~~~~~~~~~~ +$ cd proglet/ +$ ls +Proglet.hs +~~~~~~~~~~~ + +It is assumed that (apart from external dependencies) all the files that +make up a package live under a common project root directory. This +simple example has all the project files in one directory, but most +packages will use one or more subdirectories. + +To turn this into a Cabal package we need two extra files in the +project's root directory: + + * `proglet.cabal`: containing package metadata and build information. + + * `Setup.hs`: usually containing a few standardized lines of code, but + can be customized if necessary. + +We can create both files manually or we can use `cabal init` to create +them for us. + +### Using "cabal init" ### + +The `cabal init` command is interactive. It asks us a number of +questions starting with the package name and version. + +~~~~~~~~~~ +$ cabal init +Package name [default "proglet"]? +Package version [default "0.1"]? +... +~~~~~~~~~~ + +It also asks questions about various other bits of package metadata. For +a package that you never intend to distribute to others, these fields can +be left blank. + +One of the important questions is whether the package contains a library +or an executable. Libraries are collections of Haskell modules that can +be re-used by other Haskell libraries and programs, while executables +are standalone programs. + +~~~~~~~~~~ +What does the package build: + 1) Library + 2) Executable +Your choice? +~~~~~~~~~~ + +For the moment these are the only choices. For more complex packages +(e.g. a library and multiple executables or test suites) the `.cabal` +file can be edited afterwards. + +Finally, `cabal init` creates the initial `proglet.cabal` and `Setup.hs` +files, and depending on your choice of license, a `LICENSE` file as well. + +~~~~~~~~~~ +Generating LICENSE... +Generating Setup.hs... +Generating proglet.cabal... + +You may want to edit the .cabal file and add a Description field. +~~~~~~~~~~ + +As this stage the `proglet.cabal` is not quite complete and before you +are able to build the package you will need to edit the file and add +some build information about the library or executable. + +### Editing the .cabal file ### + +Load up the `.cabal` file in a text editor. The first part of the +`.cabal` file has the package metadata and towards the end of the file +you will find the `executable` or `library` section. + +You will see that the fields that have yet to be filled in are commented +out. Cabal files use "`--`" Haskell-style comment syntax. (Note that +comments are only allowed on lines on their own. Trailing comments on +other lines are not allowed because they could be confused with program +options.) + +If you selected earlier to create a library package then your `.cabal` +file will have a section that looks like this: + +~~~~~~~~~~~~~~~~~ +library + exposed-modules: Proglet + -- other-modules: + -- build-depends: +~~~~~~~~~~~~~~~~~ + +Alternatively, if you selected an executable then there will be a +section like: + +~~~~~~~~~~~~~~~~~ +executable proglet + -- main-is: + -- other-modules: + -- build-depends: +~~~~~~~~~~~~~~~~~ + +The build information fields listed (but commented out) are just the few +most important and common fields. There are many others that are covered +later in this chapter. + +Most of the build information fields are the same between libraries and +executables. The difference is that libraries have a number of "exposed" +modules that make up the public interface of the library, while +executables have a file containing a `Main` module. + +The name of a library always matches the name of the package, so it is +not specified in the library section. Executables often follow the name +of the package too, but this is not required and the name is given +explicitly. + +### Modules included in the package ### + +For a library, `cabal init` looks in the project directory for files +that look like Haskell modules and adds all the modules to the +`exposed-modules` field. For modules that do not form part of your +package's public interface, you can move those modules to the +`other-modules` field. Either way, all modules in the library need to be +listed. + +For an executable, `cabal init` does not try to guess which file +contains your program's `Main` module. You will need to fill in the +`main-is` field with the file name of your program's `Main` module +(including `.hs` or `.lhs` extension). Other modules included in the +executable should be listed in the `other-modules` field. + +### Modules imported from other packages ### + +While your library or executable may include a number of modules, it +almost certainly also imports a number of external modules from the +standard libraries or other pre-packaged libraries. (These other +libraries are of course just Cabal packages that contain a library.) + +You have to list all of the library packages that your library or +executable imports modules from. Or to put it another way: you have to +list all the other packages that your package depends on. + +For example, suppose the example `Proglet` module imports the module +`Data.Map`. The `Data.Map` module comes from the `containers` package, +so we must list it: + +~~~~~~~~~~~~~~~~~ +library + exposed-modules: Proglet + other-modules: + build-depends: containers, base == 4.* +~~~~~~~~~~~~~~~~~ + +In addition, almost every package also depends on the `base` library +package because it exports the standard `Prelude` module plus other +basic modules like `Data.List`. + +You will notice that we have listed `base == 4.*`. This gives a +constraint on the version of the base package that our package will work +with. The most common kinds of constraints are: + + * `pkgname >= n` + * `pkgname >= n && < m` + * `pkgname == n.*` + +The last is just shorthand, for example `base == 4.*` means exactly the +same thing as `base >= 4 && < 5`. + +### Building the package ### + +For simple packages that's it! We can now try configuring and building +the package: + +~~~~~~~~~~~~~~~~ +cabal configure +cabal build +~~~~~~~~~~~~~~~~ + +Assuming those two steps worked then you can also install the package: + +~~~~~~~~~~~~~~~~ +cabal install +~~~~~~~~~~~~~~~~ + +For libraries this makes them available for use in GHCi or to be used by +other packages. For executables it installs the program so that you can +run it (though you may first need to adjust your system's `$PATH`). + +### Next steps ### + +What we have covered so far should be enough for very simple packages +that you use on your own system. + +The next few sections cover more details needed for more complex +packages and details needed for distributing packages to other people. + +The previous chapter covers building and installing packages -- your own +packages or ones developed by other people. + + +# Package concepts # + +Before diving into the details of writing packages it helps to +understand a bit about packages in the Haskell world and the particular +approach that Cabal takes. + +### The point of packages ### + +Packages are a mechanism for organising and distributing code. Packages +are particularly suited for "programming in the large", that is building +big systems by using and re-using code written by different people at +different times. + +People organise code into packages based on functionality and +dependencies. Social factors are also important: most packages have a +single author, or a relatively small team of authors. + +Packages are also used for distribution: the idea is that a package can +be created in one place and be moved to a different computer and be +usable in that different environment. There are a surprising number of +details that have to be got right for this to work, and a good package +system helps to simply this process and make it reliable. + +Packages come in two main flavours: libraries of reusable code, and +complete programs. Libraries present a code interface, an API, while +programs can be run directly. In the Haskell world, library packages +expose a set of Haskell modules as their public interface. Cabal +packages can contain a library or executables or both. + +Some programming languages have packages as a builtin language concept. +For example in Java, a package provides a local namespace for types and +other definitions. In the Haskell world, packages are not a part of the +language itself. Haskell programs consist of a number of modules, and +packages just provide a way to partition the modules into sets of +related functionality. Thus the choice of module names in Haskell is +still important, even when using packages. + +### Package names and versions ### + +All packages have a name, e.g. "HUnit". Package names are assumed to be +unique. Cabal package names can use letters, numbers and hyphens, but +not spaces. The namespace for Cabal packages is flat, not hierarchical. + +Packages also have a version, e.g "1.1". This matches the typical way in +which packages are developed. Strictly speaking, each version of a +package is independent, but usually they are very similar. Cabal package +versions follow the conventional numeric style, consisting of a sequence +of digits such as "1.0.1" or "2.0". There are a range of common +conventions for "versioning" packages, that is giving some meaning to +the version number in terms of changes in the package. Section [TODO] +has some tips on package versioning. + +The combination of package name and version is called the _package ID_ +and is written with a hyphen to separate the name and version, e.g. +"HUnit-1.1". + +For Cabal packages, the combination of the package name and version +_uniquely_ identifies each package. Or to put it another way: two +packages with the same name and version are considered to _be_ the same. + +Strictly speaking, the package ID only identifies each Cabal _source_ +package; the same Cabal source package can be configured and built in +different ways. There is a separate installed package ID that uniquely +identifies each installed package instance. Most of the time however, +users need not be aware of this detail. + +### Kinds of package: Cabal vs GHC vs system ### + +It can be slightly confusing at first because there are various +different notions of package floating around. Fortunately the details +are not very complicated. + +Cabal packages +: Cabal packages are really source packages. That is they contain + Haskell (and sometimes C) source code. + + Cabal packages can be compiled to produce GHC packages. They can + also be translated into operating system packages. + +GHC packages +: This is GHC's view on packages. GHC only cares about library + packages, not executables. Library packages have to be registered + with GHC for them to be available in GHCi or to be used when + compiling other programs or packages. + + The low-level tool `ghc-pkg` is used to register GHC packages and to + get information on what packages are currently registered. + + You never need to make GHC packages manually. When you build and + install a Cabal package containing a library then it gets registered + with GHC automatically. + + Haskell implementations other than GHC have essentially the same + concept of registered packages. For the most part, Cabal hides the + slight differences. + +Operating system packages +: On operating systems like Linux and Mac OS X, the system has a + specific notion of a package and there are tools for installing and + managing packages. + + The Cabal package format is designed to allow Cabal packages to be + translated, mostly-automatically, into operating system packages. + They are usually translated 1:1, that is a single Cabal package + becomes a single system package. + + It is also possible to make Windows installers from Cabal packages, + though this is typically done for a program together with all of its + library dependencies, rather than packaging each library separately. + + +### Unit of distribution ### + +The Cabal package is the unit of distribution. What this means is that +each Cabal package can be distributed on its own in source or binary +form. Of course there may dependencies between packages, but there is +usually a degree of flexibility in which versions of packages can work +together so distributing them independently makes sense. + +It is perhaps easiest to see what being ``the unit of distribution'' +means by contrast to an alternative approach. Many projects are made up +of several interdependent packages and during development these might +all be kept under one common directory tree and be built and tested +together. When it comes to distribution however, rather than +distributing them all together in a single tarball, it is required that +they each be distributed independently in their own tarballs. + +Cabal's approach is to say that if you can specify a dependency on a +package then that package should be able to be distributed +independently. Or to put it the other way round, if you want to +distribute it as a single unit, then it should be a single package. + + +### Explicit dependencies and automatic package management ### + +Cabal takes the approach that all packages dependencies are specified +explicitly and specified in a declarative way. The point is to enable +automatic package management. This means tools like `cabal` can resolve +dependencies and install a package plus all of its dependencies +automatically. Alternatively, it is possible to mechanically (or mostly +mechanically) translate Cabal packages into system packages and let the +system package manager install dependencies automatically. + +It is important to track dependencies accurately so that packages can +reliably be moved from one system to another system and still be able to +build it there. Cabal is therefore relatively strict about specifying +dependencies. For example Cabal's default build system will not even let +code build if it tries to import a module from a package that isn't +listed in the `.cabal` file, even if that package is actually installed. +This helps to ensure that there are no "untracked dependencies" that +could cause the code to fail to build on some other system. + +The explicit dependency approach is in contrast to the traditional +"./configure" approach where instead of specifying dependencies +declaratively, the `./configure` script checks if the dependencies are +present on the system. Some manual work is required to transform a +`./configure` based package into a Linux distribution package (or +similar). This conversion work is usually done by people other than the +package author(s). The practical effect of this is that only the most +popular packages will benefit from automatic package management. Instead, +Cabal forces the original author to specify the dependencies but the +advantage is that every package can benefit from automatic package +management. + +The "./configure" approach tends to encourage packages that adapt +themselves to the environment in which they are built, for example by +disabling optional features so that they can continue to work when a +particular dependency is not available. This approach makes sense in a +world where installing additional dependencies is a tiresome manual +process and so minimising dependencies is important. The automatic +package management view is that packages should just declare what they +need and the package manager will take responsibility for ensuring that +all the dependencies are installed. + +Sometimes of course optional features and optional dependencies do make +sense. Cabal packages can have optional features and varying +dependencies. These conditional dependencies are still specified in a +declarative way however and remain compatible with automatic package +management. The need to remain compatible with automatic package +management means that Cabal's conditional dependencies system is a bit +less flexible than with the "./configure" approach. + +### Portability ### + +One of the purposes of Cabal is to make it easier to build packages on +different platforms (operating systems and CPU architectures), with +different compiler versions and indeed even with different Haskell +implementations. (Yes, there are Haskell implementations other than +GHC!) + +Cabal provides abstractions of features present in different Haskell +implementations and wherever possible it is best to take advantage of +these to increase portability. Where necessary however it is possible to +use specific features of specific implementations. + +For example a package author can list in the package's `.cabal` what +language extensions the code uses. This allows Cabal to figure out if +the language extension is supported by the Haskell implementation that +the user picks. Additionally, certain language extensions such as +Template Haskell require special handling from the build system and by +listing the extension it provides the build system with enough +information to do the right thing. + +Another similar example is linking with foreign libraries. Rather than +specifying GHC flags directly, the package author can list the libraries +that are needed and the build system will take care of using the right +flags for the compiler. Additionally this makes it easier for tools to +discover what system C libraries a package needs, which is useful for +tracking dependencies on system libraries (e.g. when translating into +Linux distribution packages). + +In fact both of these examples fall into the category of explicitly +specifying dependencies. Not all dependencies are other Cabal packages. +Foreign libraries are clearly another kind of dependency. It's also +possible to think of language extensions as dependencies: the package +depends on a Haskell implementation that supports all those extensions. + +Where compiler-specific options are needed however, there is an "escape +hatch" available. The developer can specify implementation-specific +options and more generally there is a configuration mechanism to +customise many aspects of how a package is built depending on the +Haskell implementation, the operating system, computer architecture and +user-specified configuration flags. + + +# Developing packages # + +The Cabal package is the unit of distribution. When installed, its +purpose is to make available: + + * One or more Haskell programs. + + * At most one library, exposing a number of Haskell modules. + +However having both a library and executables in a package does not work +very well; if the executables depend on the library, they must +explicitly list all the modules they directly or indirectly import from +that library. Fortunately, starting with Cabal 1.8.0.4, executables can +also declare the package that they are in as a dependency, and Cabal +will treat them as if they were in another package that depended on +the library. + +Internally, the package may consist of much more than a bunch of Haskell +modules: it may also have C source code and header files, source code +meant for preprocessing, documentation, test cases, auxiliary tools etc. + +A package is identified by a globally-unique _package name_, which +consists of one or more alphanumeric words separated by hyphens. To +avoid ambiguity, each of these words should contain at least one letter. +Chaos will result if two distinct packages with the same name are +installed on the same system. A particular version of the package is +distinguished by a _version number_, consisting of a sequence of one or +more integers separated by dots. These can be combined to form a single +text string called the _package ID_, using a hyphen to separate the name +from the version, e.g. "`HUnit-1.1`". + +Note: Packages are not part of the Haskell language; they simply +populate the hierarchical space of module names. In GHC 6.6 and later a +program may contain multiple modules with the same name if they come +from separate packages; in all other current Haskell systems packages +may not overlap in the modules they provide, including hidden modules. + + +## Creating a package ## + +Suppose you have a directory hierarchy containing the source files that +make up your package. You will need to add two more files to the root +directory of the package: + +_package_`.cabal` + +: a Unicode UTF-8 text file containing a package description. + For details of the syntax of this file, see the [section on package + descriptions](#package-descriptions). + +`Setup.hs` + +: a single-module Haskell program to perform various setup tasks (with + the interface described in the section on [building and installing + packages](installing-packages.html). This module should + import only modules that will be present in all Haskell + implementations, including modules of the Cabal library. The + content of this file is determined by the `build-type` setting in + the `.cabal` file. In most cases it will be trivial, calling on + the Cabal library to do most of the work. + +Once you have these, you can create a source bundle of this directory +for distribution. Building of the package is discussed in the section on +[building and installing packages](installing-packages.html). + +One of the purposes of Cabal is to make it easier to build a package +with different Haskell implementations. So it provides abstractions of +features present in different Haskell implementations and wherever +possible it is best to take advantage of these to increase portability. +Where necessary however it is possible to use specific features of +specific implementations. For example one of the pieces of information a +package author can put in the package's `.cabal` file is what language +extensions the code uses. This is far preferable to specifying flags for +a specific compiler as it allows Cabal to pick the right flags for the +Haskell implementation that the user picks. It also allows Cabal to +figure out if the language extension is even supported by the Haskell +implementation that the user picks. Where compiler-specific options are +needed however, there is an "escape hatch" available. The developer can +specify implementation-specific options and more generally there is a +configuration mechanism to customise many aspects of how a package is +built depending on the Haskell implementation, the Operating system, +computer architecture and user-specified configuration flags. + +~~~~~~~~~~~~~~~~ +name: Foo +version: 1.0 + +library + build-depends: base + exposed-modules: Foo + extensions: ForeignFunctionInterface + ghc-options: -Wall + if os(windows) + build-depends: Win32 +~~~~~~~~~~~~~~~~ + +#### Example: A package containing a simple library #### + +The HUnit package contains a file `HUnit.cabal` containing: + +~~~~~~~~~~~~~~~~ +name: HUnit +version: 1.1.1 +synopsis: A unit testing framework for Haskell +homepage: http://hunit.sourceforge.net/ +category: Testing +author: Dean Herington +license: BSD3 +license-file: LICENSE +cabal-version: >= 1.10 +build-type: Simple + +library + build-depends: base >= 2 && < 4 + exposed-modules: Test.HUnit.Base, Test.HUnit.Lang, + Test.HUnit.Terminal, Test.HUnit.Text, Test.HUnit + default-extensions: CPP +~~~~~~~~~~~~~~~~ + +and the following `Setup.hs`: + +~~~~~~~~~~~~~~~~ +import Distribution.Simple +main = defaultMain +~~~~~~~~~~~~~~~~ + +#### Example: A package containing executable programs #### + +~~~~~~~~~~~~~~~~ +name: TestPackage +version: 0.0 +synopsis: Small package with two programs +author: Angela Author +license: BSD3 +build-type: Simple +cabal-version: >= 1.2 + +executable program1 + build-depends: HUnit + main-is: Main.hs + hs-source-dirs: prog1 + +executable program2 + main-is: Main.hs + build-depends: HUnit + hs-source-dirs: prog2 + other-modules: Utils +~~~~~~~~~~~~~~~~ + +with `Setup.hs` the same as above. + +#### Example: A package containing a library and executable programs #### + +~~~~~~~~~~~~~~~~ +name: TestPackage +version: 0.0 +synopsis: Package with library and two programs +license: BSD3 +author: Angela Author +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: HUnit + exposed-modules: A, B, C + +executable program1 + main-is: Main.hs + hs-source-dirs: prog1 + other-modules: A, B + +executable program2 + main-is: Main.hs + hs-source-dirs: prog2 + other-modules: A, C, Utils +~~~~~~~~~~~~~~~~ + +with `Setup.hs` the same as above. Note that any library modules +required (directly or indirectly) by an executable must be listed again. + +The trivial setup script used in these examples uses the _simple build +infrastructure_ provided by the Cabal library (see +[Distribution.Simple][dist-simple]). The simplicity lies in its +interface rather that its implementation. It automatically handles +preprocessing with standard preprocessors, and builds packages for all +the Haskell implementations. + +The simple build infrastructure can also handle packages where building +is governed by system-dependent parameters, if you specify a little more +(see the section on [system-dependent +parameters](#system-dependent-parameters)). A few packages require [more +elaborate solutions](#more-complex-packages). + +## Package descriptions ## + +The package description file must have a name ending in "`.cabal`". It +must be a Unicode text file encoded using valid UTF-8. There must be +exactly one such file in the directory. The first part of the name is +usually the package name, and some of the tools that operate on Cabal +packages require this. + +In the package description file, lines whose first non-whitespace characters +are "`--`" are treated as comments and ignored. + +This file should contain of a number global property descriptions and +several sections. + +* The [global properties](#package-properties) describe the package as a + whole, such as name, license, author, etc. + +* Optionally, a number of _configuration flags_ can be declared. These + can be used to enable or disable certain features of a package. (see + the section on [configurations](#configurations)). + +* The (optional) library section specifies the [library + properties](#library) and relevant [build + information](#build-information). + +* Following is an arbitrary number of executable sections + which describe an executable program and relevant [build + information](#build-information). + +Each section consists of a number of property descriptions +in the form of field/value pairs, with a syntax roughly like mail +message headers. + +* Case is not significant in field names, but is significant in field + values. + +* To continue a field value, indent the next line relative to the field + name. + +* Field names may be indented, but all field values in the same section + must use the same indentation. + +* Tabs are *not* allowed as indentation characters due to a missing + standard interpretation of tab width. + +* To get a blank line in a field value, use an indented "`.`" + +The syntax of the value depends on the field. Field types include: + +_token_, _filename_, _directory_ +: Either a sequence of one or more non-space non-comma characters, or + a quoted string in Haskell 98 lexical syntax. Unless otherwise + stated, relative filenames and directories are interpreted from the + package root directory. + +_freeform_, _URL_, _address_ +: An arbitrary, uninterpreted string. + +_identifier_ +: A letter followed by zero or more alphanumerics or underscores. + +_compiler_ +: A compiler flavor (one of: `GHC`, `JHC`, `UHC` or `LHC`) followed by a + version range. For example, `GHC ==6.10.3`, or `LHC >=0.6 && <0.8`. + +### Modules and preprocessors ### + +Haskell module names listed in the `exposed-modules` and `other-modules` +fields may correspond to Haskell source files, i.e. with names ending in +"`.hs`" or "`.lhs`", or to inputs for various Haskell preprocessors. The +simple build infrastructure understands the extensions: + +* `.gc` ([greencard][]) +* `.chs` ([c2hs][]) +* `.hsc` (`hsc2hs`) +* `.y` and `.ly` ([happy][]) +* `.x` ([alex][]) +* `.cpphs` ([cpphs][]) + +When building, Cabal will automatically run the appropriate preprocessor +and compile the Haskell module it produces. + +Some fields take lists of values, which are optionally separated by commas, +except for the `build-depends` field, where the commas are mandatory. + +Some fields are marked as required. All others are optional, and unless +otherwise specified have empty default values. + +### Package properties ### + +These fields may occur in the first top-level properties section and +describe the package as a whole: + +`name:` _package-name_ (required) +: The unique name of the package, without the version number. + +`version:` _numbers_ (required) +: The package version number, usually consisting of a sequence of + natural numbers separated by dots. + +`cabal-version:` _>= x.y_ +: The version of the Cabal specification that this package description uses. + The Cabal specification does slowly evolve, introducing new features and + occasionally changing the meaning of existing features. By specifying + which version of the spec you are using it enables programs which process + the package description to know what syntax to expect and what each part + means. + + For historical reasons this is always expressed using _>=_ version range + syntax. No other kinds of version range make sense, in particular upper + bounds do not make sense. In future this field will specify just a version + number, rather than a version range. + + The version number you specify will affect both compatibility and + behaviour. Most tools (including the Cabal library and cabal program) + understand a range of versions of the Cabal specification. Older tools + will of course only work with older versions of the Cabal specification. + Most of the time, tools that are too old will recognise this fact and + produce a suitable error message. + + As for behaviour, new versions of the Cabal spec can change the meaning + of existing syntax. This means if you want to take advantage of the new + meaning or behaviour then you must specify the newer Cabal version. + Tools are expected to use the meaning and behaviour appropriate to the + version given in the package description. + + In particular, the syntax of package descriptions changed significantly + with Cabal version 1.2 and the `cabal-version` field is now required. + Files written in the old syntax are still recognized, so if you require + compatibility with very old Cabal versions then you may write your package + description file using the old syntax. Please consult the user's guide of + an older Cabal version for a description of that syntax. + +`build-type:` _identifier_ +: The type of build used by this package. Build types are the + constructors of the [BuildType][] type, defaulting to `Custom`. + + If the build type is anything other than `Custom`, then the + `Setup.hs` file *must* be exactly the standardized content + discussed below. This is because in these cases, `cabal` will + ignore the `Setup.hs` file completely, whereas other methods of + package management, such as `runhaskell Setup.hs [CMD]`, still + rely on the `Setup.hs` file. + + For build type `Simple`, the contents of `Setup.hs` must be: + + ~~~~~~~~~~~~~~~~ + import Distribution.Simple + main = defaultMain + ~~~~~~~~~~~~~~~~ + + For build type `Configure` (see the section on [system-dependent + parameters](#system-dependent-parameters) below), the contents of + `Setup.hs` must be: + + ~~~~~~~~~~~~~~~~ + import Distribution.Simple + main = defaultMainWithHooks autoconfUserHooks + ~~~~~~~~~~~~~~~~ + + For build type `Make` (see the section on [more complex + packages](installing-packages.html#more-complex-packages) below), + the contents of `Setup.hs` must be: + + ~~~~~~~~~~~~~~~~ + import Distribution.Make + main = defaultMain + ~~~~~~~~~~~~~~~~ + + For build type `Custom`, the file `Setup.hs` can be customized, + and will be used both by `cabal` and other tools. + + For most packages, the build type `Simple` is sufficient. + +`license:` _identifier_ (default: `AllRightsReserved`) +: The type of license under which this package is distributed. + License names are the constants of the [License][dist-license] type. + +`license-file:` _filename_ or `license-files:` _filename list_ +: The name of a file(s) containing the precise copyright license for + this package. The license file(s) will be installed with the package. + + If you have multiple license files then use the `license-files` + field instead of (or in addition to) the `license-file` field. + +`copyright:` _freeform_ +: The content of a copyright notice, typically the name of the holder + of the copyright on the package and the year(s) from which copyright + is claimed. For example: `Copyright: (c) 2006-2007 Joe Bloggs` + +`author:` _freeform_ +: The original author of the package. + + Remember that `.cabal` files are Unicode, using the UTF-8 encoding. + +`maintainer:` _address_ +: The current maintainer or maintainers of the package. This is an e-mail address to which users should send bug + reports, feature requests and patches. + +`stability:` _freeform_ +: The stability level of the package, e.g. `alpha`, `experimental`, `provisional`, + `stable`. + +`homepage:` _URL_ +: The package homepage. + +`bug-reports:` _URL_ +: The URL where users should direct bug reports. This would normally be either: + + * A `mailto:` URL, e.g. for a person or a mailing list. + + * An `http:` (or `https:`) URL for an online bug tracking system. + + For example Cabal itself uses a web-based bug tracking system + + ~~~~~~~~~~~~~~~~ + bug-reports: http://hackage.haskell.org/trac/hackage/ + ~~~~~~~~~~~~~~~~ + +`package-url:` _URL_ +: The location of a source bundle for the package. The distribution + should be a Cabal package. + +`synopsis:` _freeform_ +: A very short description of the package, for use in a table of + packages. This is your headline, so keep it short (one line) but as + informative as possible. Save space by not including the package + name or saying it's written in Haskell. + +`description:` _freeform_ +: Description of the package. This may be several paragraphs, and + should be aimed at a Haskell programmer who has never heard of your + package before. + + For library packages, this field is used as prologue text by [`setup + haddock`](installing-packages.html#setup-haddock), and thus may + contain the same markup as [haddock][] documentation comments. + +`category:` _freeform_ +: A classification category for future use by the package catalogue [Hackage]. These + categories have not yet been specified, but the upper levels of the + module hierarchy make a good start. + +`tested-with:` _compiler list_ +: A list of compilers and versions against which the package has been + tested (or at least built). + +`data-files:` _filename list_ +: A list of files to be installed for run-time use by the package. + This is useful for packages that use a large amount of static data, + such as tables of values or code templates. Cabal provides a way to + [find these files at + run-time](#accessing-data-files-from-package-code). + + A limited form of `*` wildcards in file names, for example + `data-files: images/*.png` matches all the `.png` files in the + `images` directory. + + The limitation is that `*` wildcards are only allowed in place of + the file name, not in the directory name or file extension. In + particular, wildcards do not include directories contents + recursively. Furthermore, if a wildcard is used it must be used with + an extension, so `data-files: data/*` is not allowed. When matching + a wildcard plus extension, a file's full extension must match + exactly, so `*.gz` matches `foo.gz` but not `foo.tar.gz`. A wildcard + that does not match any files is an error. + + The reason for providing only a very limited form of wildcard is to + concisely express the common case of a large number of related files + of the same file type without making it too easy to accidentally + include unwanted files. + +`data-dir:` _directory_ +: The directory where Cabal looks for data files to install, relative + to the source directory. By default, Cabal will look in the source + directory itself. + +`extra-source-files:` _filename list_ +: A list of additional files to be included in source distributions + built with [`setup sdist`](installing-packages.html#setup-sdist). As + with `data-files` it can use a limited form of `*` wildcards in file + names. + +`extra-doc-files:` _filename list_ +: A list of additional files to be included in source distributions, + and also copied to the html directory when Haddock documentation is + generated. As with `data-files` it can use a limited form of `*` + wildcards in file names. + +`extra-tmp-files:` _filename list_ +: A list of additional files or directories to be removed by [`setup + clean`](installing-packages.html#setup-clean). These would typically + be additional files created by additional hooks, such as the scheme + described in the section on [system-dependent + parameters](#system-dependent-parameters). + +### Library ### + +The library section should contain the following fields: + +`exposed-modules:` _identifier list_ (required if this package contains a library) +: A list of modules added by this package. + +`exposed:` _boolean_ (default: `True`) +: Some Haskell compilers (notably GHC) support the notion of packages + being "exposed" or "hidden" which means the modules they provide can + be easily imported without always having to specify which package + they come from. However this only works effectively if the modules + provided by all exposed packages do not overlap (otherwise a module + import would be ambiguous). + + Almost all new libraries use hierarchical module names that do not + clash, so it is very uncommon to have to use this field. However it + may be necessary to set `exposed: False` for some old libraries that + use a flat module namespace or where it is known that the exposed + modules would clash with other common modules. + +`reexported-modules:` _exportlist _ +: Supported only in GHC 7.10 and later. A list of modules to _reexport_ from + this package. The syntax of this field is `orig-pkg:Name as NewName` to + reexport module `Name` from `orig-pkg` with the new name `NewName`. We also + support abbreviated versions of the syntax: if you omit `as NewName`, + we'll reexport without renaming; if you omit `orig-pkg`, then we will + automatically figure out which package to reexport from, if it's + unambiguous. + + Reexported modules are useful for compatibility shims when a package has + been split into multiple packages, and they have the useful property that + if a package provides a module, and another package reexports it under + the same name, these are not considered a conflict (as would be the case + with a stub module.) They can also be used to resolve name conflicts. + +The library section may also contain build information fields (see the +section on [build information](#build-information)). + +#### Opening an interpreter session #### + +While developing a package, it is often useful to make its code available inside +an interpreter session. This can be done with the `repl` command: + +~~~~~~~~~~~~~~~~ +cabal repl +~~~~~~~~~~~~~~~~ + +The name comes from the acronym [REPL], which stands for +"read-eval-print-loop". By default `cabal repl` loads the first component in a +package. If the package contains several named components, the name can be given +as an argument to `repl`. The name can be also optionally prefixed with the +component's type for disambiguation purposes. Example: + +~~~~~~~~~~~~~~~~ +cabal repl foo +cabal repl exe:foo +cabal repl test:bar +cabal repl bench:baz +~~~~~~~~~~~~~~~~ + +#### Freezing dependency versions #### + +If a package is built in several different environments, such as a development +environment, a staging environment and a production environment, it may be +necessary or desirable to ensure that the same dependency versions are +selected in each environment. This can be done with the `freeze` command: + +~~~~~~~~~~~~~~~~ +cabal freeze +~~~~~~~~~~~~~~~~ + +The command writes the selected version for all dependencies to the +`cabal.config` file. All environments which share this file will use the +dependency versions specified in it. + +### Executables ### + +Executable sections (if present) describe executable programs contained +in the package and must have an argument after the section label, which +defines the name of the executable. This is a freeform argument but may +not contain spaces. + +The executable may be described using the following fields, as well as +build information fields (see the section on [build +information](#build-information)). + +`main-is:` _filename_ (required) +: The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the + `.hs` filename that must be listed, even if that file is generated + using a preprocessor. The source file must be relative to one of the + directories listed in `hs-source-dirs`. + +#### Running executables #### + +You can have Cabal build and run your executables by using the `run` command: + +~~~~~~~~~~~~~~~~ +$ cabal run EXECUTABLE [-- EXECUTABLE_FLAGS] +~~~~~~~~~~~~~~~~ + +This command will configure, build and run the executable `EXECUTABLE`. The +double dash separator is required to distinguish executable flags from `run`'s +own flags. If there is only one executable defined in the whole package, the +executable's name can be omitted. See the output of `cabal help run` for a list +of options you can pass to `cabal run`. + + +### Test suites ### + +Test suite sections (if present) describe package test suites and must have an +argument after the section label, which defines the name of the test suite. +This is a freeform argument, but may not contain spaces. It should be unique +among the names of the package's other test suites, the package's executables, +and the package itself. Using test suite sections requires at least Cabal +version 1.9.2. + +The test suite may be described using the following fields, as well as build +information fields (see the section on [build +information](#build-information)). + +`type:` _interface_ (required) +: The interface type and version of the test suite. Cabal supports two test + suite interfaces, called `exitcode-stdio-1.0` and `detailed-0.9`. Each of + these types may require or disallow other fields as described below. + +Test suites using the `exitcode-stdio-1.0` interface are executables +that indicate test failure with a non-zero exit code when run; they may provide +human-readable log information through the standard output and error channels. +This interface is provided primarily for compatibility with existing test +suites; it is preferred that new test suites be written for the `detailed-0.9` +interface. The `exitcode-stdio-1.0` type requires the `main-is` field. + +`main-is:` _filename_ (required: `exitcode-stdio-1.0`, disallowed: `detailed-0.9`) +: The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the + `.hs` filename that must be listed, even if that file is generated + using a preprocessor. The source file must be relative to one of the + directories listed in `hs-source-dirs`. This field is analogous to the + `main-is` field of an executable section. + +Test suites using the `detailed-0.9` interface are modules exporting the symbol +`tests :: IO [Test]`. The `Test` type is exported by the module +`Distribution.TestSuite` provided by Cabal. For more details, see the example below. + +The `detailed-0.9` interface allows Cabal and other test agents to inspect a +test suite's results case by case, producing detailed human- and +machine-readable log files. The `detailed-0.9` interface requires the +`test-module` field. + +`test-module:` _identifier_ (required: `detailed-0.9`, disallowed: `exitcode-stdio-1.0`) +: The module exporting the `tests` symbol. + +#### Example: Package using `exitcode-stdio-1.0` interface #### + +The example package description and executable source file below demonstrate +the use of the `exitcode-stdio-1.0` interface. For brevity, the example package +does not include a library or any normal executables, but a real package would +be required to have at least one library or executable. + +foo.cabal: + +~~~~~~~~~~~~~~~~ +Name: foo +Version: 1.0 +License: BSD3 +Cabal-Version: >= 1.9.2 +Build-Type: Simple + +Test-Suite test-foo + type: exitcode-stdio-1.0 + main-is: test-foo.hs + build-depends: base +~~~~~~~~~~~~~~~~ + +test-foo.hs: + +~~~~~~~~~~~~~~~~ +module Main where + +import System.Exit (exitFailure) + +main = do + putStrLn "This test always fails!" + exitFailure +~~~~~~~~~~~~~~~~ + +#### Example: Package using `detailed-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. + +bar.cabal: + +~~~~~~~~~~~~~~~~ +Name: bar +Version: 1.0 +License: BSD3 +Cabal-Version: >= 1.9.2 +Build-Type: Simple + +Test-Suite test-bar + type: detailed-0.9 + test-module: Bar + build-depends: base, Cabal >= 1.9.2 +~~~~~~~~~~~~~~~~ + +Bar.hs: + +~~~~~~~~~~~~~~~~ +module Bar ( tests ) where + +import Distribution.TestSuite + +tests :: IO [Test] +tests = return [ Test succeeds, Test fails ] + where + succeeds = TestInstance + { run = return $ Finished Pass + , name = "succeeds" + , tags = [] + , options = [] + , setOption = \_ _ -> Right succeeds + } + fails = TestInstance + { run = return $ Finished $ Fail "Always fails!" + , name = "fails" + , tags = [] + , options = [] + , setOption = \_ _ -> Right fails + } +~~~~~~~~~~~~~~~~ + +#### Running test suites #### + +You can have Cabal run your test suites using its built-in test +runner: + +~~~~~~~~~~~~~~~~ +$ cabal configure --enable-tests +$ cabal build +$ cabal test +~~~~~~~~~~~~~~~~ + +See the output of `cabal help test` for a list of options you can pass +to `cabal test`. + +### Benchmarks ### + +Benchmark sections (if present) describe benchmarks contained in the package and +must have an argument after the section label, which defines the name of the +benchmark. This is a freeform argument, but may not contain spaces. It should +be unique among the names of the package's other benchmarks, the package's test +suites, the package's executables, and the package itself. Using benchmark +sections requires at least Cabal version 1.9.2. + +The benchmark may be described using the following fields, as well as build +information fields (see the section on [build information](#build-information)). + +`type:` _interface_ (required) +: The interface type and version of the benchmark. At the moment Cabal only + support one benchmark interface, called `exitcode-stdio-1.0`. + +Benchmarks using the `exitcode-stdio-1.0` interface are executables that +indicate failure to run the benchmark with a non-zero exit code when run; they +may provide human-readable information through the standard output and error +channels. + +`main-is:` _filename_ (required: `exitcode-stdio-1.0`) +: The name of the `.hs` or `.lhs` file containing the `Main` module. Note that + it is the `.hs` filename that must be listed, even if that file is generated + using a preprocessor. The source file must be relative to one of the + directories listed in `hs-source-dirs`. This field is analogous to the + `main-is` field of an executable section. + +#### Example: Package using `exitcode-stdio-1.0` interface #### + +The example package description and executable source file below demonstrate +the use of the `exitcode-stdio-1.0` interface. For brevity, the example package +does not include a library or any normal executables, but a real package would +be required to have at least one library or executable. + +foo.cabal: + +~~~~~~~~~~~~~~~~ +Name: foo +Version: 1.0 +License: BSD3 +Cabal-Version: >= 1.9.2 +Build-Type: Simple + +Benchmark bench-foo + type: exitcode-stdio-1.0 + main-is: bench-foo.hs + build-depends: base, time +~~~~~~~~~~~~~~~~ + +bench-foo.hs: + +~~~~~~~~~~~~~~~~ +{-# LANGUAGE BangPatterns #-} +module Main where + +import Data.Time.Clock + +fib 0 = 1 +fib 1 = 1 +fib n = fib (n-1) + fib (n-2) + +main = do + start <- getCurrentTime + let !r = fib 20 + end <- getCurrentTime + putStrLn $ "fib 20 took " ++ show (diffUTCTime end start) +~~~~~~~~~~~~~~~~ + +#### Running benchmarks #### + +You can have Cabal run your benchmark using its built-in benchmark runner: + +~~~~~~~~~~~~~~~~ +$ cabal configure --enable-benchmarks +$ cabal build +$ cabal bench +~~~~~~~~~~~~~~~~ + +See the output of `cabal help bench` for a list of options you can +pass to `cabal bench`. + +### Build information ### + +The following fields may be optionally present in a library or +executable section, and give information for the building of the +corresponding library or executable. See also the sections on +[system-dependent parameters](#system-dependent-parameters) and +[configurations](#configurations) for a way to supply system-dependent +values for these fields. + +`build-depends:` _package list_ +: A list of packages needed to build this one. Each package can be + annotated with a version constraint. + + Version constraints use the operators `==, >=, >, <, <=` and a + version number. Multiple constraints can be combined using `&&` or + `||`. If no version constraint is specified, any version is assumed + to be acceptable. For example: + + ~~~~~~~~~~~~~~~~ + library + build-depends: + base >= 2, + foo >= 1.2 && < 1.3, + bar + ~~~~~~~~~~~~~~~~ + + Dependencies like `foo >= 1.2 && < 1.3` turn out to be very common + because it is recommended practise for package versions to + correspond to API versions. As of Cabal 1.6, there is a special + syntax to support this use: + + ~~~~~~~~~~~~~~~~ + build-depends: foo ==1.2.* + ~~~~~~~~~~~~~~~~ + + It is only syntactic sugar. It is exactly equivalent to `foo >= 1.2 && < 1.3`. + + 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. + +`other-modules:` _identifier list_ +: A list of modules used by the component but not exposed to users. + For a library component, these would be hidden modules of the + library. For an executable, these would be auxiliary modules to be + linked with the file named in the `main-is` field. + + Note: Every module in the package *must* be listed in one of + `other-modules`, `exposed-modules` or `main-is` fields. + +`hs-source-dirs:` _directory list_ (default: "`.`") +: Root directories for the module hierarchy. + + For backwards compatibility, the old variant `hs-source-dir` is also + recognized. + +`extensions:` _identifier list_ +: A list of Haskell extensions used by every module. Extension names + are the constructors of the [Extension][extension] type. These + determine corresponding compiler options. In particular, `CPP` specifies that + Haskell source files are to be preprocessed with a C preprocessor. + + Extensions used only by one module may be specified by placing a + `LANGUAGE` pragma in the source file affected, e.g.: + + ~~~~~~~~~~~~~~~~ + {-# LANGUAGE CPP, MultiParamTypeClasses #-} + ~~~~~~~~~~~~~~~~ + + Note: GHC versions prior to 6.6 do not support the `LANGUAGE` pragma. + +`build-tools:` _program list_ +: A list of programs, possibly annotated with versions, needed to + build this package, e.g. `c2hs >= 0.15, cpphs`.If no version + constraint is specified, any version is assumed to be acceptable. + +`buildable:` _boolean_ (default: `True`) +: Is the component buildable? Like some of the other fields below, + this field is more useful with the slightly more elaborate form of + the simple build infrastructure described in the section on + [system-dependent parameters](#system-dependent-parameters). + +`ghc-options:` _token list_ +: Additional options for GHC. You can often achieve the same effect + using the `extensions` field, which is preferred. + + Options required only by one module may be specified by placing an + `OPTIONS_GHC` pragma in the source file affected. + +`ghc-prof-options:` _token list_ +: Additional options for GHC when the package is built with profiling + enabled. + +`ghc-shared-options:` _token list_ +: Additional options for GHC when the package is built as shared library. + +`includes:` _filename list_ +: A list of header files to be included in any compilations via C. + This field applies to both header files that are already installed + on the system and to those coming with the package to be installed. + These files typically contain function prototypes for foreign + imports used by the package. + +`install-includes:` _filename list_ +: A list of header files from this package to be installed into + `$libdir/includes` when the package is installed. Files listed in + `install-includes:` should be found in relative to the top of the + source tree or relative to one of the directories listed in + `include-dirs`. + + `install-includes` is typically used to name header files that + contain prototypes for foreign imports used in Haskell code in this + package, for which the C implementations are also provided with the + package. Note that to include them when compiling the package + itself, they need to be listed in the `includes:` field as well. + +`include-dirs:` _directory list_ +: A list of directories to search for header files, when preprocessing + with `c2hs`, `hsc2hs`, `cpphs` or the C preprocessor, and + also when compiling via C. + +`c-sources:` _filename list_ +: A list of C source files to be compiled and linked with the Haskell files. + +`js-sources:` _filename list_ +: A list of JavaScript source files to be linked with the Haskell files + (only for JavaScript targets). + +`extra-libraries:` _token list_ +: A list of extra libraries to link with. + +`extra-ghci-libraries:` _token list_ +: A list of extra libraries to be used instead of 'extra-libraries' when + the package is loaded with GHCi. + +`extra-lib-dirs:` _directory list_ +: A list of directories to search for libraries. + +`cc-options:` _token list_ +: Command-line arguments to be passed to the C compiler. Since the + arguments are compiler-dependent, this field is more useful with the + setup described in the section on [system-dependent + parameters](#system-dependent-parameters). + +`cpp-options:` _token list_ +: Command-line arguments for pre-processing Haskell code. Applies to + haskell source and other pre-processed Haskell source like .hsc .chs. + Does not apply to C code, that's what cc-options is for. + +`ld-options:` _token list_ +: Command-line arguments to be passed to the linker. Since the + arguments are compiler-dependent, this field is more useful with the + setup described in the section on [system-dependent + parameters](#system-dependent-parameters)>. + +`pkgconfig-depends:` _package list_ +: A list of [pkg-config][] packages, needed to build this package. + They can be annotated with versions, e.g. `gtk+-2.0 >= 2.10, cairo + >= 1.0`. If no version constraint is specified, any version is + assumed to be acceptable. Cabal uses `pkg-config` to find if the + packages are available on the system and to find the extra + compilation and linker options needed to use the packages. + + If you need to bind to a C library that supports `pkg-config` (use + `pkg-config --list-all` to find out if it is supported) then it is + much preferable to use this field rather than hard code options into + the other fields. + +`frameworks:` _token list_ +: On Darwin/MacOS X, a list of frameworks to link to. See Apple's + developer documentation for more details on frameworks. This entry + is ignored on all other platforms. + +### Configurations ### + +Library and executable sections may include conditional +blocks, which test for various system parameters and +configuration flags. The flags mechanism is rather generic, +but most of the time a flag represents certain feature, that +can be switched on or off by the package user. +Here is an example package description file using +configurations: + +#### Example: A package containing a library and executable programs #### + +~~~~~~~~~~~~~~~~ +Name: Test1 +Version: 0.0.1 +Cabal-Version: >= 1.2 +License: BSD3 +Author: Jane Doe +Synopsis: Test package to test configurations +Category: Example + +Flag Debug + Description: Enable debug support + Default: False + +Flag WebFrontend + Description: Include API for web frontend. + -- Cabal checks if the configuration is possible, first + -- with this flag set to True and if not it tries with False + +Library + Build-Depends: base + Exposed-Modules: Testing.Test1 + Extensions: CPP + + if flag(debug) + GHC-Options: -DDEBUG + if !os(windows) + CC-Options: "-DDEBUG" + else + CC-Options: "-DNDEBUG" + + if flag(webfrontend) + Build-Depends: cgi > 0.42 + Other-Modules: Testing.WebStuff + +Executable test1 + Main-is: T1.hs + Other-Modules: Testing.Test1 + Build-Depends: base + + if flag(debug) + CC-Options: "-DDEBUG" + GHC-Options: -DDEBUG +~~~~~~~~~~~~~~~~ + +#### Layout #### + +Flags, conditionals, library and executable sections use layout to +indicate structure. This is very similar to the Haskell layout rule. +Entries in a section have to all be indented to the same level which +must be more than the section header. Tabs are not allowed to be used +for indentation. + +As an alternative to using layout you can also use explicit braces `{}`. +In this case the indentation of entries in a section does not matter, +though different fields within a block must be on different lines. Here +is a bit of the above example again, using braces: + +#### Example: Using explicit braces rather than indentation for layout #### + +~~~~~~~~~~~~~~~~ +Name: Test1 +Version: 0.0.1 +Cabal-Version: >= 1.2 +License: BSD3 +Author: Jane Doe +Synopsis: Test package to test configurations +Category: Example + +Flag Debug { + Description: Enable debug support + Default: False +} + +Library { + Build-Depends: base + Exposed-Modules: Testing.Test1 + Extensions: CPP + if flag(debug) { + GHC-Options: -DDEBUG + if !os(windows) { + CC-Options: "-DDEBUG" + } else { + CC-Options: "-DNDEBUG" + } + } +} +~~~~~~~~~~~~~~~~ + +#### Configuration Flags #### + +A flag section takes the flag name as an argument and may contain the +following fields. + +`description:` _freeform_ +: The description of this flag. + +`default:` _boolean_ (default: `True`) +: The default value of this flag. + + Note that this value may be [overridden in several + ways](installing-packages.html#controlling-flag-assignments"). The + rationale for having flags default to True is that users usually + want new features as soon as they are available. Flags representing + features that are not (yet) recommended for most users (such as + experimental features or debugging support) should therefore + explicitly override the default to False. + +`manual:` _boolean_ (default: `False`) +: By default, Cabal will first try to satisfy dependencies with the + default flag value and then, if that is not possible, with the + negated value. However, if the flag is manual, then the default + value (which can be overridden by commandline flags) will be used. + +#### Conditional Blocks #### + +Conditional blocks may appear anywhere inside a library or executable +section. They have to follow rather strict formatting rules. +Conditional blocks must always be of the shape + +~~~~~~~~~~~~~~~~ + `if `_condition_ + _property-descriptions-or-conditionals*_ +~~~~~~~~~~~~~~~~ + +or + +~~~~~~~~~~~~~~~~ + `if `_condition_ + _property-descriptions-or-conditionals*_ + `else` + _property-descriptions-or-conditionals*_ +~~~~~~~~~~~~~~~~ + +Note that the `if` and the condition have to be all on the same line. + +#### Conditions #### + +Conditions can be formed using boolean tests and the boolean operators +`||` (disjunction / logical "or"), `&&` (conjunction / logical "and"), +or `!` (negation / logical "not"). The unary `!` takes highest +precedence, `||` takes lowest. Precedence levels may be overridden +through the use of parentheses. For example, `os(darwin) && !arch(i386) +|| os(freebsd)` is equivalent to `(os(darwin) && !(arch(i386))) || +os(freebsd)`. + +The following tests are currently supported. + +`os(`_name_`)` +: Tests if the current operating system is _name_. The argument is + tested against `System.Info.os` on the target system. There is + unfortunately some disagreement between Haskell implementations + about the standard values of `System.Info.os`. Cabal canonicalises + it so that in particular `os(windows)` works on all implementations. + If the canonicalised os names match, this test evaluates to true, + otherwise false. The match is case-insensitive. + +`arch(`_name_`)` +: Tests if the current architecture is _name_. The argument is + matched against `System.Info.arch` on the target system. If the arch + names match, this test evaluates to true, otherwise false. The match + is case-insensitive. + +`impl(`_compiler_`)` +: Tests for the configured Haskell implementation. An optional version + constraint may be specified (for example `impl(ghc >= 6.6.1)`). If + the configured implementation is of the right type and matches the + version constraint, then this evaluates to true, otherwise false. + The match is case-insensitive. + +`flag(`_name_`)` +: Evaluates to the current assignment of the flag of the given name. + Flag names are case insensitive. Testing for flags that have not + been introduced with a flag section is an error. + +`true` +: Constant value true. + +`false` +: Constant value false. + +#### Resolution of Conditions and Flags #### + +If a package descriptions specifies configuration flags the package user can +[control these in several ways](installing-packages.html#controlling-flag-assignments). +If the user does not fix the value of a flag, Cabal will try to find a flag +assignment in the following way. + + * For each flag specified, it will assign its default value, evaluate + all conditions with this flag assignment, and check if all + dependencies can be satisfied. If this check succeeded, the package + will be configured with those flag assignments. + + * If dependencies were missing, the last flag (as by the order in + which the flags were introduced in the package description) is tried + with its alternative value and so on. This continues until either + an assignment is found where all dependencies can be satisfied, or + all possible flag assignments have been tried. + +To put it another way, Cabal does a complete backtracking search to find +a satisfiable package configuration. It is only the dependencies +specified in the `build-depends` field in conditional blocks that +determine if a particular flag assignment is satisfiable (`build-tools` +are not considered). The order of the declaration and the default value +of the flags determines the search order. Flags overridden on the +command line fix the assignment of that flag, so no backtracking will be +tried for that flag. + +If no suitable flag assignment could be found, the configuration phase +will fail and a list of missing dependencies will be printed. Note that +this resolution process is exponential in the worst case (i.e., in the +case where dependencies cannot be satisfied). There are some +optimizations applied internally, but the overall complexity remains +unchanged. + +### Meaning of field values when using conditionals ### + +During the configuration phase, a flag assignment is chosen, all +conditionals are evaluated, and the package description is combined into +a flat package descriptions. If the same field both inside a conditional +and outside then they are combined using the following rules. + + + * Boolean fields are combined using conjunction (logical "and"). + + * List fields are combined by appending the inner items to the outer + items, for example + + ~~~~~~~~~~~~~~~~ + Extensions: CPP + if impl(ghc) + Extensions: MultiParamTypeClasses + ~~~~~~~~~~~~~~~~ + + when compiled using GHC will be combined to + + ~~~~~~~~~~~~~~~~ + Extensions: CPP, MultiParamTypeClasses + ~~~~~~~~~~~~~~~~ + + Similarly, if two conditional sections appear at the same nesting + level, properties specified in the latter will come after properties + specified in the former. + + * All other fields must not be specified in ambiguous ways. For + example + + ~~~~~~~~~~~~~~~~ + Main-is: Main.hs + if flag(useothermain) + Main-is: OtherMain.hs + ~~~~~~~~~~~~~~~~ + + will lead to an error. Instead use + + ~~~~~~~~~~~~~~~~ + if flag(useothermain) + Main-is: OtherMain.hs + else + Main-is: Main.hs + ~~~~~~~~~~~~~~~~ + +### Source Repositories ### + +It is often useful to be able to specify a source revision control +repository for a package. Cabal lets you specifying this information in +a relatively structured form which enables other tools to interpret and +make effective use of the information. For example the information +should be sufficient for an automatic tool to checkout the sources. + +Cabal supports specifying different information for various common +source control systems. Obviously not all automated tools will support +all source control systems. + +Cabal supports specifying repositories for different use cases. By +declaring which case we mean automated tools can be more useful. There +are currently two kinds defined: + + * The `head` kind refers to the latest development branch of the + package. This may be used for example to track activity of a project + or as an indication to outside developers what sources to get for + making new contributions. + + * The `this` kind refers to the branch and tag of a repository that + contains the sources for this version or release of a package. For most + source control systems this involves specifying a tag, id or hash of + some form and perhaps a branch. The purpose is to be able to + reconstruct the sources corresponding to a particular package + version. This might be used to indicate what sources to get if + someone needs to fix a bug in an older branch that is no longer an + active head branch. + +You can specify one kind or the other or both. As an example here are +the repositories for the Cabal library. Note that the `this` kind of +repository specifies a tag. + +~~~~~~~~~~~~~~~~ +source-repository head + type: darcs + location: http://darcs.haskell.org/cabal/ + +source-repository this + type: darcs + location: http://darcs.haskell.org/cabal-branches/cabal-1.6/ + tag: 1.6.1 +~~~~~~~~~~~~~~~~ + +The exact fields are as follows: + +`type:` _token_ +: The name of the source control system used for this repository. The + currently recognised types are: + + * `darcs` + * `git` + * `svn` + * `cvs` + * `mercurial` (or alias `hg`) + * `bazaar` (or alias `bzr`) + * `arch` + * `monotone` + + This field is required. + +`location:` _URL_ +: The location of the repository. The exact form of this field depends + on the repository type. For example: + + * for darcs: `http://code.haskell.org/foo/` + * for git: `git://github.com/foo/bar.git` + * for CVS: `anoncvs@cvs.foo.org:/cvs` + + This field is required. + +`module:` _token_ +: CVS requires a named module, as each CVS server can host multiple + named repositories. + + This field is required for the CVS repository type and should not + be used otherwise. + +`branch:` _token_ +: Many source control systems support the notion of a branch, as a + distinct concept from having repositories in separate locations. For + example CVS, SVN and git use branches while for darcs uses different + locations for different branches. If you need to specify a branch to + identify a your repository then specify it in this field. + + This field is optional. + +`tag:` _token_ +: A tag identifies a particular state of a source repository. The tag + can be used with a `this` repository kind to identify the state of + a repository corresponding to a particular package version or + release. The exact form of the tag depends on the repository type. + + This field is required for the `this` repository kind. + +`subdir:` _directory_ +: Some projects put the sources for multiple packages under a single + source repository. This field lets you specify the relative path + from the root of the repository to the top directory for the + package, i.e. the directory containing the package's `.cabal` file. + + This field is optional. It default to empty which corresponds to the + root directory of the repository. + +### Downloading a package's source ### + +The `cabal get` command allows to access a package's source code - either by +unpacking a tarball downloaded from Hackage (the default) or by checking out a +working copy from the package's source repository. + +~~~~~~~~~~~~~~~~ +$ cabal get [FLAGS] PACKAGES +~~~~~~~~~~~~~~~~ + +The `get` command supports the following options: + +`-d --destdir` _PATH_ +: Where to place the package source, defaults to (a subdirectory of) the + current directory. + +`-s --source-repository` _[head|this|...]_ +: Fork the package's source repository using the appropriate version control + system. The optional argument allows to choose a specific repository kind. + + +## Accessing data files from package code ## + +The placement on the target system of files listed in the `data-files` +field varies between systems, and in some cases one can even move +packages around after installation (see [prefix +independence](installing-packages.html#prefix-independence)). To enable +packages to find these files in a portable way, Cabal generates a module +called `Paths_`_pkgname_ (with any hyphens in _pkgname_ replaced by +underscores) during building, so that it may be imported by modules of +the package. This module defines a function + +~~~~~~~~~~~~~~~ +getDataFileName :: FilePath -> IO FilePath +~~~~~~~~~~~~~~~ + +If the argument is a filename listed in the `data-files` field, the +result is the name of the corresponding file on the system on which the +program is running. + +Note: If you decide to import the `Paths_`_pkgname_ module then it +*must* be listed in the `other-modules` field just like any other module +in your package. + +The `Paths_`_pkgname_ module is not platform independent so it does not +get included in the source tarballs generated by `sdist`. + +### Accessing the package version ### + +The aforementioned auto generated `Paths_`_pkgname_ module also +exports the constant `version ::` [Version][data-version] which is +defined as the version of your package as specified in the `version` +field. + +## System-dependent parameters ## + +For some packages, especially those interfacing with C libraries, +implementation details and the build procedure depend on the build +environment. The `build-type` `Configure` can be used to handle many +such situations. In this case, `Setup.hs` should be: + +~~~~~~~~~~~~~~~~ +import Distribution.Simple +main = defaultMainWithHooks autoconfUserHooks +~~~~~~~~~~~~~~~~ + +Most packages, however, would probably do better using the `Simple` +build type and [configurations](#configurations). + +The `build-type` `Configure` differs from `Simple` in two ways: + +* The package root directory must contain a shell script called + `configure`. The configure step will run the script. This `configure` + script may be produced by [autoconf][] or may be hand-written. The + `configure` script typically discovers information about the system + and records it for later steps, e.g. by generating system-dependent + header files for inclusion in C source files and preprocessed Haskell + source files. (Clearly this won't work for Windows without MSYS or + Cygwin: other ideas are needed.) + +* If the package root directory contains a file called + _package_`.buildinfo` after the configuration step, subsequent steps + will read it to obtain additional settings for [build + information](#build-information) fields,to be merged with the ones + given in the `.cabal` file. In particular, this file may be generated + by the `configure` script mentioned above, allowing these settings to + vary depending on the build environment. + + The build information file should have the following structure: + + > _buildinfo_ + > + > `executable:` _name_ + > _buildinfo_ + > + > `executable:` _name_ + > _buildinfo_ + > ... + + where each _buildinfo_ consists of settings of fields listed in the + section on [build information](#build-information). The first one (if + present) relates to the library, while each of the others relate to + the named executable. (The names must match the package description, + but you don't have to have entries for all of them.) + +Neither of these files is required. If they are absent, this setup +script is equivalent to `defaultMain`. + +#### Example: Using autoconf #### + +This example is for people familiar with the [autoconf][] tools. + +In the X11 package, the file `configure.ac` contains: + +~~~~~~~~~~~~~~~~ +AC_INIT([Haskell X11 package], [1.1], [libraries@haskell.org], [X11]) + +# Safety check: Ensure that we are in the correct source directory. +AC_CONFIG_SRCDIR([X11.cabal]) + +# Header file to place defines in +AC_CONFIG_HEADERS([include/HsX11Config.h]) + +# Check for X11 include paths and libraries +AC_PATH_XTRA +AC_TRY_CPP([#include ],,[no_x=yes]) + +# Build the package if we found X11 stuff +if test "$no_x" = yes +then BUILD_PACKAGE_BOOL=False +else BUILD_PACKAGE_BOOL=True +fi +AC_SUBST([BUILD_PACKAGE_BOOL]) + +AC_CONFIG_FILES([X11.buildinfo]) +AC_OUTPUT +~~~~~~~~~~~~~~~~ + +Then the setup script will run the `configure` script, which checks for +the presence of the X11 libraries and substitutes for variables in the +file `X11.buildinfo.in`: + +~~~~~~~~~~~~~~~~ +buildable: @BUILD_PACKAGE_BOOL@ +cc-options: @X_CFLAGS@ +ld-options: @X_LIBS@ +~~~~~~~~~~~~~~~~ + +This generates a file `X11.buildinfo` supplying the parameters needed by +later stages: + +~~~~~~~~~~~~~~~~ +buildable: True +cc-options: -I/usr/X11R6/include +ld-options: -L/usr/X11R6/lib +~~~~~~~~~~~~~~~~ + +The `configure` script also generates a header file `include/HsX11Config.h` +containing C preprocessor defines recording the results of various tests. This +file may be included by C source files and preprocessed Haskell source files in +the package. + +Note: Packages using these features will also need to list additional files such +as `configure`, templates for `.buildinfo` files, files named only in +`.buildinfo` files, header files and so on in the `extra-source-files` field to +ensure that they are included in source distributions. They should also list +files and directories generated by `configure` in the `extra-tmp-files` field to +ensure that they are removed by `setup clean`. + +Quite often the files generated by `configure` need to be listed somewhere in +the package description (for example, in the `install-includes` field). However, +we usually don't want generated files to be included in the source tarball. The +solution is again provided by the `.buildinfo` file. In the above example, the +following line should be added to `X11.buildinfo`: + +~~~~~~~~~~~~~~~~ +install-includes: HsX11Config.h +~~~~~~~~~~~~~~~~ + +In this way, the generated `HsX11Config.h` file won't be included in the source +tarball in addition to `HsX11Config.h.in`, but it will be copied to the right +location during the install process. Packages that use custom `Setup.hs` scripts +can update the necessary fields programmatically instead of using the +`.buildinfo` file. + + +## Conditional compilation ## + +Sometimes you want to write code that works with more than one version +of a dependency. You can specify a range of versions for the dependency +in the `build-depends`, but how do you then write the code that can use +different versions of the API? + +Haskell lets you preprocess your code using the C preprocessor (either +the real C preprocessor, or `cpphs`). To enable this, add `extensions: +CPP` to your package description. When using CPP, Cabal provides some +pre-defined macros to let you test the version of dependent packages; +for example, suppose your package works with either version 3 or version +4 of the `base` package, you could select the available version in your +Haskell modules like this: + +~~~~~~~~~~~~~~~~ +#if MIN_VERSION_base(4,0,0) +... code that works with base-4 ... +#else +... code that works with base-3 ... +#endif +~~~~~~~~~~~~~~~~ + +In general, Cabal supplies a macro `MIN_VERSION_`_`package`_`_(A,B,C)` +for each package depended on via `build-depends`. This macro is true if +the actual version of the package in use is greater than or equal to +`A.B.C` (using the conventional ordering on version numbers, which is +lexicographic on the sequence, but numeric on each component, so for +example 1.2.0 is greater than 1.0.3). + +Since version 1.20, there is also the `MIN_TOOL_VERSION_`_`tool`_ family of +macros for conditioning on the version of build tools used to build the program +(e.g. `hsc2hs`). + +Cabal places the definitions of these macros into an +automatically-generated header file, which is included when +preprocessing Haskell source code by passing options to the C +preprocessor. + +Cabal also allows to detect when the source code is being used for generating +documentation. The `__HADDOCK_VERSION__` macro is defined only when compiling +via [haddock][] instead of a normal Haskell compiler. The value of the +`__HADDOCK_VERSION__` macro is defined as `A*1000 + B*10 + C`, where `A.B.C` is +the Haddock version. This can be useful for working around bugs in Haddock or +generating prettier documentation in some special cases. + +## More complex packages ## + +For packages that don't fit the simple schemes described above, you have +a few options: + + * By using the `build-type` `Custom`, you can supply your own + `Setup.hs` file, and customize the simple build infrastructure + using _hooks_. These allow you to perform additional actions + before and after each command is run, and also to specify + additional preprocessors. A typical `Setup.hs` may look like this: + + ~~~~~~~~~~~~~~~~ + import Distribution.Simple + main = defaultMainWithHooks simpleUserHooks { postHaddock = posthaddock } + + posthaddock args flags desc info = .... + ~~~~~~~~~~~~~~~~ + + See `UserHooks` in [Distribution.Simple][dist-simple] for the + details, but note that this interface is experimental, and likely + to change in future releases. + + * You could delegate all the work to `make`, though this is unlikely + to be very portable. Cabal supports this with the `build-type` + `Make` and a trivial setup library [Distribution.Make][dist-make], + which simply parses the command line arguments and invokes `make`. + Here `Setup.hs` should look like this: + + ~~~~~~~~~~~~~~~~ + import Distribution.Make + main = defaultMain + ~~~~~~~~~~~~~~~~ + + The root directory of the package should contain a `configure` + script, and, after that has run, a `Makefile` with a default target + that builds the package, plus targets `install`, `register`, + `unregister`, `clean`, `dist` and `docs`. Some options to commands + are passed through as follows: + + * The `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, `--datadir`, + `--libexecdir` and `--sysconfdir` options to the `configure` command are + passed on to the `configure` script. In addition the value of the + `--with-compiler` option is passed in a `--with-hc` option and all + options specified with `--configure-option=` are passed on. + + * The `--destdir` option to the `copy` command becomes a setting + of a `destdir` variable on the invocation of `make copy`. The + supplied `Makefile` should provide a `copy` target, which will + probably look like this: + + ~~~~~~~~~~~~~~~~ + copy : + $(MAKE) install prefix=$(destdir)/$(prefix) \ + bindir=$(destdir)/$(bindir) \ + libdir=$(destdir)/$(libdir) \ + datadir=$(destdir)/$(datadir) \ + libexecdir=$(destdir)/$(libexecdir) \ + sysconfdir=$(destdir)/$(sysconfdir) \ + ~~~~~~~~~~~~~~~~ + + * Finally, with the `build-type` `Custom`, you can also write your + own setup script from scratch. It must conform to the interface + described in the section on [building and installing + packages](installing-packages.html), and you may use the Cabal + library for all or part of the work. One option is to copy the + source of `Distribution.Simple`, and alter it for your needs. Good + luck. + + + +[dist-simple]: ../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html +[dist-make]: ../release/cabal-latest/doc/API/Cabal/Distribution-Make.html +[dist-license]: ../release/cabal-latest/doc/API/Cabal/Distribution-License.html#t:License +[extension]: ../release/cabal-latest/doc/API/Cabal/Language-Haskell-Extension.html#t:Extension +[BuildType]: ../release/cabal-latest/doc/API/Cabal/Distribution-PackageDescription.html#t:BuildType +[data-version]: http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Version.html +[alex]: http://www.haskell.org/alex/ +[autoconf]: http://www.gnu.org/software/autoconf/ +[c2hs]: http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ +[cpphs]: http://projects.haskell.org/cpphs/ +[greencard]: http://hackage.haskell.org/package/greencard +[haddock]: http://www.haskell.org/haddock/ +[HsColour]: http://www.cs.york.ac.uk/fp/darcs/hscolour/ +[happy]: http://www.haskell.org/happy/ +[Hackage]: http://hackage.haskell.org/ +[pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/ +[REPL]: http://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop diff --git a/doc/index.markdown b/doc/index.markdown new file mode 100644 --- /dev/null +++ b/doc/index.markdown @@ -0,0 +1,200 @@ +% Cabal User Guide + +Cabal is the standard package system for [Haskell] software. It helps +people to configure, build and install Haskell software and to +distribute it easily to other users and developers. + +There is a command line tool called `cabal` for working with Cabal +packages. It helps with installing existing packages and also helps +people developing their own packages. It can be used to work with local +packages or to install packages from online package archives, including +automatically installing dependencies. By default it is configured to +use [Hackage] which is Haskell's central package archive that contains +thousands of libraries and applications in the Cabal package format. + +# Contents # + + * [Introduction](#introduction) + - [What's in a package](#whats-in-a-package) + - [A tool for working with packages](#a-tool-for-working-with-packages) + * [Building, installing and managing packages](installing-packages.html) + * [Creating packages](developing-packages.html) + * [Reporting bugs and deficiencies](misc.html#reporting-bugs-and-deficiencies) + * [Stability of Cabal interfaces](misc.html#stability-of-cabal-interfaces) + +# Introduction # + +Cabal is a package system for Haskell software. The point of a package +system is to enable software developers and users to easily distribute, +use and reuse software. A package system makes it easier for developers +to get their software into the hands of users. Equally importantly, it +makes it easier for software developers to be able to reuse software +components written by other developers. + +Packaging systems deal with packages and with Cabal we call them _Cabal +packages_. The Cabal package is the unit of distribution. Every Cabal +package has a name and a version number which are used to identify the +package, e.g. `filepath-1.0`. + +Cabal packages can depend on other Cabal packages. There are tools +to enable automated package management. This means it is possible for +developers and users to install a package plus all of the other Cabal +packages that it depends on. It also means that it is practical to make +very modular systems using lots of packages that reuse code written by +many developers. + +Cabal packages are source based and are typically (but not necessarily) +portable to many platforms and Haskell implementations. The Cabal +package format is designed to make it possible to translate into other +formats, including binary packages for various systems. + +When distributed, Cabal packages use the standard compressed tarball +format, with the file extension `.tar.gz`, e.g. `filepath-1.0.tar.gz`. + +Note that packages are not part of the Haskell language, rather they +are a feature provided by the combination of Cabal and GHC (and several +other Haskell implementations). + + +## A tool for working with packages ## + +There is a command line tool, called "`cabal`", that users and developers +can use to build and install Cabal packages. It can be used for both +local packages and for packages available remotely over the network. It +can automatically install Cabal packages plus any other Cabal packages +they depend on. + +Developers can use the tool with packages in local directories, e.g. + +~~~~~~~~~~~~~~~~ +cd foo/ +cabal install +~~~~~~~~~~~~~~~~ + +While working on a package in a local directory, developers can run the +individual steps to configure and build, and also generate documentation +and run test suites and benchmarks. + +It is also possible to install several local packages at once, e.g. + +~~~~~~~~~~~~~~~~ +cabal install foo/ bar/ +~~~~~~~~~~~~~~~~ + +Developers and users can use the tool to install packages from remote +Cabal package archives. By default, the `cabal` tool is configured to +use the central Haskell package archive called [Hackage] but it +is possible to use it with any other suitable archive. + +~~~~~~~~~~~~~~~~ +cabal install xmonad +~~~~~~~~~~~~~~~~ + +This will install the `xmonad` package plus all of its dependencies. + +In addition to packages that have been published in an archive, +developers can install packages from local or remote tarball files, +for example + +~~~~~~~~~~~~~~~~ +cabal install foo-1.0.tar.gz +cabal install http://example.com/foo-1.0.tar.gz +~~~~~~~~~~~~~~~~ + +Cabal provides a number of ways for a user to customise how and where a +package is installed. They can decide where a package will be installed, +which Haskell implementation to use and whether to build optimised code +or build with the ability to profile code. It is not expected that users +will have to modify any of the information in the `.cabal` file. + +For full details, see the section on [building and installing +packages](installing-packages.html). + +Note that `cabal` is not the only tool for working with Cabal packages. +Due to the standardised format and a library for reading `.cabal` files, +there are several other special-purpose tools. + +## What's in a package ## + +A Cabal package consists of: + + * Haskell software, including libraries, executables and tests + * metadata about the package in a standard human and machine + readable format (the "`.cabal`" file) + * a standard interface to build the package (the "`Setup.hs`" file) + +The `.cabal` file contains information about the package, supplied by +the package author. In particular it lists the other Cabal packages +that the package depends on. + +For full details on what goes in the `.cabal` and `Setup.hs` files, and +for all the other features provided by the build system, see the section +on [developing packages](developing-packages.html). + + +## Cabal featureset ## + +Cabal and its associated tools and websites covers: + + * a software build system + * software configuration + * packaging for distribution + * automated package management + * natively using the `cabal` command line tool; or + * by translation into native package formats such as RPM or deb + * web and local Cabal package archives + * central Hackage website with 1000's of Cabal packages + +Some parts of the system can be used without others. In particular the +built-in build system for simple packages is optional: it is possible +to use custom build systems. + +## Similar systems ## + +The Cabal system is roughly comparable with the system of Python Eggs, +Ruby Gems or Perl distributions. Each system has a notion of +distributable packages, and has tools to manage the process of +distributing and installing packages. + +Hackage is an online archive of Cabal packages. It is roughly comparable +to CPAN but with rather fewer packages (around 5,000 vs 28,000). + +Cabal is often compared with autoconf and automake and there is some +overlap in functionality. The most obvious similarity is that the +command line interface for actually configuring and building packages +follows the same steps and has many of the same configuration +parameters. + +~~~~~~~~~~ +./configure --prefix=... +make +make install +~~~~~~~~~~ + +compared to + +~~~~~~~~~~ +cabal configure --prefix=... +cabal build +cabal install +~~~~~~~~~~ + +Cabal's build system for simple packages is considerably less flexible +than make/automake, but has builtin knowledge of how to build Haskell +code and requires very little manual configuration. Cabal's simple build +system is also portable to Windows, without needing a Unix-like +environment such as cygwin/mingwin. + +Compared to autoconf, Cabal takes a somewhat different approach to +package configuration. Cabal's approach is designed for automated +package management. Instead of having a configure script that tests for +whether dependencies are available, Cabal packages specify their +dependencies. There is some scope for optional and conditional +dependencies. By having package authors specify dependencies it makes it +possible for tools to install a package and all of its dependencies +automatically. It also makes it possible to translate (in a +mostly-automatically way) into another package format like RPM or deb +which also have automatic dependency resolution. + +[Haskell]: http://www.haskell.org/ +[Hackage]: http://hackage.haskell.org/ diff --git a/doc/installing-packages.markdown b/doc/installing-packages.markdown new file mode 100644 --- /dev/null +++ b/doc/installing-packages.markdown @@ -0,0 +1,1067 @@ +% Cabal User Guide + +# Building and installing packages # + +After you've unpacked a Cabal package, you can build it by moving into +the root directory of the package and running the `cabal` tool there: + +> `cabal [command] [option...]` + +The _command_ argument selects a particular step in the build/install process. + +You can also get a summary of the command syntax with + +> `cabal help` + +Alternatively, you can also use the `Setup.hs` or `Setup.lhs` script: + +> `runhaskell Setup.hs [command] [option...]` + +For the summary of the command syntax, run: + +> `cabal help` + +or + +> `runhaskell Setup.hs --help` + +## Building and installing a system package ## + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs configure --ghc +runhaskell Setup.hs build +runhaskell Setup.hs install +~~~~~~~~~~~~~~~~ + +The first line readies the system to build the tool using GHC; for +example, it checks that GHC exists on the system. The second line +performs the actual building, while the last both copies the build +results to some permanent place and registers the package with GHC. + +## Building and installing a user package ## + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs configure --user +runhaskell Setup.hs build +runhaskell Setup.hs install +~~~~~~~~~~~~~~~~ + +The package is installed under the user's home directory and is +registered in the user's package database (`--user`). + +## Installing packages from Hackage ## + +The `cabal` tool also can download, configure, build and install a [Hackage] +package and all of its dependencies in a single step. To do this, run: + +~~~~~~~~~~~~~~~~ +cabal install [PACKAGE...] +~~~~~~~~~~~~~~~~ + +To browse the list of available packages, visit the [Hackage] web site. + +## Developing with sandboxes ## + +By default, any dependencies of the package are installed into the global or +user package databases (e.g. using `cabal install --only-dependencies`). If +you're building several different packages that have incompatible dependencies, +this can cause the build to fail. One way to avoid this problem is to build each +package in an isolated environment ("sandbox"), with a sandbox-local package +database. Because sandboxes are per-project, inconsistent dependencies can be +simply disallowed. + +For more on sandboxes, see also +[this article](http://coldwa.st/e/blog/2013-08-20-Cabal-sandbox.html). + +### Sandboxes: basic usage ### + +To initialise a fresh sandbox in the current directory, run `cabal sandbox +init`. All subsequent commands (such as `build` and `install`) from this point +will use the sandbox. + +~~~~~~~~~~~~~~~ +$ cd /path/to/my/haskell/library +$ cabal sandbox init # Initialise the sandbox +$ cabal install --only-dependencies # Install dependencies into the sandbox +$ cabal build # Build your package inside the sandbox +~~~~~~~~~~~~~~~ + +It can be useful to make a source package available for installation in the +sandbox - for example, if your package depends on a patched or an unreleased +version of a library. This can be done with the `cabal sandbox add-source` +command - think of it as "local [Hackage]". If an add-source dependency is later +modified, it is reinstalled automatically. + +~~~~~~~~~~~~~~~ +$ cabal sandbox add-source /my/patched/library # Add a new add-source dependency +$ cabal install --dependencies-only # Install it into the sandbox +$ cabal build # Build the local package +$ $EDITOR /my/patched/library/Source.hs # Modify the add-source dependency +$ cabal build # Modified dependency is automatically reinstalled +~~~~~~~~~~~~~~~ + +Normally, the sandbox settings (such as optimisation level) are inherited from +the main Cabal config file (`$HOME/cabal/config`). Sometimes, though, you need +to change some settings specifically for a single sandbox. You can do this by +creating a `cabal.config` file in the same directory with your +`cabal.sandbox.config` (which was created by `sandbox init`). This file has the +same syntax as the main Cabal config file. + +~~~~~~~~~~~~~~~ +$ cat cabal.config +documentation: True +constraints: foo == 1.0, bar >= 2.0, baz +$ cabal build # Uses settings from the cabal.config file +~~~~~~~~~~~~~~~ + +When you have decided that you no longer want to build your package inside a +sandbox, just delete it: + +~~~~~~~~~~~~~~~ +$ cabal sandbox delete # Built-in command +$ rm -rf .cabal-sandbox cabal.sandbox.config # Alternative manual method +~~~~~~~~~~~~~~~ + +### Sandboxes: advanced usage ### + +The default behaviour of the `add-source` command is to track modifications done +to the added dependency and reinstall the sandbox copy of the package when +needed. Sometimes this is not desirable: in these cases you can use `add-source +--snapshot`, which disables the change tracking. In addition to `add-source`, +there are also `list-sources` and `delete-source` commands. + +Sometimes one wants to share a single sandbox between multiple packages. This +can be easily done with the `--sandbox` option: + +~~~~~~~~~~~~~~~ +$ mkdir -p /path/to/shared-sandbox +$ cd /path/to/shared-sandbox +$ cabal sandbox init --sandbox . +$ cd /path/to/package-a +$ cabal sandbox init --sandbox /path/to/shared-sandbox +$ cd /path/to/package-b +$ cabal sandbox init --sandbox /path/to/shared-sandbox +~~~~~~~~~~~~~~~ + +Note that `cabal sandbox init --sandbox .` puts all sandbox files into the +current directory. By default, `cabal sandbox init` initialises a new sandbox in +a newly-created subdirectory of the current working directory +(`./.cabal-sandbox`). + +Using multiple different compiler versions simultaneously is also supported, via +the `-w` option: + +~~~~~~~~~~~~~~~ +$ cabal sandbox init +$ cabal install --only-dependencies -w /path/to/ghc-1 # Install dependencies for both compilers +$ cabal install --only-dependencies -w /path/to/ghc-2 +$ cabal configure -w /path/to/ghc-1 # Build with the first compiler +$ cabal build +$ cabal configure -w /path/to/ghc-2 # Build with the second compiler +$ cabal build +~~~~~~~~~~~~~~~ + +It can be occasionally useful to run the compiler-specific package manager tool +(e.g. `ghc-pkg`) tool on the sandbox package DB directly (for example, you may +need to unregister some packages). The `cabal sandbox hc-pkg` command is a +convenient wrapper that runs the compiler-specific package manager tool with the +arguments: + +~~~~~~~~~~~~~~~ +$ cabal -v sandbox hc-pkg list +Using a sandbox located at /path/to/.cabal-sandbox +'ghc-pkg' '--global' '--no-user-package-conf' + '--package-conf=/path/to/.cabal-sandbox/i386-linux-ghc-7.4.2-packages.conf.d' + 'list' +[...] +~~~~~~~~~~~~~~~ + +The `--require-sandbox` option makes all sandbox-aware commands +(`install`/`build`/etc.) exit with error if there is no sandbox present. This +makes it harder to accidentally modify the user package database. The option can +be also turned on via the per-user configuration file (`~/.cabal/config`) or the +per-project one (`$PROJECT_DIR/cabal.config`). The error can be squelched with +`--no-require-sandbox`. + +The option `--sandbox-config-file` allows to specify the location of the +`cabal.sandbox.config` file (by default, `cabal` searches for it in the current +directory). This provides the same functionality as shared sandboxes, but +sometimes can be more convenient. Example: + +~~~~~~~~~~~~~~~ +$ mkdir my/sandbox +$ cd my/sandbox +$ cabal sandbox init +$ cd /path/to/my/project +$ cabal --sandbox-config-file=/path/to/my/sandbox/cabal.sandbox.config install +# Uses the sandbox located at /path/to/my/sandbox/.cabal-sandbox +$ cd ~ +$ cabal --sandbox-config-file=/path/to/my/sandbox/cabal.sandbox.config install +# Still uses the same sandbox +~~~~~~~~~~~~~~~ + +The sandbox config file can be also specified via the `CABAL_SANDBOX_CONFIG` +environment variable. + +Finally, the flag `--ignore-sandbox` lets you temporarily ignore an existing +sandbox: + +~~~~~~~~~~~~~~~ +$ mkdir my/sandbox +$ cd my/sandbox +$ cabal sandbox init +$ cabal --ignore-sandbox install text +# Installs 'text' in the user package database ('~/.cabal'). +~~~~~~~~~~~~~~~ + +## Creating a binary package ## + +When creating binary packages (e.g. for Red Hat or Debian) one needs to +create a tarball that can be sent to another system for unpacking in the +root directory: + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs configure --prefix=/usr +runhaskell Setup.hs build +runhaskell Setup.hs copy --destdir=/tmp/mypkg +tar -czf mypkg.tar.gz /tmp/mypkg/ +~~~~~~~~~~~~~~~~ + +If the package contains a library, you need two additional steps: + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs register --gen-script +runhaskell Setup.hs unregister --gen-script +~~~~~~~~~~~~~~~~ + +This creates shell scripts `register.sh` and `unregister.sh`, which must +also be sent to the target system. After unpacking there, the package +must be registered by running the `register.sh` script. The +`unregister.sh` script would be used in the uninstall procedure of the +package. Similar steps may be used for creating binary packages for +Windows. + + +The following options are understood by all commands: + +`--help`, `-h` or `-?` +: List the available options for the command. + +`--verbose=`_n_ or `-v`_n_ +: Set the verbosity level (0-3). The normal level is 1; a missing _n_ + defaults to 2. + +The various commands and the additional options they support are +described below. In the simple build infrastructure, any other options +will be reported as errors. + +## setup configure ## + +Prepare to build the package. Typically, this step checks that the +target platform is capable of building the package, and discovers +platform-specific features that are needed during the build. + +The user may also adjust the behaviour of later stages using the options +listed in the following subsections. In the simple build +infrastructure, the values supplied via these options are recorded in a +private file read by later stages. + +If a user-supplied `configure` script is run (see the section on +[system-dependent +parameters](developing-packages.html#system-dependent-parameters) or on +[complex packages](developing-packages.html#more-complex-packages)), it +is passed the `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, +`--datadir`, `--libexecdir` and `--sysconfdir` options. In addition the +value of the `--with-compiler` option is passed in a `--with-hc` option +and all options specified with `--configure-option=` are passed on. + +### Programs used for building ### + +The following options govern the programs used to process the source +files of a package: + +`--ghc` or `-g`, `--jhc`, `--lhc`, `--uhc` +: Specify which Haskell implementation to use to build the package. + At most one of these flags may be given. If none is given, the + implementation under which the setup script was compiled or + interpreted is used. + +`--with-compiler=`_path_ or `-w`_path_ +: Specify the path to a particular compiler. If given, this must match + the implementation selected above. The default is to search for the + usual name of the selected implementation. + + This flag also sets the default value of the `--with-hc-pkg` option + to the package tool for this compiler. Check the output of `setup + configure -v` to ensure that it finds the right package tool (or use + `--with-hc-pkg` explicitly). + + +`--with-hc-pkg=`_path_ +: Specify the path to the package tool, e.g. `ghc-pkg`. The package + tool must be compatible with the compiler specified by + `--with-compiler`. If this option is omitted, the default value is + determined from the compiler selected. + +`--with-`_`prog`_`=`_path_ +: Specify the path to the program _prog_. Any program known to Cabal + can be used in place of _prog_. It can either be a fully path or the + name of a program that can be found on the program search path. For + example: `--with-ghc=ghc-6.6.1` or + `--with-cpphs=/usr/local/bin/cpphs`. + The full list of accepted programs is not enumerated in this user guide. + Rather, run `cabal install --help` to view the list. + +`--`_`prog`_`-options=`_options_ +: Specify additional options to the program _prog_. Any program known + to Cabal can be used in place of _prog_. For example: + `--alex-options="--template=mytemplatedir/"`. The _options_ is split + into program options based on spaces. Any options containing embedded + spaced need to be quoted, for example + `--foo-options='--bar="C:\Program File\Bar"'`. As an alternative + that takes only one option at a time but avoids the need to quote, + use `--`_`prog`_`-option` instead. + +`--`_`prog`_`-option=`_option_ +: Specify a single additional option to the program _prog_. For + passing an option that contain embedded spaces, such as a file name + with embedded spaces, using this rather than `--`_`prog`_`-options` + means you do not need an additional level of quoting. Of course if + you are using a command shell you may still need to quote, for + example `--foo-options="--bar=C:\Program File\Bar"`. + +All of the options passed with either `--`_`prog`_`-options` or +`--`_`prog`_`-option` are passed in the order they were specified on the +configure command line. + +### Installation paths ### + +The following options govern the location of installed files from a +package: + +`--prefix=`_dir_ +: The root of the installation. For example for a global install you + might use `/usr/local` on a Unix system, or `C:\Program Files` on a + Windows system. The other installation paths are usually + subdirectories of _prefix_, but they don't have to be. + + In the simple build system, _dir_ may contain the following path + variables: `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, + `$arch`, `$abi`, `$abitag` + +`--bindir=`_dir_ +: Executables that the user might invoke are installed here. + + In the simple build system, _dir_ may contain the following path + variables: `$prefix`, `$pkgid`, `$pkg`, `$version`, `$compiler`, + `$os`, `$arch`, `$abi`, `$abitag + +`--libdir=`_dir_ +: Object-code libraries are installed here. + + In the simple build system, _dir_ may contain the following path + variables: `$prefix`, `$bindir`, `$pkgid`, `$pkg`, `$version`, + `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` + +`--libexecdir=`_dir_ +: Executables that are not expected to be invoked directly by the user + are installed here. + + In the simple build system, _dir_ may contain the following path + variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, + `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` + +`--datadir`=_dir_ +: Architecture-independent data files are installed here. + + In the simple build system, _dir_ may contain the following path + variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` + +`--sysconfdir=`_dir_ +: Installation directory for the configuration files. + + In the simple build system, _dir_ may contain the following path variables: + `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, `$pkg`, `$version`, + `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` + +In addition the simple build system supports the following installation path options: + +`--libsubdir=`_dir_ +: A subdirectory of _libdir_ in which libraries are actually + installed. For example, in the simple build system on Unix, the + default _libdir_ is `/usr/local/lib`, and _libsubdir_ contains the + package identifier and compiler, e.g. `mypkg-0.2/ghc-6.4`, so + libraries would be installed in `/usr/local/lib/mypkg-0.2/ghc-6.4`. + + _dir_ may contain the following path variables: `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` + +`--datasubdir=`_dir_ +: A subdirectory of _datadir_ in which data files are actually + installed. + + _dir_ may contain the following path variables: `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` + +`--docdir=`_dir_ +: Documentation files are installed relative to this directory. + + _dir_ may contain the following path variables: `$prefix`, `$bindir`, + `$libdir`, `$libsubdir`, `$datadir`, `$datasubdir`, `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` + +`--htmldir=`_dir_ +: HTML documentation files are installed relative to this directory. + + _dir_ may contain the following path variables: `$prefix`, `$bindir`, + `$libdir`, `$libsubdir`, `$datadir`, `$datasubdir`, `$docdir`, `$pkgid`, + `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` + +`--program-prefix=`_prefix_ +: Prepend _prefix_ to installed program names. + + _prefix_ may contain the following path variables: `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` + +`--program-suffix=`_suffix_ +: Append _suffix_ to installed program names. The most obvious use for + this is to append the program's version number to make it possible + to install several versions of a program at once: + `--program-suffix='$version'`. + + _suffix_ may contain the following path variables: `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` + +#### Path variables in the simple build system #### + +For the simple build system, there are a number of variables that can be +used when specifying installation paths. The defaults are also specified +in terms of these variables. A number of the variables are actually for +other paths, like `$prefix`. This allows paths to be specified relative +to each other rather than as absolute paths, which is important for +building relocatable packages (see [prefix +independence](#prefix-independence)). + +`$prefix` +: The path variable that stands for the root of the installation. For + an installation to be relocatable, all other installation paths must + be relative to the `$prefix` variable. + +`$bindir` +: The path variable that expands to the path given by the `--bindir` + configure option (or the default). + +`$libdir` +: As above but for `--libdir` + +`$libsubdir` +: As above but for `--libsubdir` + +`$datadir` +: As above but for `--datadir` + +`$datasubdir` +: As above but for `--datasubdir` + +`$docdir` +: As above but for `--docdir` + +`$pkgid` +: The name and version of the package, e.g. `mypkg-0.2` + +`$pkg` +: The name of the package, e.g. `mypkg` + +`$version` +: The version of the package, e.g. `0.2` + +`$compiler` +: The compiler being used to build the package, e.g. `ghc-6.6.1` + +`$os` +: The operating system of the computer being used to build the + package, e.g. `linux`, `windows`, `osx`, `freebsd` or `solaris` + +`$arch` +: The architecture of the computer being used to build the package, e.g. + `i386`, `x86_64`, `ppc` or `sparc` + +`$abitag` +: An optional tag that a compiler can use for telling incompatible ABI's + on the same architecture apart. GHCJS encodes the underlying GHC version + in the ABI tag. + +`$abi` +: A shortcut for getting a path that completely identifies the platform in terms + of binary compatibility. Expands to the same value as `$arch-$os-compiler-$abitag` + if the compiler uses an abi tag, `$arch-$os-$compiler` if it doesn't. + +#### Paths in the simple build system #### + +For the simple build system, the following defaults apply: + +Option Windows Default Unix Default +------- ---------------- ------------- +`--prefix` (global) `C:\Program Files\Haskell` `/usr/local` +`--prefix` (per-user) `C:\Documents And Settings\user\Application Data\cabal` `$HOME/.cabal` +`--bindir` `$prefix\bin` `$prefix/bin` +`--libdir` `$prefix` `$prefix/lib` +`--libsubdir` (others) `$pkgid\$compiler` `$pkgid/$compiler` +`--libexecdir` `$prefix\$pkgid` `$prefix/libexec` +`--datadir` (executable) `$prefix` `$prefix/share` +`--datadir` (library) `C:\Program Files\Haskell` `$prefix/share` +`--datasubdir` `$pkgid` `$pkgid` +`--docdir` `$prefix\doc\$pkgid` `$datadir/doc/$pkgid` +`--sysconfdir` `$prefix\etc` `$prefix/etc` +`--htmldir` `$docdir\html` `$docdir/html` +`--program-prefix` (empty) (empty) +`--program-suffix` (empty) (empty) + + +#### Prefix-independence #### + +On Windows it is possible to obtain the pathname of the running program. This +means that we can construct an installable executable package that is +independent of its absolute install location. The executable can find its +auxiliary files by finding its own path and knowing the location of the other +files relative to `$bindir`. Prefix-independence is particularly useful: it +means the user can choose the install location (i.e. the value of `$prefix`) at +install-time, rather than having to bake the path into the binary when it is +built. + +In order to achieve this, we require that for an executable on Windows, +all of `$bindir`, `$libdir`, `$datadir` and `$libexecdir` begin with +`$prefix`. If this is not the case then the compiled executable will +have baked-in all absolute paths. + +The application need do nothing special to achieve prefix-independence. +If it finds any files using `getDataFileName` and the [other functions +provided for the +purpose](developing-packages.html#accessing-data-files-from-package-code), +the files will be accessed relative to the location of the current +executable. + +A library cannot (currently) be prefix-independent, because it will be +linked into an executable whose file system location bears no relation +to the library package. + +### Controlling Flag Assignments ### + +Flag assignments (see the [resolution of conditions and +flags](developing-packages.html#resolution-of-conditions-and-flags)) can +be controlled with the following command line options. + +`-f` _flagname_ or `-f` `-`_flagname_ +: Force the specified flag to `true` or `false` (if preceded with a `-`). Later + specifications for the same flags will override earlier, i.e., + specifying `-fdebug -f-debug` is equivalent to `-f-debug` + +`--flags=`_flagspecs_ +: Same as `-f`, but allows specifying multiple flag assignments at + once. The parameter is a space-separated list of flag names (to + force a flag to `true`), optionally preceded by a `-` (to force a + flag to `false`). For example, `--flags="debug -feature1 feature2"` is + equivalent to `-fdebug -f-feature1 -ffeature2`. + +### Building Test Suites ### + +`--enable-tests` +: Build the test suites defined in the package description file during the + `build` stage. Check for dependencies required by the test suites. If the + package is configured with this option, it will be possible to run the test + suites with the `test` command after the package is built. + +`--disable-tests` +: (default) Do not build any test suites during the `build` stage. + Do not check for dependencies required only by the test suites. It will not + be possible to invoke the `test` command without reconfiguring the package. + +`--enable-coverage` +: Build libraries and executables (including test suites) with Haskell + Program Coverage enabled. Running the test suites will automatically + generate coverage reports with HPC. + +`--disable-coverage` +: (default) Do not enable Haskell Program Coverage. + +### Miscellaneous options ## + +`--user` +: Does a per-user installation. This changes the [default installation + prefix](#paths-in-the-simple-build-system). It also allow + dependencies to be satisfied by the user's package database, in + addition to the global database. This also implies a default of + `--user` for any subsequent `install` command, as packages + registered in the global database should not depend on packages + registered in a user's database. + +`--global` +: (default) Does a global installation. In this case package + dependencies must be satisfied by the global package database. All + packages in the user's package database will be ignored. Typically + the final installation step will require administrative privileges. + +`--package-db=`_db_ +: Allows package dependencies to be satisfied from this additional + package database _db_ in addition to the global package database. + All packages in the user's package database will be ignored. The + interpretation of _db_ is implementation-specific. Typically it will + be a file or directory. Not all implementations support arbitrary + package databases. + +`--enable-optimization`[=_n_] or `-O`[_n_] +: (default) Build with optimization flags (if available). This is + appropriate for production use, taking more time to build faster + libraries and programs. + + The optional _n_ value is the optimisation level. Some compilers + support multiple optimisation levels. The range is 0 to 2. Level 0 + is equivalent to `--disable-optimization`, level 1 is the default if + no _n_ parameter is given. Level 2 is higher optimisation if the + compiler supports it. Level 2 is likely to lead to longer compile + times and bigger generated code. + +`--disable-optimization` +: Build without optimization. This is suited for development: building + will be quicker, but the resulting library or programs will be slower. + +`--enable-library-profiling` or `-p` +: Request that an additional version of the library with profiling + features enabled be built and installed (only for implementations + that support profiling). + +`--disable-library-profiling` +: (default) Do not generate an additional profiling version of the + library. + +`--enable-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. + +`--disable-profiling` +: (default) Do not enable profiling in generated executables. + +`--enable-library-vanilla` +: (default) Build ordinary libraries (as opposed to profiling + libraries). This is independent of the `--enable-library-profiling` + option. If you enable both, you get both. + +`--disable-library-vanilla` +: Do not build ordinary libraries. This is useful in conjunction with + `--enable-library-profiling` to build only profiling libraries, + rather than profiling and ordinary libraries. + +`--enable-library-for-ghci` +: (default) Build libraries suitable for use with GHCi. + +`--disable-library-for-ghci` +: Not all platforms support GHCi and indeed on some platforms, trying + to build GHCi libs fails. In such cases this flag can be used as a + workaround. + +`--enable-split-objs` +: Use the GHC `-split-objs` feature when building the library. This + reduces the final size of the executables that use the library by + allowing them to link with only the bits that they use rather than + the entire library. The downside is that building the library takes + longer and uses considerably more memory. + +`--disable-split-objs` +: (default) Do not use the GHC `-split-objs` feature. This makes + building the library quicker but the final executables that use the + library will be larger. + +`--enable-executable-stripping` +: (default) When installing binary executable programs, run the + `strip` program on the binary. This can considerably reduce the size + of the executable binary file. It does this by removing debugging + information and symbols. While such extra information is useful for + debugging C programs with traditional debuggers it is rarely helpful + for debugging binaries produced by Haskell compilers. + + Not all Haskell implementations generate native binaries. For such + implementations this option has no effect. + +`--disable-executable-stripping` +: Do not strip binary executables during installation. You might want + to use this option if you need to debug a program using gdb, for + example if you want to debug the C parts of a program containing + both Haskell and C code. Another reason is if your are building a + package for a system which has a policy of managing the stripping + itself (such as some Linux distributions). + +`--enable-shared` +: Build shared library. This implies a separate compiler run to + generate position independent code as required on most platforms. + +`--disable-shared` +: (default) Do not build shared library. + +`--enable-executable-dynamic` +: Link executables dynamically. The executable's library dependencies should + be built as shared objects. This implies `--enable-shared` unless + `--disable-shared` is explicitly specified. + +`--disable-executable-dynamic` +: (default) Link executables statically. + +`--configure-option=`_str_ +: An extra option to an external `configure` script, if one is used + (see the section on [system-dependent + parameters](developing-packages.html#system-dependent-parameters)). + There can be several of these options. + +`--extra-include-dirs`[=_dir_] +: An extra directory to search for C header files. You can use this + flag multiple times to get a list of directories. + + You might need to use this flag if you have standard system header + files in a non-standard location that is not mentioned in the + package's `.cabal` file. Using this option has the same affect as + appending the directory _dir_ to the `include-dirs` field in each + library and executable in the package's `.cabal` file. The advantage + of course is that you do not have to modify the package at all. + These extra directories will be used while building the package and + for libraries it is also saved in the package registration + information and used when compiling modules that use the library. + +`--extra-lib-dirs`[=_dir_] +: An extra directory to search for system libraries files. You can use + this flag multiple times to get a list of directories. + + You might need to use this flag if you have standard system + libraries in a non-standard location that is not mentioned in the + package's `.cabal` file. Using this option has the same affect as + appending the directory _dir_ to the `extra-lib-dirs` field in each + library and executable in the package's `.cabal` file. The advantage + of course is that you do not have to modify the package at all. + These extra directories will be used while building the package and + for libraries it is also saved in the package registration + information and used when compiling modules that use the library. + +`--allow-newer`[=_pkgs_] +: Selectively relax upper bounds in dependencies without editing the + package description. + + If you want to install a package A that depends on B >= 1.0 && < 2.0, but + you have the version 2.0 of B installed, you can compile A against B 2.0 by + using `cabal install --allow-newer=B A`. This works for the whole package + index: if A also depends on C that in turn depends on B < 2.0, C's + dependency on B will be also relaxed. + + Example: + + ~~~~~~~~~~~~~~~~ + $ cd foo + $ cabal configure + Resolving dependencies... + cabal: Could not resolve dependencies: + [...] + $ cabal configure --allow-newer + Resolving dependencies... + Configuring foo... + ~~~~~~~~~~~~~~~~ + + Additional examples: + + ~~~~~~~~~~~~~~~~ + # Relax upper bounds in all dependencies. + $ cabal install --allow-newer foo + + # Relax upper bounds only in dependencies on bar, baz and quux. + $ cabal install --allow-newer=bar,baz,quux foo + + # Relax the upper bound on bar and force bar==2.1. + $ 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. + +`--constraint=`_constraint_ +: Restrict solutions involving a package to a given version range. + For example, `cabal install --constraint="bar==2.1"` will only consider + install plans that do not use `bar` at all, or `bar` of version 2.1. + + As a special case, `cabal install --constraint="bar -none"` prevents `bar` + from being used at all (`-none` abbreviates `> 1 && < 1`); `cabal install + --constraint="bar installed"` prevents reinstallation of the `bar` package; + `cabal install --constraint="bar +foo -baz"` specifies that the flag `foo` + should be turned on and the `baz` flag should be turned off. + +## setup build ## + +Perform any preprocessing or compilation needed to make this package ready for installation. + +This command takes the following options: + +--_prog_-options=_options_, --_prog_-option=_option_ +: These are mostly the same as the [options configure + step](#setup-configure). Unlike the options specified at the + configure step, any program options specified at the build step are + not persistent but are used for that invocation only. They options + specified at the build step are in addition not in replacement of + any options specified at the configure step. + +## setup haddock ## + +Build the documentation for the package using [haddock][]. By default, +only the documentation for the exposed modules is generated (but see the +`--executables` and `--internal` flags below). + +This command takes the following options: + +`--hoogle` +: Generate a file `dist/doc/html/`_pkgid_`.txt`, which can be + converted by [Hoogle](http://www.haskell.org/hoogle/) into a + database for searching. This is equivalent to running [haddock][] + with the `--hoogle` flag. + +`--html-location=`_url_ +: Specify a template for the location of HTML documentation for + prerequisite packages. The substitutions ([see + listing](#paths-in-the-simple-build-system)) are applied to the + template to obtain a location for each package, which will be used + by hyperlinks in the generated documentation. For example, the + following command generates links pointing at [Hackage] pages: + + > setup haddock --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' + + Here the argument is quoted to prevent substitution by the shell. If + this option is omitted, the location for each package is obtained + using the package tool (e.g. `ghc-pkg`). + +`--executables` +: Also run [haddock][] for the modules of all the executable programs. + By default [haddock][] is run only on the exported modules. + +`--internal` +: Run [haddock][] for the all modules, including unexposed ones, and + make [haddock][] generate documentation for unexported symbols as + well. + +`--css=`_path_ +: The argument _path_ denotes a CSS file, which is passed to + [haddock][] and used to set the style of the generated + documentation. This is only needed to override the default style + that [haddock][] uses. + +`--hyperlink-source` +: Generate [haddock][] documentation integrated with [HsColour][]. + First, [HsColour][] is run to generate colourised code. Then + [haddock][] is run to generate HTML documentation. Each entity + shown in the documentation is linked to its definition in the + colourised code. + +`--hscolour-css=`_path_ +: The argument _path_ denotes a CSS file, which is passed to [HsColour][] as in + + > runhaskell Setup.hs hscolour --css=_path_ + +## setup hscolour ## + +Produce colourised code in HTML format using [HsColour][]. Colourised +code for exported modules is put in `dist/doc/html/`_pkgid_`/src`. + +This command takes the following options: + +`--executables` +: Also run [HsColour][] on the sources of all executable programs. + Colourised code is put in `dist/doc/html/`_pkgid_/_executable_`/src`. + +`--css=`_path_ +: Use the given CSS file for the generated HTML files. The CSS file + defines the colours used to colourise code. Note that this copies + the given CSS file to the directory with the generated HTML files + (renamed to `hscolour.css`) rather than linking to it. + +## setup install ## + +Copy the files into the install locations and (for library packages) +register the package with the compiler, i.e. make the modules it +contains available to programs. + +The [install locations](#installation-paths) are determined by options +to `setup configure`. + +This command takes the following options: + +`--global` +: Register this package in the system-wide database. (This is the + default, unless the `--user` option was supplied to the `configure` + command.) + +`--user` +: Register this package in the user's local package database. (This is + the default if the `--user` option was supplied to the `configure` + command.) + +## setup copy ## + +Copy the files without registering them. This command is mainly of use +to those creating binary packages. + +This command takes the following option: + +`--destdir=`_path_ + +Specify the directory under which to place installed files. If this is +not given, then the root directory is assumed. + +## setup register ## + +Register this package with the compiler, i.e. make the modules it +contains available to programs. This only makes sense for library +packages. Note that the `install` command incorporates this action. The +main use of this separate command is in the post-installation step for a +binary package. + +This command takes the following options: + +`--global` +: Register this package in the system-wide database. (This is the default.) + + +`--user` +: Register this package in the user's local package database. + + +`--gen-script` +: Instead of registering the package, generate a script containing + commands to perform the registration. On Unix, this file is called + `register.sh`, on Windows, `register.bat`. This script might be + included in a binary bundle, to be run after the bundle is unpacked + on the target system. + +`--gen-pkg-config`[=_path_] +: Instead of registering the package, generate a package registration + file. This only applies to compilers that support package + registration files which at the moment is only GHC. The file should + be used with the compiler's mechanism for registering packages. This + option is mainly intended for packaging systems. If possible use the + `--gen-script` option instead since it is more portable across + Haskell implementations. The _path_ is + optional and can be used to specify a particular output file to + generate. Otherwise, by default the file is the package name and + version with a `.conf` extension. + +`--inplace` +: Registers the package for use directly from the build tree, without + needing to install it. This can be useful for testing: there's no + need to install the package after modifying it, just recompile and + test. + + This flag does not create a build-tree-local package database. It + still registers the package in one of the user or global databases. + + However, there are some caveats. It only works with GHC + (currently). It only works if your package doesn't depend on having + any supplemental files installed --- plain Haskell libraries should + be fine. + +## setup unregister ## + +Deregister this package with the compiler. + +This command takes the following options: + +`--global` +: Deregister this package in the system-wide database. (This is the default.) + +`--user` +: Deregister this package in the user's local package database. + +`--gen-script` +: Instead of deregistering the package, generate a script containing + commands to perform the deregistration. On Unix, this file is + called `unregister.sh`, on Windows, `unregister.bat`. This script + might be included in a binary bundle, to be run on the target + system. + +## setup clean ## + +Remove any local files created during the `configure`, `build`, +`haddock`, `register` or `unregister` steps, and also any files and +directories listed in the `extra-tmp-files` field. + +This command takes the following options: + +`--save-configure` or `-s` +: Keeps the configuration information so it is not necessary to run + the configure step again before building. + +## setup test ## + +Run the test suites specified in the package description file. Aside from +the following flags, Cabal accepts the name of one or more test suites on the +command line after `test`. When supplied, Cabal will run only the named test +suites, otherwise, Cabal will run all test suites in the package. + +`--builddir=`_dir_ +: The directory where Cabal puts generated build files (default: `dist`). + Test logs will be located in the `test` subdirectory. + +`--human-log=`_path_ +: The template used to name human-readable test logs; the path is relative + to `dist/test`. By default, logs are named according to the template + `$pkgid-$test-suite.log`, so that each test suite will be logged to its own + human-readable log file. Template variables allowed are: `$pkgid`, + `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`, `$test-suite`, and `$result`. + +`--machine-log=`_path_ +: The path to the machine-readable log, relative to `dist/test`. The default + template is `$pkgid.log`. Template variables allowed are: `$pkgid`, + `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` and `$result`. + +`--show-details=`_filter_ +: Determines if the results of individual test cases are shown on the + terminal. May be `always` (always show), `never` (never show), `failures` + (show only failed results), or `streaming` (show all results in real time). + +`--test-options=`_options_ +: Give extra options to the test executables. + +`--test-option=`_option_ +: give an extra option to the test executables. There is no need to quote + options containing spaces because a single option is assumed, so options + will not be split on spaces. + +## setup sdist ## + +Create a system- and compiler-independent source distribution in a file +_package_-_version_`.tar.gz` in the `dist` subdirectory, for +distribution to package builders. When unpacked, the commands listed in +this section will be available. + +The files placed in this distribution are the package description file, +the setup script, the sources of the modules named in the package +description file, and files named in the `license-file`, `main-is`, +`c-sources`, `js-sources`, `data-files`, `extra-source-files` and +`extra-doc-files` fields. + +This command takes the following option: + +`--snapshot` +: Append today's date (in "YYYYMMDD" format) to the version number for + the generated source package. The original package is unaffected. + + +[dist-simple]: ../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html +[dist-make]: ../release/cabal-latest/doc/API/Cabal/Distribution-Make.html +[dist-license]: ../release/cabal-latest/doc/API/Cabal/Distribution-License.html#t:License +[extension]: ../release/cabal-latest/doc/API/Cabal/Language-Haskell-Extension.html#t:Extension +[BuildType]: ../release/cabal-latest/doc/API/Cabal/Distribution-PackageDescription.html#t:BuildType +[alex]: http://www.haskell.org/alex/ +[autoconf]: http://www.gnu.org/software/autoconf/ +[c2hs]: http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ +[cpphs]: http://projects.haskell.org/cpphs/ +[greencard]: http://hackage.haskell.org/package/greencard +[haddock]: http://www.haskell.org/haddock/ +[HsColour]: http://www.cs.york.ac.uk/fp/darcs/hscolour/ +[happy]: http://www.haskell.org/happy/ +[Hackage]: http://hackage.haskell.org/ +[pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/ diff --git a/doc/misc.markdown b/doc/misc.markdown new file mode 100644 --- /dev/null +++ b/doc/misc.markdown @@ -0,0 +1,109 @@ +% Cabal User Guide + +# Reporting bugs and deficiencies # + +Please report any flaws or feature requests in the [bug tracker][]. + +For general discussion or queries email the libraries mailing list +. There is also a development mailing list +. + +[bug tracker]: https://github.com/haskell/cabal/issues + +# Stability of Cabal interfaces # + +The Cabal library and related infrastructure is still under active +development. New features are being added and limitations and bugs are +being fixed. This requires internal changes and often user visible +changes as well. We therefore cannot promise complete future-proof +stability, at least not without halting all development work. + +This section documents the aspects of the Cabal interface that we can +promise to keep stable and which bits are subject to change. + +## Cabal file format ## + +This is backwards compatible and mostly forwards compatible. New fields +can be added without breaking older versions of Cabal. Fields can be +deprecated without breaking older packages. + +## Command-line interface ## + +### Very Stable Command-line interfaces ### + +* `./setup configure` + * `--prefix` + * `--user` + * `--ghc`, `--uhc` + * `--verbose` + * `--prefix` + +* `./setup build` +* `./setup install` +* `./setup register` +* `./setup copy` + +### Stable Command-line interfaces ### + +### Unstable command-line ### + +## Functions and Types ## + +The Cabal library follows the [Package Versioning Policy][PVP]. This +means that within a stable major release, for example 1.2.x, there will +be no incompatible API changes. But minor versions increments, for +example 1.2.3, indicate compatible API additions. + +The Package Versioning Policy does not require any API guarantees +between major releases, for example between 1.2.x and 1.4.x. In practise +of course not everything changes between major releases. Some parts of +the API are more prone to change than others. The rest of this section +gives some informal advice on what level of API stability you can expect +between major releases. + +[PVP]: http://www.haskell.org/haskellwiki/Package_versioning_policy + +### Very Stable API ### + +* `defaultMain` + +* `defaultMainWithHooks defaultUserHooks` + + But regular `defaultMainWithHooks` isn't stable since `UserHooks` + changes. + +### Semi-stable API ### + +* `UserHooks` The hooks API will change in the future + +* `Distribution.*` is mostly declarative information about packages and + is somewhat stable. + +### Unstable API ### + +Everything under `Distribution.Simple.*` has no stability guarantee. + +## Hackage ## + +The index format is a partly stable interface. It consists of a tar.gz +file that contains directories with `.cabal` files in. In future it may +contain more kinds of files so do not assume every file is a `.cabal` +file. Incompatible revisions to the format would involve bumping the +name of the index file, i.e., `00-index.tar.gz`, `01-index.tar.gz` etc. + + +[dist-simple]: ../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html +[dist-make]: ../release/cabal-latest/doc/API/Cabal/Distribution-Make.html +[dist-license]: ../release/cabal-latest/doc/API/Cabal/Distribution-License.html#t:License +[extension]: ../release/cabal-latest/doc/API/Cabal/Language-Haskell-Extension.html#t:Extension +[BuildType]: ../release/cabal-latest/doc/API/Cabal/Distribution-PackageDescription.html#t:BuildType +[alex]: http://www.haskell.org/alex/ +[autoconf]: http://www.gnu.org/software/autoconf/ +[c2hs]: http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ +[cpphs]: http://projects.haskell.org/cpphs/ +[greencard]: http://hackage.haskell.org/package/greencard +[haddock]: http://www.haskell.org/haddock/ +[HsColour]: http://www.cs.york.ac.uk/fp/darcs/hscolour/ +[happy]: http://www.haskell.org/happy/ +[Hackage]: http://hackage.haskell.org/ +[pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/ diff --git a/tests/PackageTests.hs b/tests/PackageTests.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests.hs @@ -0,0 +1,172 @@ +-- The intention is that this will be the new unit test framework. +-- Please add any working tests here. This file should do nothing +-- but import tests from other modules. +-- +-- Stephen Blackheath, 2009 + +module Main where + +import 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 Distribution.Simple.Configure + ( ConfigStateFileError(..), getConfigStateFile ) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.Program.Types (programPath) +import Distribution.Simple.Program.Builtin + ( ghcProgram, ghcPkgProgram, haddockProgram ) +import Distribution.Simple.Program.Db (requireProgram) +import Distribution.Simple.Utils (cabalVersion) +import Distribution.Text (display) +import Distribution.Verbosity (normal) +import Distribution.Version (Version(Version)) + +import Control.Exception (try, throw) +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 + +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 []) + +main :: IO () +main = do + -- WORKAROUND: disable buffering on stdout to get streaming test logs + -- test providers _should_ do this themselves + hSetBuffering stdout NoBuffering + + 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" + -- Create a shared Setup executable to speed up Simple tests + compileSetup "." ghcPath + defaultMain (tests cabalVersion inplaceSpec ghcPath ghcPkgPath) + +-- Like Distribution.Simple.Configure.getPersistBuildConfig but +-- doesn't check that the Cabal version matches, which it doesn't when +-- we run Cabal's own test suite, due to bootstrapping issues. +getPersistBuildConfig_ :: FilePath -> IO LocalBuildInfo +getPersistBuildConfig_ filename = do + eLBI <- try $ getConfigStateFile filename + case eLBI of + Left (ConfigStateFileBadVersion _ _ (Right lbi)) -> return lbi + Left (ConfigStateFileBadVersion _ _ (Left err)) -> throw err + Left err -> throw err + Right lbi -> return lbi diff --git a/tests/PackageTests/BenchmarkExeV10/Check.hs b/tests/PackageTests/BenchmarkExeV10/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkExeV10/Check.hs @@ -0,0 +1,16 @@ +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/BenchmarkExeV10/Foo.hs b/tests/PackageTests/BenchmarkExeV10/Foo.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkExeV10/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +fooTest :: [String] -> Bool +fooTest _ = True diff --git a/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs b/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs @@ -0,0 +1,8 @@ +module Main where + +import Foo +import System.Exit + +main :: IO () +main | fooTest [] = exitSuccess + | otherwise = exitFailure diff --git a/tests/PackageTests/BenchmarkExeV10/my.cabal b/tests/PackageTests/BenchmarkExeV10/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkExeV10/my.cabal @@ -0,0 +1,15 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.9.2 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base + +benchmark bench-Foo + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: bench-Foo.hs + build-depends: base, my diff --git a/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal b/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal @@ -0,0 +1,20 @@ +name: BenchmarkOptions +version: 0.1 +license: BSD3 +author: Johan Tibell +stability: stable +category: PackageTests +build-type: Simple +cabal-version: >= 1.9.2 + +description: + Check that Cabal passes the correct test options to test suites. + +executable dummy + main-is: test-BenchmarkOptions.hs + build-depends: base + +benchmark test-BenchmarkOptions + main-is: test-BenchmarkOptions.hs + type: exitcode-stdio-1.0 + build-depends: base diff --git a/tests/PackageTests/BenchmarkOptions/Check.hs b/tests/PackageTests/BenchmarkOptions/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkOptions/Check.hs @@ -0,0 +1,26 @@ +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/BenchmarkOptions/test-BenchmarkOptions.hs b/tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs @@ -0,0 +1,11 @@ +module Main where + +import System.Environment ( getArgs ) +import System.Exit ( exitFailure, exitSuccess ) + +main :: IO () +main = do + args <- getArgs + if args == ["1", "2", "3"] + then exitSuccess + else putStrLn ("Got: " ++ show args) >> exitFailure diff --git a/tests/PackageTests/BenchmarkStanza/Check.hs b/tests/PackageTests/BenchmarkStanza/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkStanza/Check.hs @@ -0,0 +1,52 @@ +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.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 + { benchmarkName = "dummy" + , 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 diff --git a/tests/PackageTests/BenchmarkStanza/my.cabal b/tests/PackageTests/BenchmarkStanza/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkStanza/my.cabal @@ -0,0 +1,19 @@ +name: BenchmarkStanza +version: 0.1 +license: BSD3 +author: Johan Tibell +stability: stable +category: PackageTests +build-type: Simple + +description: + Check that Cabal recognizes the benchmark stanza defined below. + +Library + exposed-modules: MyLibrary + build-depends: base + +benchmark dummy + main-is: dummy.hs + type: exitcode-stdio-1.0 + build-depends: base diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs @@ -0,0 +1,22 @@ +module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List +import Control.Exception +import Prelude hiding (catch) + + +suite :: 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 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal @@ -0,0 +1,20 @@ +name: GlobalBuildDepsNotAdditive1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + If you specify 'base' in the global build dependencies, then define + a library without base, it fails to find 'base' for the library. + +--------------------------------------- + +build-depends: base + +Library + exposed-modules: MyLibrary + build-depends: bytestring, old-time diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs @@ -0,0 +1,22 @@ +module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List +import Control.Exception +import Prelude hiding (catch) + + +suite :: 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 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal @@ -0,0 +1,20 @@ +name: GlobalBuildDepsNotAdditive1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + If you specify 'base' in the global build dependencies, then define + an executable without base, it fails to find 'base' for the executable + +--------------------------------------- + +build-depends: base + +Executable lemon + main-is: lemon.hs + build-depends: bytestring, old-time diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs @@ -0,0 +1,22 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal @@ -0,0 +1,24 @@ +name: InternalLibrary0 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check that with 'cabal-version:' containing versions less than 1.7, we do *not* + have the new behaviour to allow executables to refer to the library defined + in the same module. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary0 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs b/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs @@ -0,0 +1,16 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new (in >= 1.7.1) ability to allow executables to refer to + the library defined in the same module. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary1 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs b/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs @@ -0,0 +1,32 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary2 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name and version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary2 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs b/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs b/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal @@ -0,0 +1,18 @@ +name: InternalLibrary2 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name and version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time diff --git a/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs @@ -0,0 +1,32 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary3 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name, but a *newer* version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary3 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs b/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs b/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal @@ -0,0 +1,18 @@ +name: InternalLibrary3 +version: 0.2 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name but a *newer* version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time diff --git a/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs @@ -0,0 +1,32 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary4 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that we can explicitly say we want InternalLibrary4-0.2 + and it will give us the *installed* version 0.2 instead of the internal 0.1. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary4 >= 0.2 diff --git a/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs b/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs b/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal b/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal @@ -0,0 +1,18 @@ +name: InternalLibrary4 +version: 0.2 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name but a *newer* version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time diff --git a/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs b/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs @@ -0,0 +1,21 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal b/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal @@ -0,0 +1,31 @@ +name: SameDepsAllRound +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +synopsis: Same dependencies all round +category: PackageTests +build-type: Simple + +description: + Check for the "old build-dep behaviour" namely that we get the same + package dependencies on all build targets, even if different ones + were specified for different targets + . + Here all .hs files use the three packages mentioned, so this shows + that build-depends is not target-specific. This is the behaviour + we want when cabal-version contains versions less than 1.7. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring + +Executable lemon + main-is: lemon.hs + build-depends: old-time + +Executable pineapple + main-is: pineapple.hs diff --git a/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs b/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs b/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "pineapple" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs @@ -0,0 +1,29 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal @@ -0,0 +1,22 @@ +name: TargetSpecificDeps1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new build-dep behaviour, where build-depends are + handled specifically for each target + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring + +Executable lemon + main-is: lemon.hs + build-depends: base, bytestring, old-time diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs @@ -0,0 +1,21 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs @@ -0,0 +1,5 @@ +import qualified Data.ByteString.Char8 as C + +main = do + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal @@ -0,0 +1,24 @@ +name: TargetSpecificDeps1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new build-dep behaviour, where build-depends are + handled specifically for each target + This one is a control against TargetSpecificDeps1 - it is correct and should + succeed. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + build-depends: base, bytestring diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs @@ -0,0 +1,28 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal @@ -0,0 +1,22 @@ +name: test +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new build-dep behaviour, where build-depends are + handled specifically for each target + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + build-depends: base, bytestring diff --git a/tests/PackageTests/BuildTestSuiteDetailedV09/Check.hs b/tests/PackageTests/BuildTestSuiteDetailedV09/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildTestSuiteDetailedV09/Check.hs @@ -0,0 +1,18 @@ +module PackageTests.BuildTestSuiteDetailedV09.Check where + +import Test.HUnit +import System.FilePath (()) + +import PackageTests.PackageTester + +suite :: PackageSpec -> FilePath -> Test +suite inplaceSpec ghcPath = TestCase $ do + let dir = "PackageTests" "BuildTestSuiteDetailedV09" + spec = inplaceSpec + { directory = dir + , configOpts = "--enable-tests" : configOpts inplaceSpec + } + confResult <- cabal_configure spec ghcPath + assertConfigureSucceeded confResult + buildResult <- cabal_build spec ghcPath + assertBuildSucceeded buildResult diff --git a/tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs b/tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs @@ -0,0 +1,6 @@ +module Dummy where + +import Distribution.TestSuite (Test) + +tests :: IO [Test] +tests = return [] diff --git a/tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal b/tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal @@ -0,0 +1,20 @@ +name: BuildTestSuiteDetailedV09 +version: 0.1 +cabal-version: >= 1.2 +license: BSD3 +author: Thomas Tuegel +stability: stable +category: PackageTests +build-type: Simple + +description: + Check that Cabal can build test suites of type detailed-0.9. + +Library + exposed-modules: Dummy + build-depends: base, Cabal + +test-suite test-Dummy + type: detailed-0.9 + test-module: Dummy + build-depends: base, Cabal diff --git a/tests/PackageTests/CMain/Bar.hs b/tests/PackageTests/CMain/Bar.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/CMain/Bar.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Bar where + +bar :: IO () +bar = return () + +foreign export ccall bar :: IO () diff --git a/tests/PackageTests/CMain/Check.hs b/tests/PackageTests/CMain/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/CMain/Check.hs @@ -0,0 +1,20 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/CMain/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/tests/PackageTests/CMain/foo.c b/tests/PackageTests/CMain/foo.c new file mode 100644 --- /dev/null +++ b/tests/PackageTests/CMain/foo.c @@ -0,0 +1,13 @@ +#include +#include "HsFFI.h" + +#ifdef __GLASGOW_HASKELL__ +#include "Bar_stub.h" +#endif + +int main(int argc, char **argv) { + hs_init(&argc, &argv); + bar(); + printf("Hello world!"); + return 0; +} diff --git a/tests/PackageTests/CMain/my.cabal b/tests/PackageTests/CMain/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/CMain/my.cabal @@ -0,0 +1,10 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.9.2 +build-type: Simple + +executable foo + main-is: foo.c + other-modules: Bar + build-depends: base diff --git a/tests/PackageTests/DeterministicAr/Check.hs b/tests/PackageTests/DeterministicAr/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/DeterministicAr/Check.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module PackageTests.DeterministicAr.Check where + +import Control.Monad +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.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 + + let distBuild = dir "dist" "build" + libdir <- ghcPkg_field1 this "library-dirs" ghcPkgPath + lbi <- getPersistBuildConfig (dir "dist") + mapM_ (checkMetadata lbi) [distBuild, libdir] + unregister this ghcPkgPath + +-- Almost a copypasta of Distribution.Simple.Program.Ar.wipeMetadata +checkMetadata :: LocalBuildInfo -> FilePath -> Assertion +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" + + ghc_7_10 = case compilerId (compiler lbi) of + CompilerId GHC version | version >= Version [7, 10] [] -> True + _ -> False + + checkError msg = assertFailure' $ + "PackageTests.DeterministicAr.checkMetadata: " ++ msg ++ + " in " ++ path + archLF = "!\x0a" -- global magic, 8 bytes + x60LF = "\x60\x0a" -- header magic, 2 bytes + metadata = BS.concat + [ "0 " -- mtime, 12 bytes + , "0 " -- UID, 6 bytes + , "0 " -- GID, 6 bytes + , "0644 " -- mode, 8 bytes + ] + headerSize = 60 + + -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details + checkArchive :: Handle -> Integer -> IO () + checkArchive h archiveSize = do + global <- BS.hGet h (BS.length archLF) + unless (global == archLF) $ checkError "Bad global header" + checkHeader (toInteger $ BS.length archLF) + + where + checkHeader :: Integer -> IO () + checkHeader offset = case compare offset archiveSize of + EQ -> return () + GT -> checkError (atOffset "Archive truncated") + LT -> do + header <- BS.hGet h headerSize + unless (BS.length header == headerSize) $ + checkError (atOffset "Short header") + let magic = BS.drop 58 header + unless (magic == x60LF) . checkError . atOffset $ + "Bad magic " ++ show magic ++ " in header" + + unless (metadata == BS.take 32 (BS.drop 16 header)) + . checkError . atOffset $ "Metadata has changed" + + let size = BS.take 10 $ BS.drop 48 header + objSize <- case reads (BS8.unpack size) of + [(n, s)] | all isSpace s -> return n + _ -> checkError (atOffset "Bad file size in header") + + let nextHeader = offset + toInteger headerSize + + -- Odd objects are padded with an extra '\x0a' + if odd objSize then objSize + 1 else objSize + hSeek h AbsoluteSeek nextHeader + checkHeader nextHeader + + where + atOffset msg = msg ++ " at offset " ++ show offset diff --git a/tests/PackageTests/DeterministicAr/Lib.hs b/tests/PackageTests/DeterministicAr/Lib.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/DeterministicAr/Lib.hs @@ -0,0 +1,5 @@ +module Lib where + +dummy :: IO () +dummy = return () + diff --git a/tests/PackageTests/DeterministicAr/my.cabal b/tests/PackageTests/DeterministicAr/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/DeterministicAr/my.cabal @@ -0,0 +1,17 @@ +name: DeterministicAr +version: 0 +license: BSD3 +cabal-version: >= 1.9.1 +author: Liyang HU +stability: stable +category: PackageTests +build-type: Simple + +description: + Ensure our GNU ar -D emulation (#1537) works as advertised: check that + all metadata in the resulting .a archive match the default. + +Library + exposed-modules: Lib + build-depends: base + diff --git a/tests/PackageTests/EmptyLib/Check.hs b/tests/PackageTests/EmptyLib/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/EmptyLib/Check.hs @@ -0,0 +1,16 @@ +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/EmptyLib/empty/empty.cabal b/tests/PackageTests/EmptyLib/empty/empty.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/EmptyLib/empty/empty.cabal @@ -0,0 +1,6 @@ +name: emptyLib +Cabal-version: >= 1.2 +version: 1.0 +build-type: Simple + +Library diff --git a/tests/PackageTests/Haddock/CPP.hs b/tests/PackageTests/Haddock/CPP.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/Haddock/CPP.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} + +module CPP where + +#define HIDING hiding +#define NEEDLES needles + +-- | For HIDING NEEDLES. +data Haystack = Haystack diff --git a/tests/PackageTests/Haddock/Check.hs b/tests/PackageTests/Haddock/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/Haddock/Check.hs @@ -0,0 +1,42 @@ +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/Haddock/Literate.lhs b/tests/PackageTests/Haddock/Literate.lhs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/Haddock/Literate.lhs @@ -0,0 +1,4 @@ +> module Literate where + +> -- | For hiding needles. +> data Haystack = Haystack diff --git a/tests/PackageTests/Haddock/NoCPP.hs b/tests/PackageTests/Haddock/NoCPP.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/Haddock/NoCPP.hs @@ -0,0 +1,8 @@ +module NoCPP (Haystack) where + +-- | For hiding needles. +data Haystack = Haystack + +-- | Causes a build failure if the CPP language extension is enabled. +stringGap = "Foo\ +\Bar" diff --git a/tests/PackageTests/Haddock/Simple.hs b/tests/PackageTests/Haddock/Simple.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/Haddock/Simple.hs @@ -0,0 +1,4 @@ +module Simple where + +-- | For hiding needles. +data Haystack = Haystack diff --git a/tests/PackageTests/Haddock/my.cabal b/tests/PackageTests/Haddock/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/Haddock/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/PackageTests/OrderFlags/Check.hs b/tests/PackageTests/OrderFlags/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/OrderFlags/Check.hs @@ -0,0 +1,24 @@ +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/OrderFlags/Foo.hs b/tests/PackageTests/OrderFlags/Foo.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/OrderFlags/Foo.hs @@ -0,0 +1,8 @@ +module Foo where + +x :: IO Int +x = return 5 + +f :: IO Int +f = do x + return 3 diff --git a/tests/PackageTests/OrderFlags/my.cabal b/tests/PackageTests/OrderFlags/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/OrderFlags/my.cabal @@ -0,0 +1,20 @@ +name: OrderFlags +version: 0.1 +license: BSD3 +author: Oleksandr Manzyuk +stability: stable +category: PackageTests +build-type: Simple +cabal-version: >=1.9.2 + +description: + Check that Cabal correctly orders flags that are passed to GHC. + +library + exposed-modules: Foo + build-depends: base + + ghc-options: -Wall -Werror + + if impl(ghc >= 6.12.1) + ghc-options: -fno-warn-unused-do-bind diff --git a/tests/PackageTests/PackageTester.hs b/tests/PackageTests/PackageTester.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PackageTester.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- You can set the following VERBOSE environment variable to control +-- the verbosity of the output generated by this module. +module PackageTests.PackageTester + ( PackageSpec(..) + , Success(..) + , Result(..) + + -- * Running cabal commands + , cabal_configure + , cabal_build + , cabal_haddock + , cabal_test + , cabal_bench + , cabal_install + , unregister + , compileSetup + , run + + -- * Test helpers + , assertConfigureSucceeded + , assertBuildSucceeded + , assertBuildFailed + , assertHaddockSucceeded + , assertTestSucceeded + , assertInstallSucceeded + , assertOutputContains + , assertOutputDoesNotContain + ) where + +import qualified Control.Exception.Extensible as E +import Control.Monad +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 System.FilePath +import System.IO (hIsEOF, hGetChar, hClose) +import System.IO.Error (isDoesNotExistError) +import System.Process (runProcess, waitForProcess) +import Test.HUnit (Assertion, assertFailure) + +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) + +data PackageSpec = PackageSpec + { directory :: FilePath + , distPref :: Maybe FilePath + , configOpts :: [String] + } + +data Success = Failure + | ConfigureSuccess + | BuildSuccess + | HaddockSuccess + | InstallSuccess + | TestSuccess + | BenchSuccess + deriving (Eq, Show) + +data Result = Result + { successful :: Bool + , success :: Success + , outputText :: String + } deriving Show + +nullResult :: Result +nullResult = Result True Failure "" + +------------------------------------------------------------------------ +-- * Running cabal commands + +recordRun :: (String, ExitCode, String) -> Success -> Result -> Result +recordRun (cmd, exitCode, exeOutput) thisSucc res = + res { successful = successful res && exitCode == ExitSuccess + , success = if exitCode == ExitSuccess then thisSucc + else success res + , outputText = + (if null $ outputText res then "" else outputText res ++ "\n") ++ + cmd ++ "\n" ++ exeOutput + } + +cabal_configure :: PackageSpec -> FilePath -> IO Result +cabal_configure spec ghcPath = do + res <- doCabalConfigure spec ghcPath + record spec res + return res + +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 + +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 + +cabal_build :: PackageSpec -> FilePath -> IO Result +cabal_build spec ghcPath = do + res <- doCabalBuild spec ghcPath + record spec res + return res + +cabal_haddock :: PackageSpec -> [String] -> FilePath -> IO Result +cabal_haddock spec extraArgs ghcPath = do + res <- doCabalHaddock spec extraArgs ghcPath + record spec res + return res + +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 + +unregister :: String -> FilePath -> IO () +unregister libraryName ghcPkgPath = do + res@(_, _, output) <- run Nothing ghcPkgPath [] ["unregister", "--user", libraryName] + if "cannot find package" `isInfixOf` output + then return () + else requireSuccess res + +-- | Install this library in the user area +cabal_install :: PackageSpec -> 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 + +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 + +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 + +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 + +-- | 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") + if customSetup + then do + compileSetup (directory spec) ghcPath + path <- canonicalizePath $ directory spec "Setup" + run (Just $ directory spec) path envOverrides cabalArgs + else do + -- Use shared Setup executable (only for Simple build types). + path <- canonicalizePath "Setup" + run (Just $ directory spec) path envOverrides 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 + verbosity <- getVerbosity + -- path is relative to the current directory; canonicalizePath makes it + -- absolute, so that runProcess will find it even when changing directory. + path' <- do pathExists <- doesFileExist path + canonicalizePath (if pathExists then path else path <.> exeExtension) + menv <- getEffectiveEnvironment envOverrides + + printRawCommandAndArgsAndEnv verbosity path' args menv + (readh, writeh) <- createPipe + pid <- runProcess path' args cwd menv Nothing (Just writeh) (Just writeh) + + -- fork off a thread to start consuming the output + out <- suckH [] readh + 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 + + +requireSuccess :: (String, ExitCode, String) -> IO () +requireSuccess (cmd, exitCode, output) = + unless (exitCode == ExitSuccess) $ + assertFailure $ "Command " ++ cmd ++ " failed.\n" ++ + "output: " ++ output + +record :: PackageSpec -> Result -> IO () +record spec res = do + C.writeFile (directory spec "test-log.txt") (C.pack $ outputText res) + +------------------------------------------------------------------------ +-- * Test helpers + +assertConfigureSucceeded :: Result -> Assertion +assertConfigureSucceeded result = unless (successful result) $ + assertFailure $ + "expected: \'setup configure\' should succeed\n" ++ + " output: " ++ outputText result + +assertBuildSucceeded :: Result -> Assertion +assertBuildSucceeded result = unless (successful result) $ + assertFailure $ + "expected: \'setup build\' should succeed\n" ++ + " output: " ++ outputText result + +assertBuildFailed :: Result -> Assertion +assertBuildFailed result = when (successful result) $ + assertFailure $ + "expected: \'setup build\' should fail\n" ++ + " output: " ++ outputText result + +assertHaddockSucceeded :: Result -> Assertion +assertHaddockSucceeded result = unless (successful result) $ + assertFailure $ + "expected: \'setup haddock\' should succeed\n" ++ + " output: " ++ outputText result + +assertTestSucceeded :: Result -> Assertion +assertTestSucceeded result = unless (successful result) $ + assertFailure $ + "expected: \'setup test\' should succeed\n" ++ + " output: " ++ outputText result + +assertInstallSucceeded :: Result -> Assertion +assertInstallSucceeded result = unless (successful result) $ + assertFailure $ + "expected: \'setup install\' should succeed\n" ++ + " output: " ++ outputText result + +assertOutputContains :: String -> Result -> Assertion +assertOutputContains needle result = + unless (needle `isInfixOf` (concatOutput output)) $ + assertFailure $ + " expected: " ++ needle ++ "\n" ++ + " in output: " ++ output ++ "" + where output = outputText result + +assertOutputDoesNotContain :: String -> Result -> Assertion +assertOutputDoesNotContain needle result = + when (needle `isInfixOf` (concatOutput output)) $ + assertFailure $ + "unexpected: " ++ needle ++ + " in output: " ++ output + where output = outputText result + +-- | Replace line breaks with spaces, correctly handling "\r\n". +concatOutput :: String -> String +concatOutput = unwords . lines . filter ((/=) '\r') + +------------------------------------------------------------------------ +-- Verbosity + +lookupEnv :: String -> IO (Maybe String) +lookupEnv name = + (fmap Just $ getEnv name) + `E.catch` \ (e :: IOError) -> + if isDoesNotExistError e + then return Nothing + else E.throw e + +-- TODO: Convert to a "-v" flag instead. +getVerbosity :: IO Verbosity +getVerbosity = do + maybe normal (readEOrFail flagToVerbosity) `fmap` lookupEnv "VERBOSE" diff --git a/tests/PackageTests/PathsModule/Executable/Check.hs b/tests/PackageTests/PathsModule/Executable/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PathsModule/Executable/Check.hs @@ -0,0 +1,16 @@ +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/Executable/Main.hs b/tests/PackageTests/PathsModule/Executable/Main.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PathsModule/Executable/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import Paths_PathsModule (getBinDir) + +main :: IO () +main = do + _ <- getBinDir + return () diff --git a/tests/PackageTests/PathsModule/Executable/my.cabal b/tests/PackageTests/PathsModule/Executable/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PathsModule/Executable/my.cabal @@ -0,0 +1,16 @@ +name: PathsModule +version: 0.1 +license: BSD3 +author: Johan Tibell +stability: stable +category: PackageTests +build-type: Simple +Cabal-version: >= 1.2 + +description: + Check that the generated paths module compiles. + +Executable TestPathsModule + main-is: Main.hs + other-modules: Paths_PathsModule + build-depends: base diff --git a/tests/PackageTests/PathsModule/Library/Check.hs b/tests/PackageTests/PathsModule/Library/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PathsModule/Library/Check.hs @@ -0,0 +1,16 @@ +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/PathsModule/Library/my.cabal b/tests/PackageTests/PathsModule/Library/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PathsModule/Library/my.cabal @@ -0,0 +1,15 @@ +name: PathsModule +version: 0.1 +license: BSD3 +author: Johan Tibell +stability: stable +category: PackageTests +build-type: Simple +Cabal-version: >= 1.2 + +description: + Check that the generated paths module compiles. + +Library + exposed-modules: Paths_PathsModule + build-depends: base diff --git a/tests/PackageTests/PreProcess/Check.hs b/tests/PackageTests/PreProcess/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PreProcess/Check.hs @@ -0,0 +1,16 @@ +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/PreProcess/Foo.hsc b/tests/PackageTests/PreProcess/Foo.hsc new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PreProcess/Foo.hsc @@ -0,0 +1,1 @@ +module Foo where diff --git a/tests/PackageTests/PreProcess/Main.hs b/tests/PackageTests/PreProcess/Main.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PreProcess/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Foo + +main :: IO () +main = return () diff --git a/tests/PackageTests/PreProcess/my.cabal b/tests/PackageTests/PreProcess/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PreProcess/my.cabal @@ -0,0 +1,32 @@ +name: PreProcess +version: 0.1 +license: BSD3 +author: Johan Tibell +stability: stable +category: PackageTests +build-type: Simple +Cabal-version: >= 1.2 + +description: + Check that preprocessors are run. + +Library + exposed-modules: Foo + build-depends: base + +Executable my-executable + main-is: Main.hs + other-modules: Foo + build-depends: base + +Test-Suite my-test-suite + main-is: Main.hs + type: exitcode-stdio-1.0 + other-modules: Foo + build-depends: base + +Benchmark my-benchmark + main-is: Main.hs + type: exitcode-stdio-1.0 + other-modules: Foo + build-depends: base diff --git a/tests/PackageTests/ReexportedModules/Check.hs b/tests/PackageTests/ReexportedModules/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/ReexportedModules/Check.hs @@ -0,0 +1,41 @@ +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/ReexportedModules/ReexportedModules.cabal b/tests/PackageTests/ReexportedModules/ReexportedModules.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/ReexportedModules/ReexportedModules.cabal @@ -0,0 +1,11 @@ +name: ReexportedModules +version: 0.1.0.0 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.21 + +library + build-depends: base, containers + reexported-modules: containers:Data.Map as DataMap diff --git a/tests/PackageTests/TemplateHaskell/Check.hs b/tests/PackageTests/TemplateHaskell/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/Check.hs @@ -0,0 +1,41 @@ +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/TemplateHaskell/dynamic/Exe.hs b/tests/PackageTests/TemplateHaskell/dynamic/Exe.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/dynamic/Exe.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import TH + +main = print $(splice) diff --git a/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs b/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/dynamic/Lib.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Lib where + +import TH + +val = $(splice) diff --git a/tests/PackageTests/TemplateHaskell/dynamic/TH.hs b/tests/PackageTests/TemplateHaskell/dynamic/TH.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/dynamic/TH.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH where + +splice = [| () |] diff --git a/tests/PackageTests/TemplateHaskell/dynamic/my.cabal b/tests/PackageTests/TemplateHaskell/dynamic/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/dynamic/my.cabal @@ -0,0 +1,15 @@ +Name: templateHaskell +Version: 0.1 +Build-Type: Simple +Cabal-Version: >= 1.2 + +Library + Exposed-Modules: Lib + Other-Modules: TH + Build-Depends: base, template-haskell + Extensions: TemplateHaskell + +Executable main + Main-is: Exe.hs + Build-Depends: base, template-haskell + Extensions: TemplateHaskell diff --git a/tests/PackageTests/TemplateHaskell/profiling/Exe.hs b/tests/PackageTests/TemplateHaskell/profiling/Exe.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/profiling/Exe.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import TH + +main = print $(splice) diff --git a/tests/PackageTests/TemplateHaskell/profiling/Lib.hs b/tests/PackageTests/TemplateHaskell/profiling/Lib.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/profiling/Lib.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Lib where + +import TH + +val = $(splice) diff --git a/tests/PackageTests/TemplateHaskell/profiling/TH.hs b/tests/PackageTests/TemplateHaskell/profiling/TH.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/profiling/TH.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH where + +splice = [| () |] diff --git a/tests/PackageTests/TemplateHaskell/profiling/my.cabal b/tests/PackageTests/TemplateHaskell/profiling/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/profiling/my.cabal @@ -0,0 +1,15 @@ +Name: templateHaskell +Version: 0.1 +Build-Type: Simple +Cabal-Version: >= 1.2 + +Library + Exposed-Modules: Lib + Other-Modules: TH + Build-Depends: base, template-haskell + Extensions: TemplateHaskell + +Executable main + Main-is: Exe.hs + Build-Depends: base, template-haskell + Extensions: TemplateHaskell diff --git a/tests/PackageTests/TemplateHaskell/vanilla/Exe.hs b/tests/PackageTests/TemplateHaskell/vanilla/Exe.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/vanilla/Exe.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import TH + +main = print $(splice) diff --git a/tests/PackageTests/TemplateHaskell/vanilla/Lib.hs b/tests/PackageTests/TemplateHaskell/vanilla/Lib.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/vanilla/Lib.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module Lib where + +import TH + +val = $(splice) diff --git a/tests/PackageTests/TemplateHaskell/vanilla/TH.hs b/tests/PackageTests/TemplateHaskell/vanilla/TH.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/vanilla/TH.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH where + +splice = [| () |] diff --git a/tests/PackageTests/TemplateHaskell/vanilla/my.cabal b/tests/PackageTests/TemplateHaskell/vanilla/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TemplateHaskell/vanilla/my.cabal @@ -0,0 +1,15 @@ +Name: templateHaskell +Version: 0.1 +Build-Type: Simple +Cabal-Version: >= 1.2 + +Library + Exposed-Modules: Lib + Other-Modules: TH + Build-Depends: base, template-haskell + Extensions: TemplateHaskell + +Executable main + Main-is: Exe.hs + Build-Depends: base, template-haskell + Extensions: TemplateHaskell diff --git a/tests/PackageTests/TestOptions/Check.hs b/tests/PackageTests/TestOptions/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestOptions/Check.hs @@ -0,0 +1,26 @@ +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/TestOptions/TestOptions.cabal b/tests/PackageTests/TestOptions/TestOptions.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestOptions/TestOptions.cabal @@ -0,0 +1,20 @@ +name: TestOptions +version: 0.1 +license: BSD3 +author: Thomas Tuegel +stability: stable +category: PackageTests +build-type: Simple +cabal-version: >= 1.9.2 + +description: + Check that Cabal passes the correct test options to test suites. + +executable dummy + main-is: test-TestOptions.hs + build-depends: base + +test-suite test-TestOptions + main-is: test-TestOptions.hs + type: exitcode-stdio-1.0 + build-depends: base diff --git a/tests/PackageTests/TestOptions/test-TestOptions.hs b/tests/PackageTests/TestOptions/test-TestOptions.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestOptions/test-TestOptions.hs @@ -0,0 +1,11 @@ +module Main where + +import System.Environment ( getArgs ) +import System.Exit ( exitFailure, exitSuccess ) + +main :: IO () +main = do + args <- getArgs + if args == ["1", "2", "3"] + then exitSuccess + else putStrLn ("Got: " ++ show args) >> exitFailure diff --git a/tests/PackageTests/TestStanza/Check.hs b/tests/PackageTests/TestStanza/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestStanza/Check.hs @@ -0,0 +1,53 @@ +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.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 + { 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 diff --git a/tests/PackageTests/TestStanza/my.cabal b/tests/PackageTests/TestStanza/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestStanza/my.cabal @@ -0,0 +1,19 @@ +name: TestStanza +version: 0.1 +license: BSD3 +author: Thomas Tuegel +stability: stable +category: PackageTests +build-type: Simple + +description: + Check that Cabal recognizes the Test stanza defined below. + +Library + exposed-modules: MyLibrary + build-depends: base + +test-suite dummy + main-is: dummy.hs + type: exitcode-stdio-1.0 + build-depends: base diff --git a/tests/PackageTests/TestSuiteExeV10/Check.hs b/tests/PackageTests/TestSuiteExeV10/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteExeV10/Check.hs @@ -0,0 +1,147 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteExeV10/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +fooTest :: [String] -> Bool +fooTest _ = True diff --git a/tests/PackageTests/TestSuiteExeV10/my.cabal b/tests/PackageTests/TestSuiteExeV10/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteExeV10/my.cabal @@ -0,0 +1,15 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.9.2 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base + +test-suite test-Foo + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: test-Foo.hs + build-depends: base, my diff --git a/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs b/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs @@ -0,0 +1,8 @@ +module Main where + +import Foo +import System.Exit + +main :: IO () +main | fooTest [] = exitSuccess + | otherwise = exitFailure diff --git a/tests/README.md b/tests/README.md new file mode 100644 --- /dev/null +++ b/tests/README.md @@ -0,0 +1,34 @@ +Writing package tests +===================== + +The tests under the [PackageTests] directory define and build packages +that exercise various components of Cabal. Each test case is an [HUnit] +test. The entry point for the test suite, where all the test cases are +listed, is [PackageTests.hs]. There are utilities for calling the stages +of Cabal's build process in [PackageTests/PackageTester.hs]; have a look +at an existing test case to see how they 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: + +1. Compiling `Setup.hs`. `runghc` needs to be told about the in-place + package database. This issue should be solved for all future package + tests; see `compileSetup` in [PackageTests/PackageTester.hs]. + +2. Compiling a package which depends on Cabal. In particular, packages + with 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. + +[PackageTests]: PackageTests +[HUnit]: http://hackage.haskell.org/package/HUnit +[PackageTests.hs]: PackageTests.hs +[PackageTests/PackageTester.hs]: PackageTests/PackageTester.hs +[detailed]: ../Distribution/TestSuite.hs +[PackageTests/BuildTestSuiteDetailedV09/Check.hs]: PackageTests/BuildTestSuiteDetailedV09/Check.hs diff --git a/tests/Setup.hs b/tests/Setup.hs new file mode 100644 --- /dev/null +++ b/tests/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests.hs @@ -0,0 +1,27 @@ +module Main + ( main + ) where + +import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout) +import Test.Framework + +import qualified UnitTests.Distribution.Compat.CreatePipe +import qualified UnitTests.Distribution.Compat.ReadP +import qualified UnitTests.Distribution.Utils.NubList + +tests :: [Test] +tests = + [ testGroup "Distribution.Compat.ReadP" + UnitTests.Distribution.Compat.ReadP.tests + , testGroup "Distribution.Compat.CreatePipe" + UnitTests.Distribution.Compat.CreatePipe.tests + , testGroup "Distribution.Utils.NubList" + UnitTests.Distribution.Utils.NubList.tests + ] + +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 diff --git a/tests/UnitTests/Distribution/Compat/CreatePipe.hs b/tests/UnitTests/Distribution/Compat/CreatePipe.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Compat/CreatePipe.hs @@ -0,0 +1,20 @@ +module UnitTests.Distribution.Compat.CreatePipe (tests) where + +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) + +tests :: [Test] +tests = [testCase "Locale Encoding" case_Locale_Encoding] + +case_Locale_Encoding :: Assertion +case_Locale_Encoding = assert $ do + let str = "\0252" + (r, w) <- createPipe + hSetEncoding w localeEncoding + out <- hGetContents r + hPutStr w str + hClose w + return $! out == str diff --git a/tests/UnitTests/Distribution/Compat/ReadP.hs b/tests/UnitTests/Distribution/Compat/ReadP.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Compat/ReadP.hs @@ -0,0 +1,153 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compat.ReadP +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This code was originally in Distribution.Compat.ReadP. Please see that file +-- for provenance. The tests have been integrated into the test framework. +-- Some properties cannot be tested, as they hold over arbitrary ReadP values, +-- and we don't have a good Arbitrary instance (nor Show instance) for ReadP. +-- +module UnitTests.Distribution.Compat.ReadP + ( tests + -- * Properties + -- $properties + ) where + +import Data.List +import Distribution.Compat.ReadP +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +tests :: [Test] +tests = + [ testProperty "Get Nil" prop_Get_Nil + , testProperty "Get Cons" prop_Get_Cons + , testProperty "Look" prop_Look + , testProperty "Fail" prop_Fail + , testProperty "Return" prop_Return + --, testProperty "Bind" prop_Bind + --, testProperty "Plus" prop_Plus + --, testProperty "LeftPlus" prop_LeftPlus + --, testProperty "Gather" prop_Gather + , testProperty "String Yes" prop_String_Yes + , testProperty "String Maybe" prop_String_Maybe + , testProperty "Munch" (prop_Munch evenChar) + , testProperty "Munch1" (prop_Munch1 evenChar) + --, testProperty "Choice" prop_Choice + --, testProperty "ReadS" prop_ReadS + ] + +-- --------------------------------------------------------------------------- +-- QuickCheck properties that hold for the combinators + +{- $properties +The following are QuickCheck specifications of what the combinators do. +These can be seen as formal specifications of the behavior of the +combinators. + +We use bags to give semantics to the combinators. +-} + +type Bag a = [a] + +-- Equality on bags does not care about the order of elements. + +(=~) :: Ord a => Bag a -> Bag a -> Bool +xs =~ ys = sort xs == sort ys + +-- A special equality operator to avoid unresolved overloading +-- when testing the properties. + +(=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool +(=~.) = (=~) + +-- Here follow the properties: + +prop_Get_Nil :: Bool +prop_Get_Nil = + readP_to_S get [] =~ [] + +prop_Get_Cons :: Char -> [Char] -> Bool +prop_Get_Cons c s = + readP_to_S get (c:s) =~ [(c,s)] + +prop_Look :: String -> Bool +prop_Look s = + readP_to_S look s =~ [(s,s)] + +prop_Fail :: String -> Bool +prop_Fail s = + readP_to_S pfail s =~. [] + +prop_Return :: Int -> String -> Bool +prop_Return x s = + readP_to_S (return x) s =~. [(x,s)] + +{- +prop_Bind p k s = + readP_to_S (p >>= k) s =~. + [ ys'' + | (x,s') <- readP_to_S p s + , ys'' <- readP_to_S (k (x::Int)) s' + ] + +prop_Plus :: ReadP Int Int -> ReadP Int Int -> String -> Bool +prop_Plus p q s = + readP_to_S (p +++ q) s =~. + (readP_to_S p s ++ readP_to_S q s) + +prop_LeftPlus :: ReadP Int Int -> ReadP Int Int -> String -> Bool +prop_LeftPlus p q s = + readP_to_S (p <++ q) s =~. + (readP_to_S p s +<+ readP_to_S q s) + where + [] +<+ ys = ys + xs +<+ _ = xs + +prop_Gather s = + forAll readPWithoutReadS $ \p -> + readP_to_S (gather p) s =~ + [ ((pre,x::Int),s') + | (x,s') <- readP_to_S p s + , let pre = take (length s - length s') s + ] +-} + +prop_String_Yes :: String -> [Char] -> Bool +prop_String_Yes this s = + readP_to_S (string this) (this ++ s) =~ + [(this,s)] + +prop_String_Maybe :: String -> String -> Bool +prop_String_Maybe this s = + readP_to_S (string this) s =~ + [(this, drop (length this) s) | this `isPrefixOf` s] + +prop_Munch :: (Char -> Bool) -> String -> Bool +prop_Munch p s = + readP_to_S (munch p) s =~ + [(takeWhile p s, dropWhile p s)] + +prop_Munch1 :: (Char -> Bool) -> String -> Bool +prop_Munch1 p s = + readP_to_S (munch1 p) s =~ + [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)] + +{- +prop_Choice :: [ReadP Int Int] -> String -> Bool +prop_Choice ps s = + readP_to_S (choice ps) s =~. + readP_to_S (foldr (+++) pfail ps) s + +prop_ReadS :: ReadS Int -> String -> Bool +prop_ReadS r s = + readP_to_S (readS_to_P r) s =~. r s +-} + +evenChar :: Char -> Bool +evenChar = even . fromEnum diff --git a/tests/UnitTests/Distribution/Utils/NubList.hs b/tests/UnitTests/Distribution/Utils/NubList.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Utils/NubList.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} +module UnitTests.Distribution.Utils.NubList + ( tests + ) where + +#if __GLASGOW_HASKELL__ < 710 +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) + +tests :: [Test] +tests = + [ testCase "Numlist retains ordering" testOrdering + , testCase "Numlist removes duplicates" testDeDupe + , testProperty "Monoid Numlist Identity" prop_Identity + , testProperty "Monoid Numlist Associativity" prop_Associativity + ] + +someIntList :: [Int] +-- This list must not have duplicate entries. +someIntList = [ 1, 3, 4, 2, 0, 7, 6, 5, 9, -1 ] + +testOrdering :: Assertion +testOrdering = + assertBool "Maintains element ordering:" $ + fromNubList (toNubList someIntList) == someIntList + +testDeDupe :: Assertion +testDeDupe = + assertBool "De-duplicates a list:" $ + fromNubList (toNubList (someIntList ++ someIntList)) == someIntList + +-- --------------------------------------------------------------------------- +-- QuickCheck properties for NubList + +prop_Identity :: [Int] -> Bool +prop_Identity xs = + mempty `mappend` toNubList xs == toNubList xs `mappend` mempty + +prop_Associativity :: [Int] -> [Int] -> [Int] -> Bool +prop_Associativity xs ys zs = + (toNubList xs `mappend` toNubList ys) `mappend` toNubList zs + == toNubList xs `mappend` (toNubList ys `mappend` toNubList zs) diff --git a/tests/hackage/check.sh b/tests/hackage/check.sh new file mode 100644 --- /dev/null +++ b/tests/hackage/check.sh @@ -0,0 +1,25 @@ +#!/bin/sh + +base_version=1.4.0.2 +test_version=1.5.6 + +for setup in archive/*/*/Setup.hs archive/*/*/Setup.lhs; do + + pkgname=$(basename ${setup}) + + if test $(wc -w < ${setup}) -gt 21; then + if ghc -package Cabal-${base_version} -S ${setup} -o /dev/null 2> /dev/null; then + + if ghc -package Cabal-${test_version} -S ${setup} -o /dev/null 2> /dev/null; then + echo "OK ${setup}" + else + echo "FAIL ${setup} does not compile with Cabal-${test_version}" + fi + else + echo "OK ${setup} (does not compile with Cabal-${base_version})" + fi + else + echo "trivial ${setup}" + fi + +done diff --git a/tests/hackage/download.sh b/tests/hackage/download.sh new file mode 100644 --- /dev/null +++ b/tests/hackage/download.sh @@ -0,0 +1,19 @@ +#!/bin/sh + +if test ! -f archive/archive.tar; then + + wget http://hackage.haskell.org/cgi-bin/hackage-scripts/archive.tar + mkdir -p archive + mv archive.tar archive/ + tar -C archive -xf archive/archive.tar + +fi + +if test ! -f archive/00-index.tar.gz; then + + wget http://hackage.haskell.org/packages/archive/00-index.tar.gz + mkdir -p archive + mv 00-index.tar.gz archive/ + tar -C archive -xzf archive/00-index.tar.gz + +fi diff --git a/tests/hackage/unpack.sh b/tests/hackage/unpack.sh new file mode 100644 --- /dev/null +++ b/tests/hackage/unpack.sh @@ -0,0 +1,16 @@ +#!/bin/sh + +for tarball in archive/*/*/*.tar.gz; do + + pkgdir=$(dirname ${tarball}) + pkgname=$(basename ${tarball} .tar.gz) + + if tar -tzf ${tarball} ${pkgname}/Setup.hs 2> /dev/null; then + tar -xzf ${tarball} ${pkgname}/Setup.hs -O > ${pkgdir}/Setup.hs + elif tar -tzf ${tarball} ${pkgname}/Setup.lhs 2> /dev/null; then + tar -xzf ${tarball} ${pkgname}/Setup.lhs -O > ${pkgdir}/Setup.lhs + else + echo "${pkgname} has no Setup.hs or .lhs at all!!?!" + fi + +done diff --git a/tests/misc/ghc-supported-languages.hs b/tests/misc/ghc-supported-languages.hs new file mode 100644 --- /dev/null +++ b/tests/misc/ghc-supported-languages.hs @@ -0,0 +1,97 @@ +-- | A test program to check that ghc has got all of its extensions registered +-- +module Main where + +import Language.Haskell.Extension +import Distribution.Text +import Distribution.Simple.Utils +import Distribution.Verbosity + +import Data.List ((\\)) +import Data.Maybe +import Control.Applicative +import Control.Monad +import System.Environment +import System.Exit + +-- | A list of GHC extensions that are deliberately not registered, +-- e.g. due to being experimental and not ready for public consumption +-- +exceptions = map readExtension [] + +checkProblems :: [Extension] -> [String] +checkProblems implemented = + + let unregistered = + [ ext | ext <- implemented -- extensions that ghc knows about + , not (registered ext) -- but that are not registered + , ext `notElem` exceptions ] -- except for the exceptions + + -- check if someone has forgotten to update the exceptions list... + + -- exceptions that are not implemented + badExceptions = exceptions \\ implemented + + -- exceptions that are now registered + badExceptions' = filter registered exceptions + + in catMaybes + [ check unregistered $ unlines + [ "The following extensions are known to GHC but are not in the " + , "extension registry in Language.Haskell.Extension." + , " " ++ intercalate "\n " (map display unregistered) + , "If these extensions are ready for public consumption then they " + , "should be registered. If they are still experimental and you " + , "think they are not ready to be registered then please add them " + , "to the exceptions list in this test program along with an " + , "explanation." + ] + , check badExceptions $ unlines + [ "Error in the extension exception list. The following extensions" + , "are listed as exceptions but are not even implemented by GHC:" + , " " ++ intercalate "\n " (map display badExceptions) + , "Please fix this test program by correcting the list of" + , "exceptions." + ] + , check badExceptions' $ unlines + [ "Error in the extension exception list. The following extensions" + , "are listed as exceptions to registration but they are in fact" + , "now registered in Language.Haskell.Extension:" + , " " ++ intercalate "\n " (map display badExceptions') + , "Please fix this test program by correcting the list of" + , "exceptions." + ] + ] + where + registered (UnknownExtension _) = False + registered _ = True + + check [] _ = Nothing + check _ i = Just i + + +main = topHandler $ do + [ghcPath] <- getArgs + exts <- getExtensions ghcPath + let problems = checkProblems exts + putStrLn (intercalate "\n" problems) + if null problems + then exitSuccess + else exitFailure + +getExtensions :: FilePath -> IO [Extension] +getExtensions ghcPath = + map readExtension . lines + <$> rawSystemStdout normal ghcPath ["--supported-languages"] + +readExtension :: String -> Extension +readExtension str = handleNoParse $ do + -- GHC defines extensions in a positive way, Cabal defines them + -- relative to H98 so we try parsing ("No" ++ extName) first + ext <- simpleParse ("No" ++ str) + case ext of + UnknownExtension _ -> simpleParse str + _ -> return ext + where + handleNoParse :: Maybe Extension -> Extension + handleNoParse = fromMaybe (error $ "unparsable extension " ++ show str)