packages feed

Cabal-ide-backend (empty) → 1.23.0.0

raw patch · 216 files changed

+40754/−0 lines, 216 filesdep +Cabaldep +Cabal-ide-backenddep +HUnitbuild-type:Customsetup-changed

Dependencies added: Cabal, Cabal-ide-backend, HUnit, QuickCheck, array, base, binary, bytestring, containers, deepseq, directory, extensible-exceptions, filepath, ghc-prim, old-time, pretty, process, regex-posix, test-framework, test-framework-hunit, test-framework-quickcheck2, time, unix

Files

+ Cabal-ide-backend.cabal view
@@ -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 <ijones@syntaxpolice.org>+        Duncan Coutts <duncan@community.haskell.org>+maintainer: cabal-devel@haskell.org+homepage: http://www.haskell.org/cabal/+bug-reports: https://github.com/haskell/cabal/issues+synopsis: A framework for packaging Haskell software+description:+  NOTE: This is a temporary fork of Cabal necessary for+  <https://github.com/fpco/ide-backend>. 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
+ Distribution/Compat/Binary.hs view
@@ -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
+ Distribution/Compat/Binary/Class.hs view
@@ -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 <kolmodin@gmail.com>+-- 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)
+ Distribution/Compat/Binary/Generic.hs view
@@ -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 <bos@serpentine.com>+-- 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
+ Distribution/Compat/CopyFile.hs view
@@ -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
+ Distribution/Compat/CreatePipe.hs view
@@ -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
+ Distribution/Compat/Environment.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}++module Distribution.Compat.Environment (getEnvironment)+       where++import qualified System.Environment as System++#ifdef mingw32_HOST_OS+import qualified Data.Char as Char (toUpper)+#endif++getEnvironment :: IO [(String, String)]+#ifdef mingw32_HOST_OS+-- On Windows, the names of environment variables are case-insensitive, but are+-- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise+-- them.+getEnvironment = fmap upcaseVars System.getEnvironment+  where+    upcaseVars = map upcaseVar+    upcaseVar (var, val) = (map Char.toUpper var, val)+#else+getEnvironment = System.getEnvironment+#endif
+ Distribution/Compat/Exception.hs view
@@ -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
+ Distribution/Compat/ReadP.hs view
@@ -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/+-- (<http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.19.9217>).+--+-- This version of ReadP has been locally hacked to make it H98, by+-- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>+--+-- The unit tests have been moved to UnitTest.Distribution.Compat.ReadP, by+-- Mark Lentczner <mailto:mark@glyphic.com>+-----------------------------------------------------------------------------++module Distribution.Compat.ReadP+  (+  -- * The 'ReadP' type+  ReadP,      -- :: * -> *; instance Functor, Monad, MonadPlus++  -- * Primitive operations+  get,        -- :: ReadP Char+  look,       -- :: ReadP String+  (+++),      -- :: ReadP a -> ReadP a -> ReadP a+  (<++),      -- :: ReadP a -> ReadP a -> ReadP a+  gather,     -- :: ReadP a -> ReadP (String, a)++  -- * Other operations+  pfail,      -- :: ReadP a+  satisfy,    -- :: (Char -> Bool) -> ReadP Char+  char,       -- :: Char -> ReadP Char+  string,     -- :: String -> ReadP String+  munch,      -- :: (Char -> Bool) -> ReadP String+  munch1,     -- :: (Char -> Bool) -> ReadP String+  skipSpaces, -- :: ReadP ()+  choice,     -- :: [ReadP a] -> ReadP a+  count,      -- :: Int -> ReadP a -> ReadP [a]+  between,    -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a+  option,     -- :: a -> ReadP a -> ReadP a+  optional,   -- :: ReadP a -> ReadP ()+  many,       -- :: ReadP a -> ReadP [a]+  many1,      -- :: ReadP a -> ReadP [a]+  skipMany,   -- :: ReadP a -> ReadP ()+  skipMany1,  -- :: ReadP a -> ReadP ()+  sepBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]+  sepBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]+  endBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]+  endBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]+  chainr,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+  chainl,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+  chainl1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+  chainr1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+  manyTill,   -- :: ReadP a -> ReadP end -> ReadP [a]++  -- * Running a parser+  ReadS,      -- :: *; = String -> [(a,String)]+  readP_to_S, -- :: ReadP a -> ReadS a+  readS_to_P  -- :: ReadS a -> ReadP a+  )+ where++import Control.Monad( MonadPlus(..), 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']))
+ Distribution/Compat/TempFile.hs view
@@ -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
+ Distribution/Compiler.hs view
@@ -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
+ Distribution/GetOpt.hs view
@@ -0,0 +1,335 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.GetOpt+-- Copyright   :  (c) Sven Panne 2002-2005+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- This library provides facilities for parsing the command-line options+-- in a standalone program.  It is essentially a Haskell port of the GNU+-- @getopt@ library.+--+-----------------------------------------------------------------------------++{-+Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small+changes Dec. 1997)++Two rather obscure features are missing: The Bash 2.0 non-option hack+(if you don't already know it, you probably don't want to hear about+it...) and the recognition of long options with a single dash+(e.g. '-help' is recognised as '--help', as long as there is no short+option 'h').++Other differences between GNU's getopt and this implementation:++* To enforce a coherent description of options and arguments, there+  are explanation fields in the option/argument descriptor.++* Error messages are now more informative, but no longer POSIX+  compliant... :-(++And a final Haskell advertisement: The GNU C implementation uses well+over 1100 lines, we need only 195 here, including a 46 line example!+:-)+-}++{-# 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..."++-}
+ Distribution/InstalledPackageInfo.hs view
@@ -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)+  ]
+ Distribution/License.hs view
@@ -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+-- <https://en.wikipedia.org/wiki/License_compatibility licensing conflicts>,+-- and to deter+-- <https://en.wikipedia.org/wiki/License_proliferation license proliferation>.+--+-- 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+-- <http://www.haskell.org/cabal/users-guide/developing-packages.html#package-descriptions Cabal users guide>.+--+-- = Additional resources+--+-- The following websites provide information about free and open source+-- software licenses:+--+-- * <http://www.opensource.org The Open Source Initiative (OSI)>+--+-- * <https://www.fsf.org The Free Software Foundation (FSF)>+--+-- = 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,+    -- <https://www.gnu.org/licenses/old-licenses/gpl-2.0.html version 2> or+    -- <https://www.gnu.org/licenses/gpl.html version 3>.+    GPL (Maybe Version)++    -- | <https://www.gnu.org/licenses/agpl.html GNU Affero General Public License, version 3>.+  | AGPL (Maybe Version)++    -- | GNU Lesser General Public License,+    -- <https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html version 2.1> or+    -- <https://www.gnu.org/licenses/lgpl.html version 3>.+  | LGPL (Maybe Version)++    -- | <http://www.opensource.org/licenses/bsd-license 2-clause BSD license>.+  | BSD2++    -- | <http://www.opensource.org/licenses/bsd-3-clause 3-clause BSD license>.+  | BSD3++    -- | <http://directory.fsf.org/wiki/License:BSD_4Clause 4-clause BSD license>.+    -- 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++    -- | <http://www.opensource.org/licenses/MIT MIT license>.+  | MIT++    -- | <http://www.isc.org/downloads/software-support-policy/isc-license/ ISC license>+  | ISC++    -- | <https://www.mozilla.org/MPL/ Mozilla Public License, version 2.0>.+  | MPL Version++    -- | <https://www.apache.org/licenses/ Apache License, version 2.0>.+  | 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
+ Distribution/Make.hs view
@@ -0,0 +1,184 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Make+-- Copyright   :  Martin Sj&#xF6;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"]
+ Distribution/ModuleName.hs view
@@ -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
+ Distribution/Package.hs view
@@ -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]
+ Distribution/PackageDescription.hs view
@@ -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)
+ Distribution/PackageDescription/Check.hs view
@@ -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)
+ Distribution/PackageDescription/Configuration.hs view
@@ -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
+ Distribution/PackageDescription/Parse.hs view
@@ -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)+  }
+ Distribution/PackageDescription/PrettyPrint.hs view
@@ -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+++
+ Distribution/PackageDescription/Utils.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.PackageDescription.Utils+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Common utils used by modules under Distribution.PackageDescription.*.++module Distribution.PackageDescription.Utils (+  cabalBug, userBug+  ) where++-- ----------------------------------------------------------------------------+-- Exception and logging utils++userBug :: String -> a+userBug msg = error $ msg ++ ". This is a bug in your .cabal file."++cabalBug :: String -> a+cabalBug msg = error $ msg ++ ". This is possibly a bug in Cabal.\n"+               ++ "Please report it to the developers: "+               ++ "https://github.com/haskell/cabal/issues/new"
+ Distribution/ParseUtils.hs view
@@ -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 @<property>: <value>@ field+    | Section LineNo String String [Field]+      -- ^ A section with a name and possible parameter.  The syntactic+      -- structure is:+      --+      -- @+      --   <sectionname> <arg> {+      --     <field>*+      --   }+      -- @+    | IfBlock LineNo String [Field] [Field]+      -- ^ A conditional block with an optional else branch:+      --+      -- @+      --  if <condition> {+      --    <field>*+      --  } else {+      --    <field>*+      --  }+      -- @+      deriving (Show+               ,Eq)   -- for testing++lineNo :: Field -> LineNo+lineNo (F n _ _) = n+lineNo (Section n _ _ _) = n+lineNo (IfBlock n _ _ _) = n++fName :: Field -> String+fName (F _ n _) = n+fName (Section _ n _ _) = n+fName _ = error "fname: not a field or section"++readFields :: String -> ParseResult [Field]+readFields input = ifelse+               =<< mapM (mkField 0)+               =<< mkTree tokens++  where ls = (lines . normaliseLineEndings) input+        tokens = (concatMap tokeniseLine . trimLines) ls++readFieldsFlat :: String -> ParseResult [Field]+readFieldsFlat input = mapM (mkField 0)+                   =<< mkTree tokens+  where ls = (lines . normaliseLineEndings) input+        tokens = (concatMap tokeniseLineFlat . trimLines) ls++-- attach line number and determine indentation+trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)]+trimLines ls = [ (lineno, indent, hastabs, trimTrailing l')+               | (lineno, l) <- zip [1..] ls+               , let (sps, l') = span isSpace l+                     indent    = length sps+                     hastabs   = '\t' `elem` sps+               , validLine l' ]+  where validLine ('-':'-':_) = False      -- Comment+        validLine []          = False      -- blank line+        validLine _           = True++-- | We parse generically based on indent level and braces '{' '}'. To do that+-- we split into lines and then '{' '}' tokens and other spans within a line.+data Token =+       -- | The 'Line' token is for bits that /start/ a line, eg:+       --+       -- > "\n  blah blah { blah"+       --+       -- tokenises to:+       --+       -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"]+       --+       -- so lines are the only ones that can have nested layout, since they+       -- have a known indentation level.+       --+       -- eg: we can't have this:+       --+       -- > if ... {+       -- > } else+       -- >     other+       --+       -- because other cannot nest under else, since else doesn't start a line+       -- so cannot have nested layout. It'd have to be:+       --+       -- > if ... {+       -- > }+       -- >   else+       -- >     other+       --+       -- but that's not so common, people would normally use layout or+       -- brackets not both in a single @if else@ construct.+       --+       -- > if ... { foo : bar }+       -- > else+       -- >    other+       --+       -- this is OK+       Line LineNo Indent HasTabs String+     | Span LineNo                String  -- ^ span in a line, following brackets+     | OpenBracket LineNo | CloseBracket LineNo++type Indent = Int+type HasTabs = Bool++-- | Tokenise a single line, splitting on '{' '}' and the spans 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
+ Distribution/ReadE.hs view
@@ -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
+ Distribution/Simple.hs view
@@ -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)
+ Distribution/Simple/Bench.hs view
@@ -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)]
+ Distribution/Simple/Build.hs view
@@ -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_<pkg>.hs and cabal_macros.h files+--+writeAutogenFiles :: Verbosity+                  -> PackageDescription+                  -> LocalBuildInfo+                  -> IO ()+writeAutogenFiles verbosity pkg lbi = do+  createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi)++  let pathsModulePath = autogenModulesDir lbi+                    </> ModuleName.toFilePath (autogenModuleName pkg) <.> "hs"+  rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi)++  let cppHeaderPath = autogenModulesDir lbi </> cppHeaderName+  rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi)++-- | Check that the given build targets are valid in the current context.+--+-- Also swizzle into a more convenient form.+--+checkBuildTargets :: Verbosity -> PackageDescription -> [BuildTarget]+                  -> IO [(ComponentName, Maybe (Either ModuleName FilePath))]+checkBuildTargets _ pkg []      =+    return [ (componentName c, Nothing) | c <- pkgEnabledComponents pkg ]++checkBuildTargets verbosity pkg targets = do++    let (enabled, disabled) =+          partitionEithers+            [ case componentDisabledReason (getComponent pkg cname) of+                Nothing     -> Left  target'+                Just reason -> Right (cname, reason)+            | target <- targets+            , let target'@(cname,_) = swizzleTarget target ]++    case disabled of+      []                 -> return ()+      ((cname,reason):_) -> die $ formatReason (showComponentName cname) reason++    forM_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) ->+      warn verbosity $ "Ignoring '" ++ either display id t ++ ". The whole "+                    ++ showComponentName c ++ " will be built. (Support for "+                    ++ "module and file targets has not been implemented yet.)"++    return enabled++  where+    swizzleTarget (BuildTargetComponent c)   = (c, Nothing)+    swizzleTarget (BuildTargetModule    c m) = (c, Just (Left  m))+    swizzleTarget (BuildTargetFile      c f) = (c, Just (Right f))++    formatReason cn DisabledComponent =+        "Cannot build the " ++ cn ++ " because the component is marked "+     ++ "as disabled in the .cabal file."+    formatReason cn DisabledAllTests =+        "Cannot build the " ++ cn ++ " because test suites are not "+     ++ "enabled. Run configure with the flag --enable-tests"+    formatReason cn DisabledAllBenchmarks =+        "Cannot build the " ++ cn ++ " because benchmarks are not "+     ++ "enabled. Re-run configure with the flag --enable-benchmarks"
+ Distribution/Simple/Build/Macros.hs view
@@ -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_<package>+-- > MIN_VERSION_<package>(A,B,C)+--+-- for each /package/ in @build-depends@, which is true if the version of+-- /package/ in use is @>= A.B.C@, using the normal ordering on version+-- numbers.+--+module Distribution.Simple.Build.Macros (+    generate,+    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
+ Distribution/Simple/Build/PathsModule.hs view
@@ -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_<pkg>.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")
+ Distribution/Simple/BuildPaths.hs view
@@ -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<packagename>-<compilerFlavour><compilerVersion>+-- 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"
+ Distribution/Simple/BuildTarget.hs view
@@ -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
+ Distribution/Simple/CCompiler.hs view
@@ -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
+ Distribution/Simple/Command.hs view
@@ -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 [])
+ Distribution/Simple/Compiler.hs view
@@ -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
+ Distribution/Simple/Configure.hs view
@@ -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
+ Distribution/Simple/GHC.hs view
@@ -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"
+ Distribution/Simple/GHC/IPI641.hs view
@@ -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+  }
+ Distribution/Simple/GHC/IPI642.hs view
@@ -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+  }
+ Distribution/Simple/GHC/ImplInfo.hs view
@@ -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
+ Distribution/Simple/GHC/Internal.hs view
@@ -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)."
+ Distribution/Simple/GHCJS.hs view
@@ -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
+ Distribution/Simple/Haddock.hs view
@@ -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
+ Distribution/Simple/HaskellSuite.hs view
@@ -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
+ Distribution/Simple/Hpc.hs view
@@ -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
+ Distribution/Simple/Install.hs view
@@ -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?"
+ Distribution/Simple/InstallDirs.hs view
@@ -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
+ Distribution/Simple/JHC.hs view
@@ -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)
+ Distribution/Simple/LHC.hs view
@@ -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 <ldLibName>.tmp, and any existing file+            -- named <ldLibName> is included when linking. The+            -- output is renamed to <libName>.+          rawSystemProgramConf verbosity ldProgram (withPrograms lbi)+            (args ++ if exists then [ldLibName] else [])+          renameFile (ldLibName <.> "tmp") ldLibName++        runAr = rawSystemProgramConf verbosity arProgram (withPrograms lbi)++         --TODO: discover this at configure time or runtime on Unix+         -- The value is 32k on Windows and POSIX specifies a minimum of 4k+         -- but all sensible Unixes use more than 4k.+         -- we could use getSysVar ArgumentLimit but that's in the Unix lib+        maxCommandLineSize = 30 * 1024++    ifVanillaLib False $ xargs maxCommandLineSize+      runAr arArgs arObjArgs++    ifProfLib $ xargs maxCommandLineSize+      runAr arProfArgs arProfObjArgs++    ifGHCiLib $ xargs maxCommandLineSize+      (runLd ghciLibFilePath) ldArgs ldObjArgs++    ifSharedLib $ runGhcProg ghcSharedLinkArgs+++-- | Build an executable with LHC.+--+buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo+                      -> Executable         -> ComponentLocalBuildInfo -> IO ()+buildExe verbosity _pkg_descr lbi+  exe@Executable { exeName = exeName', modulePath = modPath } clbi = do+  let pref = buildDir lbi+      runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)++  exeBi <- hackThreadedFlag verbosity+             (compiler lbi) (withProfExe lbi) (buildInfo exe)++  -- exeNameReal, the name that GHC really uses (with .exe on Windows)+  let exeNameReal = exeName' <.>+                    (if null $ takeExtension exeName' then exeExtension else "")++  let targetDir = pref </> exeName'+  let exeDir    = targetDir </> (exeName' ++ "-tmp")+  createDirectoryIfMissingVerbose verbosity True targetDir+  createDirectoryIfMissingVerbose verbosity True exeDir+  -- TODO: do we need to put hs-boot files into place for mutually recursive modules?+  -- FIX: what about exeName.hi-boot?++  -- build executables+  unless (null (cSources exeBi)) $ do+   info verbosity "Building C Sources."+   sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi+                                          exeDir filename verbosity+                 createDirectoryIfMissingVerbose verbosity True odir+                 runGhcProg args+             | filename <- cSources exeBi]++  srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath++  let cObjs = map (`replaceExtension` objExtension) (cSources exeBi)+  let lhcWrap x = ("--ghc-opts\"":x) ++ ["\""]+  let binArgs linkExe profExe =+             (if linkExe+                 then ["-o", targetDir </> exeNameReal]+                 else ["-c"])+          ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity+          ++ [exeDir </> x | x <- cObjs]+          ++ [srcMainFile]+          ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi]+          ++ ["-l"++lib | lib <- extraLibs exeBi]+          ++ ["-L"++libDir | libDir <- extraLibDirs exeBi]+          ++ concat [["-framework", f] | f <- PD.frameworks exeBi]+          ++ if profExe+                then ["-prof",+                      "-hisuf", "p_hi",+                      "-osuf", "p_o"+                     ] ++ 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
+ Distribution/Simple/LocalBuildInfo.hs view
@@ -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)
+ Distribution/Simple/PackageIndex.hs view
@@ -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!
+ Distribution/Simple/PreProcess.hs view
@@ -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)+  ]
+ Distribution/Simple/PreProcess/Unlit.hs view
@@ -0,0 +1,165 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.PreProcess.Unlit+-- Copyright   :  ...+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Remove the \"literal\" markups from a Haskell source file, including+-- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\"++-- This version is interesting because instead of striping comment lines, it+-- turns them into "-- " style comments. This allows using haddock markup+-- in literate scripts without having to use "> --" prefix.++module Distribution.Simple.PreProcess.Unlit (unlit,plain) where++import Data.Char+import Data.List++data Classified = BirdTrack String | Blank String | Ordinary String+                | Line !Int String | CPP String+                | BeginCode | EndCode+                -- output only:+                | Error String | Comment String++-- | No unliteration.+plain :: String -> String -> String+plain _ hs = hs++classify :: String -> Classified+classify ('>':s) = BirdTrack s+classify ('#':s) = case tokens s of+                     (line:file:_) | all isDigit line+                                  && length file >= 2+                                  && head file == '"'+                                  && last file == '"'+                                -> Line (read line) (tail (init file))+                     _          -> CPP s+  where tokens = unfoldr $ \str -> case lex str of+                                   (t@(_:_), str'):_ -> Just (t, str')+                                   _                 -> Nothing+classify ('\\':s)+  | "begin{code}" `isPrefixOf` s = BeginCode+  | "end{code}"   `isPrefixOf` s = EndCode+classify s | all isSpace s       = Blank s+classify s                       = Ordinary s++-- So the weird exception for comment indenting is to make things work with+-- haddock, see classifyAndCheckForBirdTracks below.+unclassify :: Bool -> Classified -> String+unclassify _     (BirdTrack s) = ' ':s+unclassify _     (Blank s)     = s+unclassify _     (Ordinary s)  = s+unclassify _     (Line n file) = "# " ++ show n ++ " " ++ show file+unclassify _     (CPP s)       = '#':s+unclassify True  (Comment "")  = "  --"+unclassify True  (Comment s)   = "  -- " ++ s+unclassify False (Comment "")  = "--"+unclassify False (Comment s)   = "-- " ++ s+unclassify _     _             = internalError++-- | 'unlit' takes a filename (for error reports), and transforms the+--   given string, to eliminate the literate comments from the program text.+unlit :: FilePath -> String -> Either String String+unlit file input =+  let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks+                                   . inlines+                                   $ input+   in either (Left . unlines . map (unclassify usesBirdTracks))+              Right+    . checkErrors+    . reclassify+    $ classified++  where+    -- So haddock requires comments and code to align, since it treats comments+    -- as following the layout rule. This is a pain for us since bird track+    -- style literate code typically gets indented by two since ">" is replaced+    -- by " " and people usually use one additional space of indent ie+    -- "> then the code". On the other hand we cannot just go and indent all+    -- the comments by two since that does not work for latex style literate+    -- code. So the hacky solution we use here is that if we see any bird track+    -- style code then we'll indent all comments by two, otherwise by none.+    -- Of course this will not work for mixed latex/bird track .lhs files but+    -- nobody does that, it's silly and specifically recommended against in the+    -- H98 unlit spec.+    --+    classifyAndCheckForBirdTracks =+      flip mapAccumL False $ \seenBirdTrack line ->+        let classification = classify line+         in (seenBirdTrack || isBirdTrack classification, classification)++    isBirdTrack (BirdTrack _) = True+    isBirdTrack _             = False++    checkErrors ls = case [ e | Error e <- ls ] of+      []          -> Left  ls+      (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message)+        where (f, n) = errorPos file 1 ls+    errorPos f n []              = (f, n)+    errorPos f n (Error _:_)     = (f, n)+    errorPos _ _ (Line n' f':ls) = errorPos f' n' ls+    errorPos f n (_         :ls) = errorPos f  (n+1) ls++-- Here we model a state machine, with each state represented by+-- a local function. We only have four states (well, five,+-- if you count the error state), but the rules+-- to transition between then are not so simple.+-- Would it be simpler to have more states?+--+-- Each state represents the type of line that was last read+-- i.e. are we in a comment section, or a latex-code section,+-- or a bird-code section, etc?+reclassify :: [Classified] -> [Classified]+reclassify = blank -- begin in blank state+  where+    latex []               = []+    latex (EndCode    :ls) = Blank "" : comment ls+    latex (BeginCode  :_ ) = [Error "\\begin{code} in code section"]+    latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls+    latex (          l:ls) = l : latex ls++    blank []               = []+    blank (EndCode    :_ ) = [Error "\\end{code} without \\begin{code}"]+    blank (BeginCode  :ls) = Blank ""    : latex ls+    blank (BirdTrack l:ls) = BirdTrack l : bird ls+    blank (Ordinary  l:ls) = Comment   l : comment ls+    blank (          l:ls) =           l : blank ls++    bird []              = []+    bird (EndCode   :_ ) = [Error "\\end{code} without \\begin{code}"]+    bird (BeginCode :ls) = Blank "" : latex ls+    bird (Blank l   :ls) = Blank l  : blank ls+    bird (Ordinary _:_ ) = [Error "program line before comment line"]+    bird (         l:ls) = l : bird ls++    comment []               = []+    comment (EndCode    :_ ) = [Error "\\end{code} without \\begin{code}"]+    comment (BeginCode  :ls) = Blank "" : latex ls+    comment (CPP l      :ls) = CPP l : comment ls+    comment (BirdTrack _:_ ) = [Error "comment line before program line"]+    -- a blank line and another ordinary line following a comment+    -- will be treated as continuing the comment. Otherwise it's+    -- then end of the comment, with a blank line.+    comment (Blank     l:ls@(Ordinary  _:_)) = Comment l : comment ls+    comment (Blank     l:ls) = Blank l   : blank ls+    comment (Line n f   :ls) = Line n f  : comment ls+    comment (Ordinary  l:ls) = Comment l : comment ls+    comment (Comment   _: _) = internalError+    comment (Error     _: _) = internalError++-- Re-implementation of 'lines', for better efficiency (but decreased laziness).+-- Also, importantly, accepts non-standard DOS and Mac line ending characters.+inlines :: String -> [String]+inlines xs = lines' xs id+  where+  lines' []             acc = [acc []]+  lines' ('\^M':'\n':s) acc = acc [] : lines' s id    -- DOS+  lines' ('\^M':s)      acc = acc [] : lines' s id    -- MacOS+  lines' ('\n':s)       acc = acc [] : lines' s id    -- Unix+  lines' (c:s)          acc = lines' s (acc . (c:))++internalError :: a+internalError = error "unlit: internal error"
+ Distribution/Simple/Program.hs view
@@ -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
+ Distribution/Simple/Program/Ar.hs view
@@ -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 = "!<arch>\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
+ Distribution/Simple/Program/Builtin.hs view
@@ -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+  }
+ Distribution/Simple/Program/Db.hs view
@@ -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
+ Distribution/Simple/Program/Find.hs view
@@ -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))
+ Distribution/Simple/Program/GHC.hs view
@@ -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
+ Distribution/Simple/Program/HcPkg.hs view
@@ -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      = []+
+ Distribution/Simple/Program/Hpc.hs view
@@ -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 ]+        ]
+ Distribution/Simple/Program/Ld.hs view
@@ -0,0 +1,62 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Program.Ld+-- Copyright   :  Duncan Coutts 2009+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module provides an library interface to the @ld@ linker program.++module Distribution.Simple.Program.Ld (+    combineObjectFiles,+  ) where++import Distribution.Simple.Program.Types+         ( ConfiguredProgram(..) )+import Distribution.Simple.Program.Run+         ( programInvocation, multiStageProgramInvocation+         , runProgramInvocation )+import Distribution.Verbosity+         ( Verbosity )++import System.Directory+         ( renameFile )+import System.FilePath+         ( (<.>) )++-- | Call @ld -r@ to link a bunch of object files together.+--+combineObjectFiles :: Verbosity -> ConfiguredProgram+                   -> FilePath -> [FilePath] -> IO ()+combineObjectFiles verbosity ld target files =++  -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is,+  -- if we have more object files than fit on a single command line then we+  -- have a slight problem. What we have to do is link files in batches into+  -- a temp object file and then include that one in the next batch.++  let simpleArgs  = ["-r", "-o", target]++      initialArgs = ["-r", "-o", target]+      middleArgs  = ["-r", "-o", target, tmpfile]+      finalArgs   = middleArgs++      simple      = programInvocation ld simpleArgs+      initial     = programInvocation ld initialArgs+      middle      = programInvocation ld middleArgs+      final       = programInvocation ld finalArgs++      invocations = multiStageProgramInvocation+                      simple (initial, middle, final) files++   in run invocations++  where+    tmpfile        = target <.> "tmp" -- perhaps should use a proper temp file++    run []         = return ()+    run [inv]      = runProgramInvocation verbosity inv+    run (inv:invs) = do runProgramInvocation verbosity inv+                        renameFile target tmpfile+                        run invs
+ Distribution/Simple/Program/Run.hs view
@@ -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
+ Distribution/Simple/Program/Script.hs view
@@ -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
+ Distribution/Simple/Program/Strip.hs view
@@ -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"]
+ Distribution/Simple/Program/Types.hs view
@@ -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+  }
+ Distribution/Simple/Register.hs view
@@ -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"
+ Distribution/Simple/Setup.hs view
@@ -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+-- <http://www.haskell.org/pipermail/cabal-devel/2007-December/001509.html>+-- for an explanation.+--+-- The types defined here get used in the front end and especially in+-- @cabal-install@ which has to do quite a bit of manipulating sets of command+-- line flags.+--+-- This is actually relatively nice, it works quite well. The main change it+-- needs is to unify it with the code for managing sets of fields that can be+-- read and written from files. This would allow us to save configure flags in+-- config files.++{-# 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?+-}
+ Distribution/Simple/SrcDist.hs view
@@ -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) }
+ Distribution/Simple/Test.hs view
@@ -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)
+ Distribution/Simple/Test/ExeV10.hs view
@@ -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)]
+ Distribution/Simple/Test/LibV09.hs view
@@ -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
+ Distribution/Simple/Test/Log.hs view
@@ -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"
+ Distribution/Simple/UHC.hs view
@@ -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)
+ Distribution/Simple/UserHooks.hs view
@@ -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 ()
+ Distribution/Simple/Utils.hs view
@@ -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) -- ^<pkgname>.cabal+findPackageDesc dir+ = do files <- getDirectoryContents dir+      -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal+      -- file we filter to exclude dirs and null base file names:+      cabalFiles <- filterM doesFileExist+                       [ dir </> file+                       | file <- files+                       , let (name, ext) = splitExtension file+                       , not (null name) && ext == ".cabal" ]+      case cabalFiles of+        []          -> 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 <pkgname>.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+-- <http://github.com/nh2/haskell-ordnub ordnub> 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
+ Distribution/System.hs view
@@ -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
+ Distribution/TestSuite.hs view
@@ -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 }
+ Distribution/Text.hs view
@@ -0,0 +1,68 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Text+-- Copyright   :  Duncan Coutts 2007+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This defines a 'Text' class which is a bit like the 'Read' and 'Show'+-- classes. The difference is that is uses a modern pretty printer and parser+-- system and the format is not expected to be Haskell concrete syntax but+-- rather the external human readable representation used by Cabal.+--+module Distribution.Text (+  Text(..),+  display,+  simpleParse,+  ) where++import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint          as Disp++import Data.Version (Version(Version))+import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace)++class Text a where+  disp  :: a -> Disp.Doc+  parse :: Parse.ReadP r a++display :: Text a => a -> String+display = Disp.renderStyle style . disp+  where style = Disp.Style {+          Disp.mode            = Disp.PageMode,+          Disp.lineLength      = 79,+          Disp.ribbonsPerLine  = 1.0+        }++simpleParse :: Text a => String -> Maybe a+simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str+                       , all Char.isSpace s ] of+  []    -> Nothing+  (p:_) -> Just p++-- -----------------------------------------------------------------------------+-- Instances for types from the base package++instance Text Bool where+  disp  = Disp.text . show+  parse = Parse.choice [ (Parse.string "True" Parse.++++                          Parse.string "true") >> return True+                       , (Parse.string "False" Parse.++++                          Parse.string "false") >> return False ]++instance Text Version where+  disp (Version branch _tags)     -- Death to version tags!!+    = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch))++  parse = do+      branch <- Parse.sepBy1 digits (Parse.char '.')+      tags   <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum)+      return (Version branch tags)  --TODO: should we ignore the tags?+    where+      digits = do+        first <- Parse.satisfy Char.isDigit+        if first == '0'+          then return 0+          else do rest <- Parse.munch Char.isDigit+                  return (read (first : rest))
+ Distribution/Utils/NubList.hs view
@@ -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
+ Distribution/Verbosity.hs view
@@ -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
+ Distribution/Version.hs view
@@ -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) ]
+ LICENSE view
@@ -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.
+ Language/Haskell/Extension.hs view
@@ -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.+  -- <http://haskell.org/onlinereport/>+     Haskell98++  -- | The Haskell 2010 language as defined by the Haskell 2010 report.+  -- <http://www.haskell.org/onlinereport/haskell2010>+  | Haskell2010++  -- | An unknown language, identified by its name.+  | UnknownLanguage String+  deriving (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.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-overlap>+    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.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#undecidable-instances>+  | 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.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-overlap>+  | 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.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#recursive-do-notation>+  | RecursiveDo++  -- | Provide syntax for writing list comprehensions which iterate+  -- over several lists together, like the 'zipWith' family of+  -- functions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#parallel-list-comprehensions>+  | ParallelListComp++  -- | Allow multiple parameters in a type class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#multi-param-type-classes>+  | MultiParamTypeClasses++  -- | Enable the dreaded monomorphism restriction.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/monomorphism.html>+  | 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.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#functional-dependencies>+  | FunctionalDependencies++  -- | Like 'RankNTypes' but does not allow a higher-rank type to+  -- itself appear on the left of a function arrow.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#universal-quantification>+  | Rank2Types++  -- | Allow a universally-quantified type to occur on the left of a+  -- function arrow.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#universal-quantification>+  | RankNTypes++  -- | Allow data constructors to have polymorphic arguments.  Unlike+  -- 'RankNTypes', does not allow this for ordinary functions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#universal-quantification>+  | PolymorphicComponents++  -- | Allow existentially-quantified data constructors.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#existential-quantification>+  | ExistentialQuantification++  -- | Cause a type variable in a signature, which has an explicit+  -- @forall@ quantifier, to scope over the definition of the+  -- accompanying value declaration.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#scoped-type-variables>+  | ScopedTypeVariables++  -- | Deprecated, use 'ScopedTypeVariables' instead.+  | PatternSignatures++  -- | Enable implicit function parameters with dynamic scope.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#implicit-parameters>+  | ImplicitParams++  -- | Relax some restrictions on the form of the context of a type+  -- signature.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#flexible-contexts>+  | FlexibleContexts++  -- | Relax some restrictions on the form of the context of an+  -- instance declaration.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-rules>+  | FlexibleInstances++  -- | Allow data type declarations with no constructors.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#nullary-types>+  | EmptyDataDecls++  -- | Run the C preprocessor on Haskell source code.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/options-phases.html#c-pre-processor>+  | CPP++  -- | Allow an explicit kind signature giving the kind of types over+  -- which a type variable ranges.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#kinding>+  | KindSignatures++  -- | Enable a form of pattern which forces evaluation before an+  -- attempted match, and a form of strict @let@/@where@ binding.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/bang-patterns.html>+  | BangPatterns++  -- | Allow type synonyms in instance heads.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#flexible-instance-head>+  | TypeSynonymInstances++  -- | Enable Template Haskell, a system for compile-time+  -- metaprogramming.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/template-haskell.html>+  | TemplateHaskell++  -- | Enable the Foreign Function Interface.  In GHC, implements the+  -- standard Haskell 98 Foreign Function Interface Addendum, plus+  -- some GHC-specific extensions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html>+  | ForeignFunctionInterface++  -- | Enable arrow notation.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/arrow-notation.html>+  | Arrows++  -- | /(deprecated)/ Enable generic type classes, with default instances defined in+  -- terms of the algebraic structure of a type.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/generic-classes.html>+  | Generics++  -- | Enable the implicit importing of the module "Prelude".  When+  -- disabled, when desugaring certain built-in syntax into ordinary+  -- identifiers, use whatever is in scope rather than the "Prelude"+  -- -- version.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#rebindable-syntax>+  | ImplicitPrelude++  -- | Enable syntax for implicitly binding local names corresponding+  -- to the field names of a record.  Puns bind specific names, unlike+  -- 'RecordWildCards'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#record-puns>+  | NamedFieldPuns++  -- | Enable a form of guard which matches a pattern and binds+  -- variables.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#pattern-guards>+  | PatternGuards++  -- | Allow a type declared with @newtype@ to use @deriving@ for any+  -- class with an instance for the underlying type.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#newtype-deriving>+  | GeneralizedNewtypeDeriving++  -- | Enable the \"Trex\" extensible records system.+  --+  -- * <http://cvs.haskell.org/Hugs/pages/users_guide/hugs-only.html#TREX>+  | ExtensibleRecords++  -- | Enable type synonyms which are transparent in some definitions+  -- and opaque elsewhere, as a way of implementing abstract+  -- datatypes.+  --+  -- * <http://cvs.haskell.org/Hugs/pages/users_guide/restricted-synonyms.html>+  | RestrictedTypeSynonyms++  -- | Enable an alternate syntax for string literals,+  -- with string templating.+  --+  -- * <http://cvs.haskell.org/Hugs/pages/users_guide/here-documents.html>+  | HereDocuments++  -- | Allow the character @#@ as a postfix modifier on identifiers.+  -- Also enables literal syntax for unboxed values.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#magic-hash>+  | MagicHash++  -- | Allow data types and type synonyms which are indexed by types,+  -- i.e. ad-hoc polymorphism for types.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-families.html>+  | TypeFamilies++  -- | Allow a standalone declaration which invokes the type class+  -- @deriving@ mechanism.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#stand-alone-deriving>+  | StandaloneDeriving++  -- | Allow certain Unicode characters to stand for certain ASCII+  -- character sequences, e.g. keywords and punctuation.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#unicode-syntax>+  | UnicodeSyntax++  -- | Allow the use of unboxed types as foreign types, e.g. in+  -- @foreign import@ and @foreign export@.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html#id681687>+  | UnliftedFFITypes++  -- | Enable interruptible FFI.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html#ffi-interruptible>+  | InterruptibleFFI++  -- | Allow use of CAPI FFI calling convention (@foreign import capi@).+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html#ffi-capi>+  | CApiFFI++  -- | Defer validity checking of types until after expanding type+  -- synonyms, relaxing the constraints on how synonyms may be used.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#type-synonyms>+  | LiberalTypeSynonyms++  -- | 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'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#record-wildcards>+  | RecordWildCards++  -- | Deprecated, use 'NamedFieldPuns' instead.+  | RecordPuns++  -- | Allow a record field name to be disambiguated by the type of+  -- the record it's in.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#disambiguate-fields>+  | DisambiguateRecordFields++  -- | Enable traditional record syntax (as supported by Haskell 98)+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#traditional-record-syntax>+  | TraditionalRecordSyntax++  -- | Enable overloading of string literals using a type class, much+  -- like integer literals.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#overloaded-strings>+  | OverloadedStrings++  -- | Enable generalized algebraic data types, in which type+  -- variables may be instantiated on a per-constructor basis. Implies+  -- 'GADTSyntax'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#gadt>+  | GADTs++  -- | Enable GADT syntax for declaring ordinary algebraic datatypes.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#gadt-style>+  | GADTSyntax++  -- | Make pattern bindings monomorphic.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/monomorphism.html#id630981>+  | MonoPatBinds++  -- | Relax the requirements on mutually-recursive polymorphic+  -- functions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#typing-binds>+  | RelaxedPolyRec++  -- | Allow default instantiation of polymorphic types in more+  -- situations.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/interactive-evaluation.html#extended-default-rules>+  | ExtendedDefaultRules++  -- | Enable unboxed tuples.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/primitives.html#unboxed-tuples>+  | UnboxedTuples++  -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and+  -- 'Data.Generics.Data'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>+  | DeriveDataTypeable++  -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>+  | DeriveGeneric++  -- | Enable support for default signatures.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#class-default-signatures>+  | DefaultSignatures++  -- | Allow type signatures to be specified in instance declarations.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-sigs>+  | InstanceSigs++  -- | Allow a class method's type to place additional constraints on+  -- a class type variable.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#class-method-types>+  | ConstrainedClassMethods++  -- | Allow imports to be qualified by the package name the module is+  -- intended to be imported from, e.g.+  --+  -- > import "network" Network.Socket+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#package-imports>+  | PackageImports++  -- | /(deprecated)/ Allow a type variable to be instantiated at a+  -- polymorphic type.+  --+  -- * <http://www.haskell.org/ghc/docs/6.12.3/html/users_guide/other-type-extensions.html#impredicative-polymorphism>+  | ImpredicativeTypes++  -- | /(deprecated)/ Change the syntax for qualified infix operators.+  --+  -- * <http://www.haskell.org/ghc/docs/6.12.3/html/users_guide/syntax-extns.html#new-qualified-operators>+  | NewQualifiedOperators++  -- | Relax the interpretation of left operator sections to allow+  -- unary postfix operators.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#postfix-operators>+  | PostfixOperators++  -- | Enable quasi-quotation, a mechanism for defining new concrete+  -- syntax for expressions and patterns.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/template-haskell.html#th-quasiquotation>+  | QuasiQuotes++  -- | Enable generalized list comprehensions, supporting operations+  -- such as sorting and grouping.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#generalised-list-comprehensions>+  | TransformListComp++  -- | Enable monad comprehensions, which generalise the list+  -- comprehension syntax to work for any monad.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#monad-comprehensions>+  | MonadComprehensions++  -- | Enable view patterns, which match a value by applying a+  -- function and matching on the result.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#view-patterns>+  | ViewPatterns++  -- | Allow concrete XML syntax to be used in expressions and patterns,+  -- as per the Haskell Server Pages extension language:+  -- <http://www.haskell.org/haskellwiki/HSP>. The ideas behind it are+  -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\"+  -- by Niklas Broberg, from Haskell Workshop '05.+  | XmlSyntax++  -- | Allow regular pattern matching over lists, as discussed in the+  -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre+  -- and Josef Svenningsson, from ICFP '04.+  | RegularPatterns++  -- | Enable the use of tuple sections, e.g. @(, True)@ desugars into+  -- @\x -> (x, True)@.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#tuple-sections>+  | TupleSections++  -- | 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.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#n-k-patterns>+  | NPlusKPatterns++  -- | Improve the layout rule when @if@ expressions are used in a @do@+  -- block.+  | DoAndIfThenElse++  -- | Enable support for multi-way @if@-expressions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#multi-way-if>+  | MultiWayIf++  -- | Enable support lambda-@case@ expressions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#lambda-case>+  | LambdaCase++  -- | Makes much of the Haskell sugar be desugared into calls to the+  -- function with a particular name that is in scope.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#rebindable-syntax>+  | RebindableSyntax++  -- | Make @forall@ a keyword in types, which can be used to give the+  -- generalisation explicitly.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#explicit-foralls>+  | ExplicitForAll++  -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in+  -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#datatype-contexts>+  | DatatypeContexts++  -- | Local (@let@ and @where@) bindings are monomorphic.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#mono-local-binds>+  | MonoLocalBinds++  -- | Enable @deriving@ for the 'Data.Functor.Functor' class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>+  | DeriveFunctor++  -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>+  | DeriveTraversable++  -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>+  | DeriveFoldable++  -- | Enable non-decreasing indentation for @do@ blocks.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/bugs-and-infelicities.html#infelicities-syntax>+  | 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+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-imports>+  | SafeImports++  -- | Compile a module in the Safe, Safe Haskell mode -- a restricted+  -- form of the Haskell language to ensure type safety.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-trust>+  | Safe++  -- | Compile a module in the Trustworthy, Safe Haskell mode -- no+  -- restrictions apply but the module is marked as trusted as long as+  -- the package the module resides in is trusted.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-trust>+  | Trustworthy++  -- | Compile a module in the Unsafe, Safe Haskell mode so that+  -- modules compiled using Safe, Safe Haskell mode can't import it.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-trust>+  | Unsafe++  -- | Allow type class/implicit parameter/equality constraints to be+  -- used as types with the special kind constraint.  Also generalise+  -- the @(ctxt => ty)@ syntax so that any type of kind constraint can+  -- occur before the arrow.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/constraint-kind.html>+  | ConstraintKinds++  -- | Enable kind polymorphism.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/kind-polymorphism.html>+  | PolyKinds++  -- | Enable datatype promotion.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/promotion.html>+  | DataKinds++  -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/.+  --+  -- * <http://www.haskell.org/haskellwiki/GHC/Data_Parallel_Haskell>+  | ParallelArrays++  -- | Enable explicit role annotations, like in (@type role Foo representational representational@).+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/roles.html>+  | RoleAnnotations++  -- | Enable overloading of list literals, arithmetic sequences and+  -- list patterns using the 'IsList' type class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#overloaded-lists>+  | OverloadedLists++  -- | Enable case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#empty-case>+  | EmptyCase++  -- | Triggers the generation of derived 'Typeable' instances for every+  -- datatype and type class declaration.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#auto-derive-typeable>+  | AutoDeriveTypeable++  -- | Desugars negative literals directly (without using negate).+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#negative-literals>+  | NegativeLiterals++  -- | Allow the use of binary integer literal syntax (e.g. @0b11001001@ to denote @201@).+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#binary-literals>+  | BinaryLiterals++  -- | Allow the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#num-decimals>+  | NumDecimals++  -- | Enable support for type classes with no type parameter.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#nullary-type-classes>+  | NullaryTypeClasses++  -- | Enable explicit namespaces in module import/export lists.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#explicit-namespaces>+  | ExplicitNamespaces++  -- | Allow the user to write ambiguous types, and the type inference engine to infer them.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#ambiguity>+  | AllowAmbiguousTypes++  -- | Enable @foreign import javascript@.+  | JavaScriptFFI++  -- | Allow giving names to and abstracting over patterns.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#pattern-synonyms>+  | 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.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#partial-type-signatures>+  | PartialTypeSignatures++  -- | Allow named placeholders written with a leading underscore inside type+  -- signatures.  Wildcards with the same name unify to the same type.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#named-wildcards>+  | NamedWildCards++  -- | Enable @deriving@ for any class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#derive-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 ]
+ README.md view
@@ -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/
+ Setup.hs view
@@ -0,0 +1,10 @@+import Distribution.Simple+main :: IO ()+main = defaultMain++-- Although this looks like the Simple build type, it is in fact vital that+-- we use this Setup.hs because it'll get compiled against the local copy+-- of the Cabal lib, thus enabling Cabal to bootstrap itself without relying+-- on any previous installation. This also means we can use any new features+-- immediately because we never have to worry about building Cabal with an+-- older version of itself.
+ changelog view
@@ -0,0 +1,443 @@+-*-change-log-*-++1.22.0.0 Johan Tibell <johan.tibell@gmail.com> 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 <johan.tibell@gmail.com> May 2014+	* Fix streaming test output.++1.20.0.0 Johan Tibell <johan.tibell@gmail.com> 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 <duncan@community.haskell.org> June 2011+	* Include test suites in cabal sdist+	* Fix for conditionals in test suite stanzas in .cabal files+	* Fix permissions of directories created during install+	* Fix for global builds when $HOME env var is not set++1.10.1.0 Duncan Coutts <duncan@community.haskell.org> February 2011+	* Improved error messages when test suites are not enabled+	* Template parameters allowed in test --test-option(s) flag+	* Improved documentation of the test feature+	* Relaxed QA check on cabal-version when using test-suite sections+	* haddock command now allows both --hoogle and --html at the same time+	* Find ghc-version-specific instances of the hsc2hs program+	* Preserve file executable permissions in sdist tarballs+	* Pass gcc location and flags to ./configure scripts+	* Get default gcc flags from ghc++1.10.0.0 Duncan Coutts <duncan@haskell.org> November 2010+	* New cabal test feature+	* Initial support for UHC+	* New default-language and other-languages fields (e.g. Haskell98/2010)+	* New default-extensions and other-extensions fields+	* Deprecated extensions field (for packages using cabal-version >=1.10)+	* Cabal-version field must now only be of the form ">= x.y"+	* Removed deprecated --copy-prefix= feature+	* Auto-reconfigure when .cabal file changes+	* Workaround for haddock overwriting .hi and .o files when using TH+	* Extra cpp flags used with hsc2hs and c2hs (-D${os}_BUILD_OS etc)+	* New cpp define VERSION_<package> gives string version of dependencies+	* User guide source now in markdown format for easier editing+	* Improved checks and error messages for C libraries and headers+	* Removed BSD4 from the list of suggested licenses+	* Updated list of known language extensions+	* Fix for include paths to allow C code to import FFI stub.h files+	* Fix for intra-package dependencies on OSX+	* Stricter checks on various bits of .cabal file syntax+	* Minor fixes for c2hs++1.8.0.6 Duncan Coutts <duncan@haskell.org> June 2010+	* Fix 'register --global/--user'++1.8.0.4 Duncan Coutts <duncan@haskell.org> March 2010+	* Set dylib-install-name for dynalic libs on OSX+	* Stricter configure check that compiler supports a package's extensions+	* More configure-time warnings+	* Hugs can compile Cabal lib again+	* Default datadir now follows prefix on Windows+	* Support for finding installed packages for hugs+	* Cabal version macros now have proper parenthesis+	* Reverted change to filter out deps of non-buildable components+	* Fix for registering implace when using a specific package db+	* Fix mismatch between $os and $arch path template variables+	* Fix for finding ar.exe on Windows, always pick ghc's version+	* Fix for intra-package dependencies with ghc-6.12++1.8.0.2 Duncan Coutts <duncan@haskell.org> December 2009+	* Support for GHC-6.12+	* New unique installed package IDs which use a package hash+	* Allow executables to depend on the lib within the same package+	* Dependencies for each component apply only to that component+	  (previously applied to all the other components too)+	* Added new known license MIT and versioned GPL and LGPL+	* More liberal package version range syntax+	* Package registration files are now UTF8+	* Support for LHC and JHC-0.7.2+	* Deprecated RecordPuns extension in favour of NamedFieldPuns+	* Deprecated PatternSignatures extension in favor of ScopedTypeVariables+	* New VersionRange semantic view as a sequence of intervals+	* Improved package quality checks+	* Minor simplification in a couple Setup.hs hooks+	* Beginnings of a unit level testsuite using QuickCheck+	* Various bug fixes+	* Various internal cleanups++1.6.0.2 Duncan Coutts <duncan@haskell.org> February 2009+	* New configure-time check for C headers and libraries+	* Added language extensions present in ghc-6.10+	* Added support for NamedFieldPuns extension in ghc-6.8+	* Fix in configure step for ghc-6.6 on Windows+	* Fix warnings in Path_pkgname.hs module on Windows+	* Fix for exotic flags in ld-options field+	* Fix for using pkg-config in a package with a lib and an executable+	* Fix for building haddock docs for exes that use the Paths module+	* Fix for installing header files in subdirectories+	* Fix for the case of building profiling libs but not ordinary libs+	* Fix read-only attribute of installed files on Windows+	* Ignore ghc -threaded flag when profiling in ghc-6.8 and older++1.6.0.1 Duncan Coutts <duncan@haskell.org> October 2008+	* Export a compat function to help alex and happy++1.6.0.0 Duncan Coutts <duncan@haskell.org> October 2008+	* Support for ghc-6.10+	* Source control repositories can now be specified in .cabal files+	* Bug report URLs can be now specified in .cabal files+	* Wildcards now allowed in data-files and extra-source-files fields+	* New syntactic sugar for dependencies "build-depends: foo ==1.2.*"+	* New cabal_macros.h provides macros to test versions of dependencies+	* Relocatable bindists now possible on unix via env vars+	* New 'exposed' field allows packages to be not exposed by default+	* Install dir flags can now use $os and $arch variables+	* New --builddir flag allows multiple builds from a single sources dir+	* cc-options now only apply to .c files, not for -fvia-C+	* cc-options are not longer propagated to dependent packages+	* The cpp/cc/ld-options fields no longer use ',' as a separator+	* hsc2hs is now called using gcc instead of using ghc as gcc+	* New api for manipulating sets and graphs of packages+	* Internal api improvements and code cleanups+	* Minor improvements to the user guide+	* Miscellaneous minor bug fixes++1.4.0.2 Duncan Coutts <duncan@haskell.org> August 2008+	* Fix executable stripping default+	* Fix striping exes on OSX that export dynamic symbols (like ghc)+	* Correct the order of arguments given by --prog-options=+	* Fix corner case with overlapping user and global packages+	* Fix for modules that use pre-processing and .hs-boot files+	* Clarify some points in the user guide and readme text+	* Fix verbosity flags passed to sub-command like haddock+	* Fix sdist --snapshot+	* Allow meta-packages that contain no modules or C code+	* Make the generated Paths module -Wall clean on Windows++1.4.0.1 Duncan Coutts <duncan@haskell.org> June 2008+	* Fix a bug which caused '.' to always be in the sources search path+	* Haddock-2.2 and later do now support the --hoogle flag++1.4.0.0 Duncan Coutts <duncan@haskell.org> June 2008+	* Rewritten command line handling support+	* Command line completion with bash+	* Better support for Haddock 2+	* Improved support for nhc98+	* Removed support for ghc-6.2+	* Haddock markup in .lhs files now supported+	* Default colour scheme for highlighted source code+	* Default prefix for --user installs is now $HOME/.cabal+	* All .cabal files are treaded as UTF-8 and must be valid+	* Many checks added for common mistakes+	* New --package-db= option for specific package databases+	* Many internal changes to support cabal-install+	* Stricter parsing for version strings, eg dissalows "1.05"+	* Improved user guide introduction+	* Programatica support removed+	* New options --program-prefix/suffix allows eg versioned programs+	* Support packages that use .hs-boot files+	* Fix sdist for Main modules that require preprocessing+	* New configure -O flag with optimisation level 0--2+	* Provide access to "x-" extension fields through the Cabal api+	* Added check for broken installed packages+	* Added warning about using inconsistent versions of dependencies+	* Strip binary executable files by default with an option to disable+	* New options to add site-specific include and library search paths+	* Lift the restriction that libraries must have exposed-modules+	* Many bugs fixed.+	* Many internal structural improvements and code cleanups++1.2.4.0 Duncan Coutts <duncan@haskell.org> June 2008+	* Released with GHC 6.8.3+	* Backported several fixes and minor improvements from Cabal-1.4+	* Use a default colour scheme for sources with hscolour >=1.9+	* Support --hyperlink-source for Haddock >= 2.0+	* Fix for running in a non-writable directory+	* Add OSX -framework arguments when linking executables+	* Updates to the user guide+	* Allow build-tools names to include + and _+	* Export autoconfUserHooks and simpleUserHooks+	* Export ccLdOptionsBuildInfo for Setup.hs scripts+	* Export unionBuildInfo and make BuildInfo an instance of Monoid+	* Fix to allow the 'main-is' module to use a pre-processor++1.2.3.0 Duncan Coutts <duncan@haskell.org> Nov 2007+	* Released with GHC 6.8.2+	* Includes full list of GHC language extensions+	* Fix infamous "dist/conftest.c" bug+	* Fix configure --interfacedir=+	* Find ld.exe on Windows correctly+	* Export PreProcessor constructor and mkSimplePreProcessor+	* Fix minor bug in unlit code+	* Fix some markup in the haddock docs++1.2.2.0 Duncan Coutts <duncan@haskell.org> Nov 2007+	* Released with GHC 6.8.1+	* Support haddock-2.0+	* Support building DSOs with GHC+	* Require reconfiguring if the .cabal file has changed+	* Fix os(windows) configuration test+	* Fix building documentation+	* Fix building packages on Solaris+	* Other minor bug fixes++1.2.1 Duncan Coutts <duncan@haskell.org> Oct 2007+	* To be included in GHC 6.8.1+	* New field "cpp-options" used when preprocessing Haskell modules+	* Fixes for hsc2hs when using ghc+	* C source code gets compiled with -O2 by default+	* OS aliases, to allow os(windows) rather than requiring os(mingw32)+	* Fix cleaning of 'stub' files+	* Fix cabal-setup, command line ui that replaces "runhaskell Setup.hs"+	* Build docs even when dependent packages docs are missing+	* Allow the --html-dir to be specified at configure time+	* Fix building with ghc-6.2+	* Other minor bug fixes and build fixes++1.2.0  Duncan Coutts <duncan.coutts@worc.ox.ac.uk> Sept 2007+	* To be included in GHC 6.8.x+	* New configurations feature+	* Can make haddock docs link to hilighted sources (with hscolour)+	* New flag to allow linking to haddock docs on the web+	* Supports pkg-config+	* New field "build-tools" for tool dependencies+	* Improved c2hs support+	* Preprocessor output no longer clutters source dirs+	* 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 <duncan.coutts@worc.ox.ac.uk> May 2007+	* Released with GHC 6.6.1+	* Handle windows text file encoding for .cabal files+	* Fix compiling a executable for profiling that uses Template Haskell+	* Other minor bug fixes and user guide clarifications++1.1.6.1 Duncan Coutts <duncan.coutts@worc.ox.ac.uk> Oct 2006+	* fix unlit code+	* fix escaping in register.sh++1.1.6  Duncan Coutts <duncan.coutts@worc.ox.ac.uk> Oct 2006+	* Released with GHC 6.6+	* Added support for hoogle+	* Allow profiling and normal builds of libs to be chosen indepentantly+	* Default installation directories on Win32 changed+	* Register haddock docs with ghc-pkg+	* Get haddock to make hyperlinks to dependent package docs+	* Added BangPatterns language extension+	* Various bug fixes++1.1.4  Duncan Coutts <duncan.coutts@worc.ox.ac.uk> May 2006+	* Released with GHC 6.4.2+	* Better support for packages that need to install header files+	* cabal-setup added, but not installed by default yet+	* Implemented "setup register --inplace"+	* Have packages exposed by default with ghc-6.2+	* It is no longer necessary to run 'configure' before 'clean' or 'sdist'+	* Added support for ghc's -split-objs+	* Initial support for JHC+	* Ignore extension fields in .cabal files (fields begining with "x-")+	* Some changes to command hooks API to improve consistency+	* Hugs support improvements+	* Added GeneralisedNewtypeDeriving language extension+	* Added cabal-version field+	* Support hidden modules with haddock+	* Internal code refactoring+	* More bug fixes++1.1.3  Isaac Jones  <ijones@syntaxpolice.org> Sept 2005+	* WARNING: Interfaces not documented in the user's guide may+	  change in future releases.+	* Move building of GHCi .o libs to the build phase rather than+	register phase. (from Duncan Coutts)+	* Use .tar.gz for source package extension+	* Uses GHC instead of cpphs if the latter is not available+	* Added experimental "command hooks" which completely override the+	default behavior of a command.+	* Some bugfixes++1.1.1  Isaac Jones  <ijones@syntaxpolice.org> July 2005+	* WARNING: Interfaces not documented in the user's guide may+	  change in future releases.+ 	* Handles recursive modules for GHC 6.2 and GHC 6.4.+	* Added "setup test" command (Used with UserHook)+	* implemented handling of _stub.{c,h,o} files+	* Added support for profiling+	* Changed install prefix of libraries (pref/pkgname-version+	  to prefix/pkgname-version/compname-version)+	* Added pattern guards as a language extension+	* Moved some functionality to Language.Haskell.Extension+	* Register / unregister .bat files for windows+	* Exposed more of the API+	* Added support for the hide-all-packages flag in GHC > 6.4+	* Several bug fixes++1.0  Isaac Jones  <ijones@syntaxpolice.org> March 11 2005+	* Released with GHC 6.4, Hugs March 2005, and nhc98 1.18+	* Some sanity checking++0.5  Isaac Jones  <ijones@syntaxpolice.org> Wed Feb 19 2005+	* WARNING: this is a pre-release and the interfaces are still+	likely to change until we reach a 1.0 release.+	* Hooks interfaces changed+	* Added preprocessors to user hooks+	* No more executable-modules or hidden-modules.  Use+	"other-modules" instead.+	* Certain fields moved into BuildInfo, much refactoring+	* extra-libs -> extra-libraries+	* Added --gen-script to configure and unconfigure.+	* modules-ghc (etc) now ghc-modules (etc)+	* added new fields including "synopsis"+	* Lots of bug fixes+	* spaces can sometimes be used instead of commas+	* A user manual has appeared (Thanks, ross!)+	* for ghc 6.4, configures versionsed depends properly+	* more features to ./setup haddock++0.4  Isaac Jones  <ijones@syntaxpolice.org> Sun Jan 16 2005++	* Much thanks to all the awesome fptools hackers who have been+	working hard to build the Haskell Cabal!++	* Interface Changes:++	** WARNING: this is a pre-release and the interfaces are still+	likely to change until we reach a 1.0 release.++	** Instead of Package.description, you should name your+	description files <something>.cabal.  In particular, we suggest+	that you name it <packagename>.cabal, but this is not enforced+	(yet).  Multiple .cabal files in the same directory is an error,+	at least for now.++	** ./setup install --install-prefix is gone.  Use ./setup copy+	--copy-prefix instead.++	** The "Modules" field is gone.  Use "hidden-modules",+	"exposed-modules", and "executable-modules".++	** Build-depends is now a package-only field, and can't go into+	executable stanzas.  Build-depends is a package-to-package+	relationship.++	** Some new fields.  Use the Source.++	* New Features++	** Cabal is now included as a package in the CVS version of+	fptools.  That means it'll be released as "-package Cabal" in+	future versions of the compilers, and if you are a bleeding-edge+	user, you can grab it from the CVS repository with the compilers.++	** Hugs compatibility and NHC98 compatibility should both be+	improved.++	** Hooks Interface / Autoconf compatibility: Most of the hooks+	interface is hidden for now, because it's not finalized.  I have+	exposed only "defaultMainWithHooks" and "defaultUserHooks".  This+	allows you to use a ./configure script to preprocess+	"foo.buildinfo", which gets merged with "foo.cabal".  In future+	releases, we'll expose UserHooks, but we're definitely going to+	change the interface to those.  The interface to the two functions+	I've exposed should stay the same, though.++	** ./setup haddock is a baby feature which pre-processes the+	source code with hscpp and runs haddock on it.  This is brand new+	and hardly tested, so you get to knock it around and see what you+	think.++	** Some commands now actually implement verbosity.++	** The preprocessors have been tested a bit more, and seem to work+	OK.  Please give feedback if you use these.++0.3  Isaac Jones  <ijones@syntaxpolice.org> Sun Jan 16 2005+	* Unstable snapshot release+	* From now on, stable releases are even.++0.2  Isaac Jones  <ijones@syntaxpolice.org>++	* Adds more HUGS support and preprocessor support.
+ doc/developing-packages.markdown view
@@ -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 <X11/Xlib.h>],,[no_x=yes])++# Build the package if we found X11 stuff+if test "$no_x" = yes+then BUILD_PACKAGE_BOOL=False+else BUILD_PACKAGE_BOOL=True+fi+AC_SUBST([BUILD_PACKAGE_BOOL])++AC_CONFIG_FILES([X11.buildinfo])+AC_OUTPUT+~~~~~~~~~~~~~~~~++Then the setup script will run the `configure` script, which checks for+the presence of the X11 libraries and substitutes for variables in the+file `X11.buildinfo.in`:++~~~~~~~~~~~~~~~~+buildable: @BUILD_PACKAGE_BOOL@+cc-options: @X_CFLAGS@+ld-options: @X_LIBS@+~~~~~~~~~~~~~~~~++This generates a file `X11.buildinfo` supplying the parameters needed by+later stages:++~~~~~~~~~~~~~~~~+buildable: True+cc-options:  -I/usr/X11R6/include+ld-options:  -L/usr/X11R6/lib+~~~~~~~~~~~~~~~~++The `configure` script also generates a header file `include/HsX11Config.h`+containing C preprocessor defines recording the results of various tests.  This+file may be included by C source files and preprocessed Haskell source files in+the package.++Note: Packages using these features will also need to list additional files such+as `configure`, templates for `.buildinfo` files, files named only in+`.buildinfo` files, header files and so on in the `extra-source-files` field to+ensure that they are included in source distributions.  They should also list+files and directories generated by `configure` in the `extra-tmp-files` field to+ensure that they are removed by `setup clean`.++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
+ doc/index.markdown view
@@ -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/
+ doc/installing-packages.markdown view
@@ -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/
+ doc/misc.markdown view
@@ -0,0 +1,109 @@+% Cabal User Guide++# Reporting bugs and deficiencies #++Please report any flaws or feature requests in the [bug tracker][].++For general discussion or queries email the libraries mailing list+<libraries@haskell.org>. There is also a development mailing list+<cabal-devel@haskell.org>.++[bug tracker]: 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/
+ tests/PackageTests.hs view
@@ -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
+ tests/PackageTests/BenchmarkExeV10/Check.hs view
@@ -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
+ tests/PackageTests/BenchmarkExeV10/Foo.hs view
@@ -0,0 +1,4 @@+module Foo where++fooTest :: [String] -> Bool+fooTest _ = True
+ tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs view
@@ -0,0 +1,8 @@+module Main where++import Foo+import System.Exit++main :: IO ()+main | fooTest [] = exitSuccess+     | otherwise = exitFailure
+ tests/PackageTests/BenchmarkExeV10/my.cabal view
@@ -0,0 +1,15 @@+name:           my+version:        0.1+license:        BSD3+cabal-version:  >= 1.9.2+build-type:     Simple++library+    exposed-modules:    Foo+    build-depends:      base++benchmark bench-Foo+    type:   exitcode-stdio-1.0+    hs-source-dirs: benchmarks+    main-is:    bench-Foo.hs+    build-depends: base, my
+ tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal view
@@ -0,0 +1,20 @@+name: BenchmarkOptions+version: 0.1+license: BSD3+author: Johan Tibell+stability: stable+category: PackageTests+build-type: Simple+cabal-version: >= 1.9.2++description:+    Check that Cabal passes the correct test options to test suites.++executable dummy+    main-is: test-BenchmarkOptions.hs+    build-depends: base++benchmark test-BenchmarkOptions+    main-is: test-BenchmarkOptions.hs+    type: exitcode-stdio-1.0+    build-depends: base
+ tests/PackageTests/BenchmarkOptions/Check.hs view
@@ -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'
+ tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs view
@@ -0,0 +1,11 @@+module Main where++import System.Environment ( getArgs )+import System.Exit ( exitFailure, exitSuccess )++main :: IO ()+main = do+    args <- getArgs+    if args == ["1", "2", "3"]+        then exitSuccess+        else putStrLn ("Got: " ++ show args) >> exitFailure
+ tests/PackageTests/BenchmarkStanza/Check.hs view
@@ -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
+ tests/PackageTests/BenchmarkStanza/my.cabal view
@@ -0,0 +1,19 @@+name: BenchmarkStanza+version: 0.1+license: BSD3+author: Johan Tibell+stability: stable+category: PackageTests+build-type: Simple++description:+    Check that Cabal recognizes the benchmark stanza defined below.++Library+    exposed-modules: MyLibrary+    build-depends: base++benchmark dummy+    main-is: dummy.hs+    type: exitcode-stdio-1.0+    build-depends: base
+ tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs view
@@ -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)
+ tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal view
@@ -0,0 +1,20 @@+name: GlobalBuildDepsNotAdditive1+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    If you specify 'base' in the global build dependencies, then define+    a library without base, it fails to find 'base' for the library.++---------------------------------------++build-depends: base++Library+    exposed-modules: MyLibrary+    build-depends: bytestring, old-time
+ tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import System.Time++myLibFunc :: IO ()+myLibFunc = do+    getClockTime+    let text = "myLibFunc"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs view
@@ -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)
+ tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal view
@@ -0,0 +1,20 @@+name: GlobalBuildDepsNotAdditive1+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    If you specify 'base' in the global build dependencies, then define+    an executable without base, it fails to find 'base' for the executable++---------------------------------------++build-depends: base++Executable lemon+    main-is: lemon.hs+    build-depends: bytestring, old-time
+ tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs view
@@ -0,0 +1,7 @@+import qualified Data.ByteString.Char8 as C+import System.Time++main = do+    getClockTime+    let text = "lemon"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs view
@@ -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
+ tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import System.Time++myLibFunc :: IO ()+myLibFunc = do+    getClockTime+    let text = "myLibFunc"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal view
@@ -0,0 +1,24 @@+name: InternalLibrary0+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    Check that with 'cabal-version:' containing versions less than 1.7, we do *not*+    have the new behaviour to allow executables to refer to the library defined+    in the same module.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time++Executable lemon+    main-is: lemon.hs+    hs-source-dirs: programs+    build-depends: base, bytestring, old-time, InternalLibrary0
+ tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs view
@@ -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
+ tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import System.Time++myLibFunc :: IO ()+myLibFunc = do+    getClockTime+    let text = "myLibFunc"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal view
@@ -0,0 +1,23 @@+name: InternalLibrary1+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    Check for the new (in >= 1.7.1) ability to allow executables to refer to+    the library defined in the same module.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time++Executable lemon+    main-is: lemon.hs+    hs-source-dirs: programs+    build-depends: base, bytestring, old-time, InternalLibrary1
+ tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs view
@@ -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)+
+ tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import System.Time++myLibFunc :: IO ()+myLibFunc = do+    getClockTime+    let text = "myLibFunc internal"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal view
@@ -0,0 +1,23 @@+name: InternalLibrary2+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that the internal library is preferred by ghc to+    an installed one of the same name and version.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time++Executable lemon+    main-is: lemon.hs+    hs-source-dirs: programs+    build-depends: base, bytestring, old-time, InternalLibrary2
+ tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import System.Time++myLibFunc :: IO ()+myLibFunc = do+    getClockTime+    let text = "myLibFunc installed"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal view
@@ -0,0 +1,18 @@+name: InternalLibrary2+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that the internal library is preferred by ghc to+    an installed one of the same name and version.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time
+ tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs view
@@ -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)+
+ tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import System.Time++myLibFunc :: IO ()+myLibFunc = do+    getClockTime+    let text = "myLibFunc internal"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal view
@@ -0,0 +1,23 @@+name: InternalLibrary3+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that the internal library is preferred by ghc to+    an installed one of the same name, but a *newer* version.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time++Executable lemon+    main-is: lemon.hs+    hs-source-dirs: programs+    build-depends: base, bytestring, old-time, InternalLibrary3
+ tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import System.Time++myLibFunc :: IO ()+myLibFunc = do+    getClockTime+    let text = "myLibFunc installed"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal view
@@ -0,0 +1,18 @@+name: InternalLibrary3+version: 0.2+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that the internal library is preferred by ghc to+    an installed one of the same name but a *newer* version.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time
+ tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs view
@@ -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)+
+ tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import System.Time++myLibFunc :: IO ()+myLibFunc = do+    getClockTime+    let text = "myLibFunc internal"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal view
@@ -0,0 +1,23 @@+name: InternalLibrary4+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that we can explicitly say we want InternalLibrary4-0.2+    and it will give us the *installed* version 0.2 instead of the internal 0.1.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time++Executable lemon+    main-is: lemon.hs+    hs-source-dirs: programs+    build-depends: base, bytestring, old-time, InternalLibrary4 >= 0.2
+ tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import System.Time++myLibFunc :: IO ()+myLibFunc = do+    getClockTime+    let text = "myLibFunc installed"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal view
@@ -0,0 +1,18 @@+name: InternalLibrary4+version: 0.2+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    This test is to make sure that the internal library is preferred by ghc to+    an installed one of the same name but a *newer* version.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time
+ tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs view
@@ -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)
+ tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import System.Time++myLibFunc :: IO ()+myLibFunc = do+    getClockTime+    let text = "myLibFunc"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal view
@@ -0,0 +1,31 @@+name: SameDepsAllRound+version: 0.1+license: BSD3+cabal-version: >= 1.6+author: Stephen Blackheath+stability: stable+synopsis: Same dependencies all round+category: PackageTests+build-type: Simple++description:+    Check for the "old build-dep behaviour" namely that we get the same+    package dependencies on all build targets, even if different ones+    were specified for different targets+    .+    Here all .hs files use the three packages mentioned, so this shows+    that build-depends is not target-specific.  This is the behaviour+    we want when cabal-version contains versions less than 1.7.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring++Executable lemon+    main-is: lemon.hs+    build-depends: old-time++Executable pineapple+    main-is: pineapple.hs
+ tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs view
@@ -0,0 +1,7 @@+import qualified Data.ByteString.Char8 as C+import System.Time++main = do+    getClockTime+    let text = "lemon"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs view
@@ -0,0 +1,7 @@+import qualified Data.ByteString.Char8 as C+import System.Time++main = do+    getClockTime+    let text = "pineapple"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs view
@@ -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)
+ tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import System.Time++myLibFunc :: IO ()+myLibFunc = do+    getClockTime+    let text = "myLibFunc"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs view
@@ -0,0 +1,7 @@+import qualified Data.ByteString.Char8 as C+import System.Time++main = do+    getClockTime+    let text = "lemon"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal view
@@ -0,0 +1,22 @@+name: TargetSpecificDeps1+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    Check for the new build-dep behaviour, where build-depends are+    handled specifically for each target++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring++Executable lemon+    main-is: lemon.hs+    build-depends: base, bytestring, old-time
+ tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs view
@@ -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)
+ tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import System.Time++myLibFunc :: IO ()+myLibFunc = do+    getClockTime+    let text = "myLibFunc"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs view
@@ -0,0 +1,5 @@+import qualified Data.ByteString.Char8 as C++main = do+    let text = "lemon"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal view
@@ -0,0 +1,24 @@+name: TargetSpecificDeps1+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    Check for the new build-dep behaviour, where build-depends are+    handled specifically for each target+    This one is a control against TargetSpecificDeps1 - it is correct and should+    succeed.++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time++Executable lemon+    main-is: lemon.hs+    build-depends: base, bytestring
+ tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs view
@@ -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)
+ tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs view
@@ -0,0 +1,10 @@+module MyLibrary where++import qualified Data.ByteString.Char8 as C+import System.Time++myLibFunc :: IO ()+myLibFunc = do+    getClockTime+    let text = "myLibFunc"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs view
@@ -0,0 +1,7 @@+import qualified Data.ByteString.Char8 as C+import System.Time++main = do+    getClockTime+    let text = "lemon"+    C.putStrLn $ C.pack text
+ tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal view
@@ -0,0 +1,22 @@+name: test+version: 0.1+license: BSD3+cabal-version: >= 1.7.1+author: Stephen Blackheath+stability: stable+category: PackageTests+build-type: Simple++description:+    Check for the new build-dep behaviour, where build-depends are+    handled specifically for each target++---------------------------------------++Library+    exposed-modules: MyLibrary+    build-depends: base, bytestring, old-time++Executable lemon+    main-is: lemon.hs+    build-depends: base, bytestring
+ tests/PackageTests/BuildTestSuiteDetailedV09/Check.hs view
@@ -0,0 +1,18 @@+module PackageTests.BuildTestSuiteDetailedV09.Check where++import Test.HUnit+import System.FilePath ((</>))++import PackageTests.PackageTester++suite :: PackageSpec -> FilePath -> Test+suite inplaceSpec ghcPath = TestCase $ do+    let dir = "PackageTests" </> "BuildTestSuiteDetailedV09"+        spec = inplaceSpec+            { directory = dir+            , configOpts = "--enable-tests" : configOpts inplaceSpec+            }+    confResult <- cabal_configure spec ghcPath+    assertConfigureSucceeded confResult+    buildResult <- cabal_build spec ghcPath+    assertBuildSucceeded buildResult
+ tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs view
@@ -0,0 +1,6 @@+module Dummy where++import Distribution.TestSuite (Test)++tests :: IO [Test]+tests = return []
+ tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal view
@@ -0,0 +1,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
+ tests/PackageTests/CMain/Bar.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Bar where++bar :: IO ()+bar = return ()++foreign export ccall bar :: IO ()
+ tests/PackageTests/CMain/Check.hs view
@@ -0,0 +1,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
+ tests/PackageTests/CMain/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ tests/PackageTests/CMain/foo.c view
@@ -0,0 +1,13 @@+#include <stdio.h>+#include "HsFFI.h"++#ifdef __GLASGOW_HASKELL__+#include "Bar_stub.h"+#endif++int main(int argc, char **argv) {+    hs_init(&argc, &argv);+    bar();+    printf("Hello world!");+    return 0;+}
+ tests/PackageTests/CMain/my.cabal view
@@ -0,0 +1,10 @@+name:           my+version:        0.1+license:        BSD3+cabal-version:  >= 1.9.2+build-type:     Simple++executable foo+    main-is:    foo.c+    other-modules: Bar+    build-depends: base
+ tests/PackageTests/DeterministicAr/Check.hs view
@@ -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 = "!<arch>\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
+ tests/PackageTests/DeterministicAr/Lib.hs view
@@ -0,0 +1,5 @@+module Lib where++dummy :: IO ()+dummy = return ()+
+ tests/PackageTests/DeterministicAr/my.cabal view
@@ -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+
+ tests/PackageTests/EmptyLib/Check.hs view
@@ -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
+ tests/PackageTests/EmptyLib/empty/empty.cabal view
@@ -0,0 +1,6 @@+name: emptyLib+Cabal-version: >= 1.2+version: 1.0+build-type: Simple++Library
+ tests/PackageTests/Haddock/CPP.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE CPP #-}++module CPP where++#define HIDING  hiding+#define NEEDLES needles++-- | For HIDING NEEDLES.+data Haystack = Haystack
+ tests/PackageTests/Haddock/Check.hs view
@@ -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)))
+ tests/PackageTests/Haddock/Literate.lhs view
@@ -0,0 +1,4 @@+> module Literate where++> -- | For hiding needles.+> data Haystack = Haystack
+ tests/PackageTests/Haddock/NoCPP.hs view
@@ -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"
+ tests/PackageTests/Haddock/Simple.hs view
@@ -0,0 +1,4 @@+module Simple where++-- | For hiding needles.+data Haystack = Haystack
+ tests/PackageTests/Haddock/my.cabal view
@@ -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
+ tests/PackageTests/OrderFlags/Check.hs view
@@ -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)
+ tests/PackageTests/OrderFlags/Foo.hs view
@@ -0,0 +1,8 @@+module Foo where++x :: IO Int+x = return 5++f :: IO Int+f = do x+       return 3
+ tests/PackageTests/OrderFlags/my.cabal view
@@ -0,0 +1,20 @@+name: OrderFlags+version: 0.1+license: BSD3+author: Oleksandr Manzyuk+stability: stable+category: PackageTests+build-type: Simple+cabal-version: >=1.9.2++description:+    Check that Cabal correctly orders flags that are passed to GHC.++library+    exposed-modules: Foo+    build-depends: base++    ghc-options: -Wall -Werror++    if impl(ghc >= 6.12.1)+        ghc-options: -fno-warn-unused-do-bind
+ tests/PackageTests/PackageTester.hs view
@@ -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"
+ tests/PackageTests/PathsModule/Executable/Check.hs view
@@ -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
+ tests/PackageTests/PathsModule/Executable/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import Paths_PathsModule (getBinDir)++main :: IO ()+main = do+    _ <- getBinDir+    return ()
+ tests/PackageTests/PathsModule/Executable/my.cabal view
@@ -0,0 +1,16 @@+name: PathsModule+version: 0.1+license: BSD3+author: Johan Tibell+stability: stable+category: PackageTests+build-type: Simple+Cabal-version: >= 1.2++description:+    Check that the generated paths module compiles.++Executable TestPathsModule+    main-is: Main.hs+    other-modules: Paths_PathsModule+    build-depends: base
+ tests/PackageTests/PathsModule/Library/Check.hs view
@@ -0,0 +1,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
+ tests/PackageTests/PathsModule/Library/my.cabal view
@@ -0,0 +1,15 @@+name: PathsModule+version: 0.1+license: BSD3+author: Johan Tibell+stability: stable+category: PackageTests+build-type: Simple+Cabal-version: >= 1.2++description:+    Check that the generated paths module compiles.++Library+    exposed-modules: Paths_PathsModule+    build-depends: base
+ tests/PackageTests/PreProcess/Check.hs view
@@ -0,0 +1,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
+ tests/PackageTests/PreProcess/Foo.hsc view
@@ -0,0 +1,1 @@+module Foo where
+ tests/PackageTests/PreProcess/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import Foo++main :: IO ()+main = return ()
+ tests/PackageTests/PreProcess/my.cabal view
@@ -0,0 +1,32 @@+name: PreProcess+version: 0.1+license: BSD3+author: Johan Tibell+stability: stable+category: PackageTests+build-type: Simple+Cabal-version: >= 1.2++description:+    Check that preprocessors are run.++Library+    exposed-modules: Foo+    build-depends: base++Executable my-executable+    main-is: Main.hs+    other-modules: Foo+    build-depends: base++Test-Suite my-test-suite+    main-is: Main.hs+    type: exitcode-stdio-1.0+    other-modules: Foo+    build-depends: base++Benchmark my-benchmark+    main-is: Main.hs+    type: exitcode-stdio-1.0+    other-modules: Foo+    build-depends: base
+ tests/PackageTests/ReexportedModules/Check.hs view
@@ -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
+ tests/PackageTests/ReexportedModules/ReexportedModules.cabal view
@@ -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
+ tests/PackageTests/TemplateHaskell/Check.hs view
@@ -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
+ tests/PackageTests/TemplateHaskell/dynamic/Exe.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import TH++main = print $(splice)
+ tests/PackageTests/TemplateHaskell/dynamic/Lib.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Lib where++import TH++val = $(splice)
+ tests/PackageTests/TemplateHaskell/dynamic/TH.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}+module TH where++splice = [| () |]
+ tests/PackageTests/TemplateHaskell/dynamic/my.cabal view
@@ -0,0 +1,15 @@+Name: templateHaskell+Version: 0.1+Build-Type: Simple+Cabal-Version: >= 1.2++Library+    Exposed-Modules: Lib+    Other-Modules: TH+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell++Executable main+    Main-is: Exe.hs+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell
+ tests/PackageTests/TemplateHaskell/profiling/Exe.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import TH++main = print $(splice)
+ tests/PackageTests/TemplateHaskell/profiling/Lib.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Lib where++import TH++val = $(splice)
+ tests/PackageTests/TemplateHaskell/profiling/TH.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}+module TH where++splice = [| () |]
+ tests/PackageTests/TemplateHaskell/profiling/my.cabal view
@@ -0,0 +1,15 @@+Name: templateHaskell+Version: 0.1+Build-Type: Simple+Cabal-Version: >= 1.2++Library+    Exposed-Modules: Lib+    Other-Modules: TH+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell++Executable main+    Main-is: Exe.hs+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell
+ tests/PackageTests/TemplateHaskell/vanilla/Exe.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import TH++main = print $(splice)
+ tests/PackageTests/TemplateHaskell/vanilla/Lib.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module Lib where++import TH++val = $(splice)
+ tests/PackageTests/TemplateHaskell/vanilla/TH.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}+module TH where++splice = [| () |]
+ tests/PackageTests/TemplateHaskell/vanilla/my.cabal view
@@ -0,0 +1,15 @@+Name: templateHaskell+Version: 0.1+Build-Type: Simple+Cabal-Version: >= 1.2++Library+    Exposed-Modules: Lib+    Other-Modules: TH+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell++Executable main+    Main-is: Exe.hs+    Build-Depends: base, template-haskell+    Extensions: TemplateHaskell
+ tests/PackageTests/TestOptions/Check.hs view
@@ -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'
+ tests/PackageTests/TestOptions/TestOptions.cabal view
@@ -0,0 +1,20 @@+name: TestOptions+version: 0.1+license: BSD3+author: Thomas Tuegel+stability: stable+category: PackageTests+build-type: Simple+cabal-version: >= 1.9.2++description:+    Check that Cabal passes the correct test options to test suites.++executable dummy+    main-is: test-TestOptions.hs+    build-depends: base++test-suite test-TestOptions+    main-is: test-TestOptions.hs+    type: exitcode-stdio-1.0+    build-depends: base
+ tests/PackageTests/TestOptions/test-TestOptions.hs view
@@ -0,0 +1,11 @@+module Main where++import System.Environment ( getArgs )+import System.Exit ( exitFailure, exitSuccess )++main :: IO ()+main = do+    args <- getArgs+    if args == ["1", "2", "3"]+        then exitSuccess+        else putStrLn ("Got: " ++ show args) >> exitFailure
+ tests/PackageTests/TestStanza/Check.hs view
@@ -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
+ tests/PackageTests/TestStanza/my.cabal view
@@ -0,0 +1,19 @@+name: TestStanza+version: 0.1+license: BSD3+author: Thomas Tuegel+stability: stable+category: PackageTests+build-type: Simple++description:+    Check that Cabal recognizes the Test stanza defined below.++Library+    exposed-modules: MyLibrary+    build-depends: base++test-suite dummy+    main-is: dummy.hs+    type: exitcode-stdio-1.0+    build-depends: base
+ tests/PackageTests/TestSuiteExeV10/Check.hs view
@@ -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
+ tests/PackageTests/TestSuiteExeV10/Foo.hs view
@@ -0,0 +1,4 @@+module Foo where++fooTest :: [String] -> Bool+fooTest _ = True
+ tests/PackageTests/TestSuiteExeV10/my.cabal view
@@ -0,0 +1,15 @@+name:           my+version:        0.1+license:        BSD3+cabal-version:  >= 1.9.2+build-type:     Simple++library+    exposed-modules:    Foo+    build-depends:      base++test-suite test-Foo+    type:   exitcode-stdio-1.0+    hs-source-dirs: tests+    main-is:    test-Foo.hs+    build-depends: base, my
+ tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs view
@@ -0,0 +1,8 @@+module Main where++import Foo+import System.Exit++main :: IO ()+main | fooTest [] = exitSuccess+     | otherwise = exitFailure
+ tests/README.md view
@@ -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
+ tests/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ tests/UnitTests.hs view
@@ -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
+ tests/UnitTests/Distribution/Compat/CreatePipe.hs view
@@ -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
+ tests/UnitTests/Distribution/Compat/ReadP.hs view
@@ -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
+ tests/UnitTests/Distribution/Utils/NubList.hs view
@@ -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)
+ tests/hackage/check.sh view
@@ -0,0 +1,25 @@+#!/bin/sh++base_version=1.4.0.2+test_version=1.5.6++for setup in archive/*/*/Setup.hs archive/*/*/Setup.lhs; do++  pkgname=$(basename ${setup})+  +  if test $(wc -w < ${setup}) -gt 21; then+    if ghc -package Cabal-${base_version} -S ${setup} -o /dev/null 2> /dev/null; then++      if ghc -package Cabal-${test_version} -S ${setup} -o /dev/null 2> /dev/null; then+        echo "OK ${setup}"+      else+        echo "FAIL ${setup} does not compile with Cabal-${test_version}"     +      fi+    else+      echo "OK ${setup} (does not compile with Cabal-${base_version})" +    fi+  else+    echo "trivial ${setup}"+  fi++done
+ tests/hackage/download.sh view
@@ -0,0 +1,19 @@+#!/bin/sh++if test ! -f archive/archive.tar; then++  wget http://hackage.haskell.org/cgi-bin/hackage-scripts/archive.tar+  mkdir -p archive+  mv archive.tar archive/+  tar -C archive -xf archive/archive.tar    ++fi++if test ! -f archive/00-index.tar.gz; then++  wget http://hackage.haskell.org/packages/archive/00-index.tar.gz+  mkdir -p archive+  mv 00-index.tar.gz archive/+  tar -C archive -xzf archive/00-index.tar.gz++fi
+ tests/hackage/unpack.sh view
@@ -0,0 +1,16 @@+#!/bin/sh++for tarball in archive/*/*/*.tar.gz; do++  pkgdir=$(dirname ${tarball})+  pkgname=$(basename ${tarball} .tar.gz)++  if tar -tzf ${tarball} ${pkgname}/Setup.hs 2> /dev/null; then+    tar -xzf ${tarball} ${pkgname}/Setup.hs -O > ${pkgdir}/Setup.hs+  elif tar -tzf ${tarball} ${pkgname}/Setup.lhs 2> /dev/null; then+    tar -xzf ${tarball} ${pkgname}/Setup.lhs -O > ${pkgdir}/Setup.lhs+  else+    echo "${pkgname} has no Setup.hs or .lhs at all!!?!"+  fi++done
+ tests/misc/ghc-supported-languages.hs view
@@ -0,0 +1,97 @@+-- | A test program to check that ghc has got all of its extensions registered+--+module Main where++import Language.Haskell.Extension+import Distribution.Text+import Distribution.Simple.Utils+import Distribution.Verbosity++import Data.List ((\\))+import Data.Maybe+import Control.Applicative+import Control.Monad+import System.Environment+import System.Exit++-- | A list of GHC extensions that are deliberately not registered,+-- e.g. due to being experimental and not ready for public consumption+--+exceptions = map readExtension []++checkProblems :: [Extension] -> [String]+checkProblems implemented =++  let unregistered  =+        [ ext | ext <- implemented          -- extensions that ghc knows about +              , not (registered ext)        -- but that are not registered+              , ext `notElem` exceptions ]  -- except for the exceptions++      -- check if someone has forgotten to update the exceptions list...++      -- exceptions that are not implemented+      badExceptions  = exceptions \\ implemented+      +      -- exceptions that are now registered+      badExceptions' = filter registered exceptions+      +   in catMaybes+      [ check unregistered $ unlines+          [ "The following extensions are known to GHC but are not in the "+          , "extension registry in Language.Haskell.Extension."+          , "  " ++ intercalate "\n  " (map display unregistered)+          , "If these extensions are ready for public consumption then they "+          , "should be registered. If they are still experimental and you "+          , "think they are not ready to be registered then please add them "+          , "to the exceptions list in this test program along with an "+          , "explanation."+          ]+      , check badExceptions $ unlines+          [ "Error in the extension exception list. The following extensions"+          , "are listed as exceptions but are not even implemented by GHC:"+          , "  " ++ intercalate "\n  " (map display badExceptions)+          , "Please fix this test program by correcting the list of"+          , "exceptions."+          ]+      , check badExceptions' $ unlines+          [ "Error in the extension exception list. The following extensions"+          , "are listed as exceptions to registration but they are in fact"+          , "now registered in Language.Haskell.Extension:"+          , "  " ++ intercalate "\n  " (map display badExceptions')+          , "Please fix this test program by correcting the list of"+          , "exceptions."+          ]+      ]+  where+   registered (UnknownExtension _) = False+   registered _                    = True++   check [] _ = Nothing  +   check _  i = Just i+++main = topHandler $ do+  [ghcPath] <- getArgs+  exts      <- getExtensions ghcPath+  let problems = checkProblems exts+  putStrLn (intercalate "\n" problems)+  if null problems+    then exitSuccess+    else exitFailure++getExtensions :: FilePath -> IO [Extension]+getExtensions ghcPath =+        map readExtension . lines+    <$> rawSystemStdout normal ghcPath ["--supported-languages"]++readExtension :: String -> Extension+readExtension str = handleNoParse $ do+    -- GHC defines extensions in a positive way, Cabal defines them+    -- relative to H98 so we try parsing ("No" ++ extName) first+    ext <- simpleParse ("No" ++ str)+    case ext of+      UnknownExtension _ -> simpleParse str+      _                  -> return ext+  where+    handleNoParse :: Maybe Extension -> Extension+    handleNoParse = fromMaybe (error $ "unparsable extension " ++ show str)