Cabal 1.10.2.0 → 1.12.0

raw patch · 55 files changed

+2163/−688 lines, 55 filesdep +Cabaldep +HUnitdep +QuickCheckdep ~basedep ~directorydep ~filepathPVP ok

version bump matches the API change (PVP)

Dependencies added: Cabal, HUnit, QuickCheck, bytestring, extensible-exceptions, test-framework, test-framework-hunit, test-framework-quickcheck2

Dependency ranges changed: base, directory, filepath, pretty, process, unix

API changes (from Hackage documentation)

Files

• Cabal.cabal +43/−6
• Distribution/Compat/CopyFile.hs +9/−2
• Distribution/Compat/Exception.hs +15/−3
• Distribution/Compat/TempFile.hs +5/−5
• Distribution/InstalledPackageInfo.hs +17/−6
• Distribution/Make.hs +2/−1
• Distribution/PackageDescription.hs +5/−8
• Distribution/PackageDescription/Check.hs +49/−24
• Distribution/PackageDescription/Parse.hs +21/−9
• Distribution/PackageDescription/PrettyPrint.hs +238/−0
• Distribution/ParseUtils.hs +41/−7
• Distribution/Simple.hs +27/−2
• Distribution/Simple/Build.hs +87/−88
• Distribution/Simple/Build/PathsModule.hs +20/−16
• Distribution/Simple/Compiler.hs +2/−2
• Distribution/Simple/Configure.hs +76/−19
• Distribution/Simple/GHC.hs +73/−46
• Distribution/Simple/GHC/IPI641.hs +2/−0
• Distribution/Simple/GHC/IPI642.hs +2/−0
• Distribution/Simple/Haddock.hs +99/−95
• Distribution/Simple/Hpc.hs +185/−0
• Distribution/Simple/Hugs.hs +33/−27
• Distribution/Simple/InstallDirs.hs +5/−5
• Distribution/Simple/JHC.hs +9/−5
• Distribution/Simple/LHC.hs +3/−3
• Distribution/Simple/LocalBuildInfo.hs +117/−25
• Distribution/Simple/NHC.hs +22/−9
• Distribution/Simple/PreProcess.hs +65/−67
• Distribution/Simple/Program/HcPkg.hs +70/−9
• Distribution/Simple/Program/Types.hs +17/−1
• Distribution/Simple/Register.hs +7/−6
• Distribution/Simple/Setup.hs +39/−4
• Distribution/Simple/SrcDist.hs +56/−42
• Distribution/Simple/Test.hs +17/−2
• Distribution/Simple/UHC.hs +17/−13
• Distribution/Simple/Utils.hs +12/−7
• Distribution/System.hs +11/−4
• Distribution/Text.hs +2/−2
• Distribution/Version.hs +2/−2
• Language/Haskell/Extension.hs +85/−116
• tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs +15/−0
• tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs +15/−0
• tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs +20/−0
• tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs +12/−0
• tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs +24/−0
• tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs +24/−0
• tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs +24/−0
• tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs +12/−0
• tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs +18/−0
• tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs +13/−0
• tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs +17/−0
• tests/PackageTests/PackageTester.hs +192/−0
• tests/PackageTests/TestStanza/Check.hs +57/−0
• tests/PackageTests/TestSuiteExeV10/Check.hs +47/−0
• tests/suite.hs +66/−0

@@ -1,5 +1,5 @@ Name: Cabal-Version: 1.10.2.0+Version: 1.12.0 Copyright: 2003-2006, Isaac Jones            2005-2011, Duncan Coutts License: BSD3@@ -18,7 +18,7 @@         The Haskell Cabal is part of a larger infrastructure for distributing,         organizing, and cataloging Haskell libraries and tools. Category: Distribution-cabal-version: >=1.6+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.@@ -43,14 +43,14 @@   if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 }   if flag(base3)     Build-Depends: directory  >= 1   && < 1.2,-                   process    >= 1   && < 1.1,+                   process    >= 1   && < 1.2,                    old-time   >= 1   && < 1.1,                    containers >= 0.1 && < 0.5,                    array      >= 0.1 && < 0.4,-                   pretty     >= 1   && < 1.1+                   pretty     >= 1   && < 1.2    if !os(windows)-    Build-Depends: unix       >= 2.0 && < 2.5+    Build-Depends: unix       >= 2.0 && < 2.6    ghc-options: -Wall -fno-ignore-asserts   if impl(ghc >= 6.8)@@ -68,6 +68,7 @@         Distribution.PackageDescription.Configuration,         Distribution.PackageDescription.Parse,         Distribution.PackageDescription.Check,+        Distribution.PackageDescription.PrettyPrint,         Distribution.ParseUtils,         Distribution.ReadE,         Distribution.Simple,@@ -81,6 +82,7 @@         Distribution.Simple.GHC,         Distribution.Simple.LHC,         Distribution.Simple.Haddock,+        Distribution.Simple.Hpc,         Distribution.Simple.Hugs,         Distribution.Simple.Install,         Distribution.Simple.InstallDirs,@@ -123,4 +125,39 @@         Distribution.Simple.GHC.IPI642,         Paths_Cabal -  Extensions: CPP+  Default-Language: Haskell98+  Default-Extensions: CPP++test-suite unit-tests+  type: exitcode-stdio-1.0+  main-is: suite.hs+  other-modules: PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check,+                 PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check,+                 PackageTests.BuildDeps.InternalLibrary0.Check,+                 PackageTests.BuildDeps.InternalLibrary1.Check,+                 PackageTests.BuildDeps.InternalLibrary2.Check,+                 PackageTests.BuildDeps.InternalLibrary3.Check,+                 PackageTests.BuildDeps.InternalLibrary4.Check,+                 PackageTests.BuildDeps.TargetSpecificDeps1.Check,+                 PackageTests.BuildDeps.TargetSpecificDeps2.Check,+                 PackageTests.BuildDeps.TargetSpecificDeps3.Check,+                 PackageTests.BuildDeps.SameDepsAllRound.Check,+                 PackageTests.TestStanza.Check,+                 PackageTests.TestSuiteExeV10.Check,+                 PackageTests.PackageTester+  hs-source-dirs: tests+  build-depends:+        base,+        test-framework,+        test-framework-quickcheck2,+        test-framework-hunit,+        HUnit,+        QuickCheck >= 2.1.0.1,+        Cabal,+        process,+        directory,+        filepath,+        extensible-exceptions,+        bytestring,+        unix+  Default-Language: Haskell98

@@ -41,12 +41,15 @@ #endif /* __GLASGOW_HASKELL__ */  #ifndef mingw32_HOST_OS+#if __GLASGOW_HASKELL__ >= 611+import System.Posix.Internals (withFilePath)+#else+import Foreign.C              (withCString)+#endif import System.Posix.Types          ( FileMode ) import System.Posix.Internals          ( c_chmod )-import Foreign.C-         ( withCString ) #if __GLASGOW_HASKELL__ >= 608 import Foreign.C          ( throwErrnoPathIfMinus1_ )@@ -67,7 +70,11 @@  setFileMode :: FilePath -> FileMode -> IO () setFileMode name m =+#if __GLASGOW_HASKELL__ >= 611+  withFilePath name $ \s -> do+#else   withCString name $ \s -> do+#endif #if __GLASGOW_HASKELL__ >= 608     throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) #else

@@ -9,9 +9,14 @@ #define NEW_EXCEPTION #endif -module Distribution.Compat.Exception-    (Exception.IOException, onException, catchIO, catchExit, throwIOIO)-    where+module Distribution.Compat.Exception (+     Exception.IOException,+     onException,+     catchIO,+     catchExit,+     throwIOIO,+     tryIO,+  ) where  import System.Exit import qualified Control.Exception as Exception@@ -29,6 +34,13 @@ throwIOIO = Exception.throwIO #else throwIOIO = Exception.throwIO . Exception.IOException+#endif++tryIO :: IO a -> IO (Either Exception.IOException a)+#ifdef NEW_EXCEPTION+tryIO = Exception.try+#else+tryIO = Exception.tryJust Exception.ioErrors #endif  catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a

@@ -27,7 +27,7 @@ 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        (try, isAlreadyExistsError)+import System.IO.Error        (isAlreadyExistsError) #if __GLASGOW_HASKELL__ >= 611 import System.Posix.Internals (withFilePath) #else@@ -39,7 +39,7 @@ #else import GHC.Handle             (fdToHandle) #endif-import Distribution.Compat.Exception (onException)+import Distribution.Compat.Exception (onException, tryIO) #endif import Foreign.C              (getErrno, errnoToIOError) @@ -89,7 +89,7 @@     (templateBase, templateExt) = splitExtension template     findTempName :: Int -> IO (FilePath, Handle)     findTempName x-      = do let path = tmp_dir </> (templateBase ++ show x) <.> templateExt+      = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt            b  <- doesFileExist path            if b then findTempName (x+1)                 else do hnd <- openBinaryFile path ReadWriteMode@@ -189,8 +189,8 @@   findTempName pid   where     findTempName x = do-      let dirpath = dir </> template ++ show x-      r <- try $ mkPrivateDir dirpath+      let dirpath = dir </> template ++ "-" ++ show x+      r <- tryIO $ mkPrivateDir dirpath       case r of         Right _ -> return dirpath         Left  e | isAlreadyExistsError e -> findTempName (x+1)

@@ -61,12 +61,13 @@         parseInstalledPackageInfo,         showInstalledPackageInfo,         showInstalledPackageInfoField,+        fieldsInstalledPackageInfo,   ) where  import Distribution.ParseUtils          ( FieldDescr(..), ParseResult(..), PError(..), PWarning          , simpleField, listField, parseLicenseQ-         , showFields, showSingleNamedField, parseFields+         , showFields, showSingleNamedField, parseFieldsFlat          , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ          , showFilePath, showToken, boolField, parseOptVersion          , parseFreeText, showFreeText )@@ -98,12 +99,14 @@         stability         :: String,         homepage          :: String,         pkgUrl            :: String,+        synopsis          :: String,         description       :: String,         category          :: String,         -- these parts are required by an installed package only:         exposed           :: Bool,         exposedModules    :: [m],         hiddenModules     :: [m],+        trusted           :: Bool,         importDirs        :: [FilePath],  -- contain sources in case of Hugs         libraryDirs       :: [FilePath],         hsLibraries       :: [String],@@ -139,11 +142,13 @@         stability         = "",         homepage          = "",         pkgUrl            = "",+        synopsis          = "",         description       = "",         category          = "",         exposed           = False,         exposedModules    = [],         hiddenModules     = [],+        trusted           = False,         importDirs        = [],         libraryDirs       = [],         hsLibraries       = [],@@ -168,22 +173,23 @@ -- Parsing  parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo-parseInstalledPackageInfo = parseFields all_fields emptyInstalledPackageInfo+parseInstalledPackageInfo =+    parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo  -- ----------------------------------------------------------------------------- -- Pretty-printing  showInstalledPackageInfo :: InstalledPackageInfo -> String-showInstalledPackageInfo = showFields all_fields+showInstalledPackageInfo = showFields fieldsInstalledPackageInfo  showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)-showInstalledPackageInfoField = showSingleNamedField all_fields+showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo  -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing -all_fields :: [FieldDescr InstalledPackageInfo]-all_fields = basicFieldDescrs ++ installedFieldDescrs+fieldsInstalledPackageInfo :: [FieldDescr InstalledPackageInfo]+fieldsInstalledPackageInfo = basicFieldDescrs ++ installedFieldDescrs  basicFieldDescrs :: [FieldDescr InstalledPackageInfo] basicFieldDescrs =@@ -214,6 +220,9 @@  , 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})@@ -235,6 +244,8 @@  , listField   "hidden-modules"         disp               parseModuleNameQ         hiddenModules      (\xs    pkg -> pkg{hiddenModules=xs})+ , boolField   "trusted"+        trusted            (\val pkg -> pkg{trusted=val})  , listField   "import-dirs"         showFilePath       parseFilePathQ         importDirs         (\xs pkg -> pkg{importDirs=xs})

@@ -90,6 +90,7 @@   ) 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@@ -183,7 +184,7 @@ haddockAction flags args = do   noExtraFlags args   rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"]-    `catch` \_ ->+    `catchIO` \_ ->     rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"]  buildAction :: BuildFlags -> [String] -> IO ()

@@ -602,8 +602,8 @@ emptyBuildInfo :: BuildInfo emptyBuildInfo = mempty --- | The 'BuildInfo' for the library (if there is one and it's buildable) and--- all the buildable executables. Useful for gathering dependencies.+-- | The 'BuildInfo' for the library (if there is one and it's buildable), and+-- all buildable executables and test suites.  Useful for gathering dependencies. allBuildInfo :: PackageDescription -> [BuildInfo] allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr]                               , let bi = libBuildInfo lib@@ -613,7 +613,8 @@                               , buildable bi ]                       ++ [ bi | tst <- testSuites pkg_descr                               , let bi = testBuildInfo tst-                              , buildable bi ]+                              , buildable bi+                              , testEnabled tst ]   --FIXME: many of the places where this is used, we actually want to look at   --       unbuildable bits too, probably need separate functions @@ -788,11 +789,7 @@       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--       --the lib only exists in the buildinfo file.  FIX: Is this-       --wrong?  If there aren't any exposedModules, then the library-       --won't build anyway.  add to sanity checker?-      updateLibrary (Just bi) Nothing     = Just emptyLibrary{libBuildInfo=bi}+      updateLibrary (Just _)  Nothing    = Nothing        updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)]                         -> [Executable]          -- ^list of executables to update

@@ -101,7 +101,7 @@  import qualified Language.Haskell.Extension as Extension (deprecatedExtensions) import Language.Haskell.Extension-         ( Language(UnknownLanguage), knownLanguages, Extension(..) )+         ( Language(UnknownLanguage), knownLanguages, Extension(..), KnownExtension(..) ) import System.FilePath          ( (</>), takeExtension, isRelative, isAbsolute          , splitDirectories,  splitPath )@@ -395,6 +395,10 @@   , 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)."@@ -643,23 +647,38 @@     checkFlags flags = check (any (`elem` flags) all_ghc_options)      ghcExtension ('-':'f':name) = case name of-      "allow-overlapping-instances" -> Just OverlappingInstances-      "th"                          -> Just TemplateHaskell-      "ffi"                         -> Just ForeignFunctionInterface-      "fi"                          -> Just ForeignFunctionInterface-      "no-monomorphism-restriction" -> Just NoMonomorphismRestriction-      "no-mono-pat-binds"           -> Just NoMonoPatBinds-      "allow-undecidable-instances" -> Just UndecidableInstances-      "allow-incoherent-instances"  -> Just IncoherentInstances-      "arrows"                      -> Just Arrows-      "generics"                    -> Just Generics-      "no-implicit-prelude"         -> Just NoImplicitPrelude-      "implicit-params"             -> Just ImplicitParams-      "bang-patterns"               -> Just BangPatterns-      "scoped-type-variables"       -> Just ScopedTypeVariables-      "extended-default-rules"      -> Just ExtendedDefaultRules-      _                             -> Nothing-    ghcExtension ('-':'c':"pp")     = Just CPP+      "allow-overlapping-instances"    -> Just (EnableExtension  OverlappingInstances)+      "no-allow-overlapping-instances" -> Just (DisableExtension OverlappingInstances)+      "th"                             -> Just (EnableExtension  TemplateHaskell)+      "no-th"                          -> Just (DisableExtension TemplateHaskell)+      "ffi"                            -> Just (EnableExtension  ForeignFunctionInterface)+      "no-ffi"                         -> Just (DisableExtension ForeignFunctionInterface)+      "fi"                             -> Just (EnableExtension  ForeignFunctionInterface)+      "no-fi"                          -> Just (DisableExtension ForeignFunctionInterface)+      "monomorphism-restriction"       -> Just (EnableExtension  MonomorphismRestriction)+      "no-monomorphism-restriction"    -> Just (DisableExtension MonomorphismRestriction)+      "mono-pat-binds"                 -> Just (EnableExtension  MonoPatBinds)+      "no-mono-pat-binds"              -> Just (DisableExtension MonoPatBinds)+      "allow-undecidable-instances"    -> Just (EnableExtension  UndecidableInstances)+      "no-allow-undecidable-instances" -> Just (DisableExtension UndecidableInstances)+      "allow-incoherent-instances"     -> Just (EnableExtension  IncoherentInstances)+      "no-allow-incoherent-instances"  -> Just (DisableExtension IncoherentInstances)+      "arrows"                         -> Just (EnableExtension  Arrows)+      "no-arrows"                      -> Just (DisableExtension Arrows)+      "generics"                       -> Just (EnableExtension  Generics)+      "no-generics"                    -> Just (DisableExtension Generics)+      "implicit-prelude"               -> Just (EnableExtension  ImplicitPrelude)+      "no-implicit-prelude"            -> Just (DisableExtension ImplicitPrelude)+      "implicit-params"                -> Just (EnableExtension  ImplicitParams)+      "no-implicit-params"             -> Just (DisableExtension ImplicitParams)+      "bang-patterns"                  -> Just (EnableExtension  BangPatterns)+      "no-bang-patterns"               -> Just (DisableExtension BangPatterns)+      "scoped-type-variables"          -> Just (EnableExtension  ScopedTypeVariables)+      "no-scoped-type-variables"       -> Just (DisableExtension ScopedTypeVariables)+      "extended-default-rules"         -> Just (EnableExtension  ExtendedDefaultRules)+      "no-extended-default-rules"      -> Just (DisableExtension ExtendedDefaultRules)+      _                                -> Nothing+    ghcExtension "-cpp"             = Just (EnableExtension CPP)     ghcExtension _                  = Nothing  checkCCOptions :: PackageDescription -> [PackageCheck]@@ -1034,28 +1053,34 @@      -- The known extensions in Cabal-1.2.3     compatExtensions =+      map EnableExtension       [ OverlappingInstances, UndecidableInstances, IncoherentInstances       , RecursiveDo, ParallelListComp, MultiParamTypeClasses-      , NoMonomorphismRestriction, FunctionalDependencies, Rank2Types+      , FunctionalDependencies, Rank2Types       , RankNTypes, PolymorphicComponents, ExistentialQuantification       , ScopedTypeVariables, ImplicitParams, FlexibleContexts       , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns       , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface-      , Arrows, Generics, NoImplicitPrelude, NamedFieldPuns, PatternGuards+      , Arrows, Generics, NamedFieldPuns, PatternGuards       , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms-      , HereDocuments-      ] ++ compatExtensionsExtra+      , 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, NoMonoPatBinds, RelaxedPolyRec+      , 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

@@ -58,6 +58,14 @@         parseHookedBuildInfo,         writeHookedBuildInfo,         showHookedBuildInfo,++        pkgDescrFieldDescrs,+        libFieldDescrs,+        executableFieldDescrs,+        binfoFieldDescrs,+        sourceRepoFieldDescrs,+        testSuiteFieldDescrs,+        flagFieldDescrs   ) where  import Data.Char  (isSpace)@@ -166,7 +174,8 @@ -- | 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 = (f,val):(customFieldsPD pkg) }+storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD =+                                                        (customFieldsPD pkg) ++ [(f,val)]} storeXFieldsPD _ _ = Nothing  -- ---------------------------------------------------------------------------@@ -184,7 +193,7 @@  storeXFieldsLib :: UnrecFieldParser Library storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) =-    Just $ l {libBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi) }}+    Just $ l {libBuildInfo = bi{ customFieldsBI = (customFieldsBI bi) ++ [(f,val)]}} storeXFieldsLib _ _ = Nothing  -- ---------------------------------------------------------------------------@@ -546,6 +555,9 @@ 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@@ -738,7 +750,7 @@             flds <- collectFields parseExeFields sec_fields             skipField             (repos, flags, lib, exes, tests) <- getBody-            return (repos, flags, lib, exes ++ [(exename, flds)], tests)+            return (repos, flags, lib, (exename, flds): exes, tests)          | sec_type == "test-suite" -> do             when (null sec_label) $ lift $ syntaxError line_no@@ -772,7 +784,7 @@                     -- 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 need one to specify a type because the+                    -- 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)@@ -782,11 +794,11 @@                     (repos, flags, lib, exes, tests) <- getBody                     return (repos, flags, lib, exes, (testname, flds) : tests)                 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)+                         "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 == "library" -> do             when (not (null sec_label)) $ lift $

@@ -0,0 +1,238 @@+-----------------------------------------------------------------------------+--+-- Module      :  Distribution.PackageDescription.PrettyPrint+-- Copyright   :  Jürgen Nicklisch-Franken 2010+-- License     :  AllRightsReserved+--+-- Maintainer  : cabal-devel@haskell.org+-- Stability   : provisional+-- Portability : portable+--+-- | Pretty printing for cabal files+--+-----------------------------------------------------------------------------+{- 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. -}++module Distribution.PackageDescription.PrettyPrint (+    writeGenericPackageDescription,+    showGenericPackageDescription,+) where++import Distribution.PackageDescription+       ( TestSuite(..), TestSuiteInterface(..), testType+       , SourceRepo(..),+        customFieldsBI, CondTree(..), Condition(..),+        FlagName(..), ConfVar(..), Executable(..), Library(..),+        Flag(..), PackageDescription(..),+        GenericPackageDescription(..))+import Text.PrettyPrint+       (hsep, comma, punctuate, fsep, parens, char, nest, empty,+        isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render)+import Distribution.Simple.Utils (writeUTF8File)+import Distribution.ParseUtils (showFreeText, FieldDescr(..))+import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,+       sourceRepoFieldDescrs)+import Distribution.Package (Dependency(..))+import Distribution.Text (Text(..))+import Data.Maybe (isJust, fromJust, isNothing)++indentWith :: Int+indentWith = 4++-- | 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)++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"]++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+                      | otherwise        = text name <> colon <+> fielddoc++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 (MkFlag name desc dflt manual)    =+    emptyLine $ text "flag" <+> ppFlagName name $+$+            (nest indentWith ((if null desc+                                then empty+                                else  text "Description: " <+> showFreeText desc) $+$+                     (if dflt then empty else text "Default: False") $+$+                     (if manual then text "Manual: True" else empty)))++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     = ppFields 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')+            $+$ ppFields 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 =+                text "type:" <+> disp (testType testsuite)+            $+$ maybe empty (\f -> text "main-is:"     <+> text f)+                            (testSuiteMainIs testsuite)+            $+$ maybe empty (\m -> text "test-module:" <+> disp m)+                            (testSuiteModule testsuite)+            $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite)+            $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))++    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++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 deps ifs) mbIt ppIt =+    let res = ppDeps deps+                $+$ (vcat $ map ppIf ifs)+                $+$ ppIt it mbIt+    in if isJust mbIt && isEmpty res+        then ppCondTree ct Nothing ppIt+        else res+  where+    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))++ppDeps :: [Dependency] -> Doc+ppDeps []                                = empty+ppDeps deps                              =+    text "build-depends:" <+> fsep (punctuate comma (map disp deps))++emptyLine :: Doc -> Doc+emptyLine d                              = text " " $+$ d+++

@@ -52,8 +52,8 @@         LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,         runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning,         Field(..), fName, lineNo,-        FieldDescr(..), ppField, ppFields, readFields,-        showFields, showSingleNamedField, parseFields,+        FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat,+        showFields, showSingleNamedField, parseFields, parseFieldsFlat,         parseFilePathQ, parseTokenQ, parseTokenQ',         parseModuleNameQ, parseBuildTool, parsePkgconfigDependency,         parseOptVersion, parsePackageNameQ, parseVersionRangeQ,@@ -77,7 +77,7 @@ import Distribution.Text          ( Text(..) ) import Distribution.Simple.Utils-         ( intercalate, lowercase, normaliseLineEndings )+         ( comparing, intercalate, lowercase, normaliseLineEndings ) import Language.Haskell.Extension          ( Language, Extension ) @@ -88,6 +88,7 @@ import qualified Data.Map as Map import Control.Monad (foldM) import System.FilePath (normalise)+import Data.List (sortBy)  -- ----------------------------------------------------------------------------- @@ -230,14 +231,16 @@ 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 (update flavor opts (get b)) b) $+             (\opts b -> set (reorder (update flavor opts (get b))) b) $         field name (hsep . map text)                    (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)  -- 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@@ -275,7 +278,14 @@  parseFields :: [FieldDescr a] -> a -> String -> ParseResult a parseFields fields initial = \str ->-  readFields str >>= foldM setField initial+  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 ]@@ -352,6 +362,12 @@   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'))@@ -425,6 +441,13 @@                       | 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 = reverse . dropWhile isSpace . reverse@@ -604,7 +627,7 @@  parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) parseTestedWithQ = parseQuoted tw <++ tw-  where +  where     tw :: ReadP r (CompilerFlavor,VersionRange)     tw = do compiler <- parseCompilerFlavorCompat             skipSpaces@@ -678,4 +701,15 @@ -- | 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 s = vcat [text (if null l then "." else l) | l <- lines s]+showFreeText "" = empty+showFreeText ('\n' :r)  = text " " $+$ text "." $+$ showFreeText r+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''

@@ -87,7 +87,7 @@ import Distribution.Simple.UserHooks import Distribution.Package --must not specify imports, since we're exporting moule. import Distribution.PackageDescription-         ( PackageDescription(..), GenericPackageDescription+         ( PackageDescription(..), GenericPackageDescription, Executable(..)          , updatePackageDescription, hasLibs          , HookedBuildInfo, emptyHookedBuildInfo ) import Distribution.PackageDescription.Parse@@ -138,7 +138,7 @@ import Distribution.Compat.Exception (catchIO, throwIOIO)  import Control.Monad   (when)-import Data.List       (intersperse, unionBy)+import Data.List       (intersperse, unionBy, nub, (\\))  -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the@@ -302,6 +302,9 @@                 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@@ -333,6 +336,7 @@                 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@@ -384,12 +388,31 @@    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 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@@ -524,6 +547,7 @@                          backwardsCompatHack flags lbi                     pbi <- getHookedBuildInfo verbosity+                   sanityCheckHookedBuildInfo pkg_descr pbi                    let pkg_descr' = updatePackageDescription pbi pkg_descr                    postConf simpleUserHooks args flags pkg_descr' lbi @@ -554,6 +578,7 @@                      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 

@@ -76,11 +76,11 @@ import Distribution.Simple.Setup          ( BuildFlags(..), fromFlag ) import Distribution.Simple.PreProcess-         ( preprocessSources, PPSuffixHandler )+         ( preprocessComponent, PPSuffixHandler ) import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(compiler, buildDir, withPackageDB)-         , ComponentLocalBuildInfo(..), withLibLBI, withExeLBI-         , inplacePackageId, withTestLBI )+         , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI+         , inplacePackageId ) import Distribution.Simple.BuildPaths          ( autogenModulesDir, autogenModuleName, cppHeaderName ) import Distribution.Simple.Register@@ -107,100 +107,102 @@ -- ----------------------------------------------------------------------------- -- |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+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)-  initialBuildSteps distPref pkg_descr lbi verbosity suffixes+  initialBuildSteps distPref pkg_descr lbi verbosity   setupMessage verbosity "Building" (packageId pkg_descr)    internalPackageDB <- createInternalPackageDB distPref -  withLibLBI pkg_descr lbi $ \lib clbi -> do-    info verbosity "Building library..."-    buildLib verbosity pkg_descr lbi lib clbi--    -- Register the library in-place, so exes can depend-    -- on internally defined libraries.-    pwd <- getCurrentDirectory-    let installedPkgInfo =-          (inplaceInstalledPackageInfo pwd distPref pkg_descr lib lbi clbi) {-            -- The inplace registration uses the "-inplace" suffix,-            -- not an ABI hash.-            IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo)-          }-    registerPackage verbosity-      installedPkgInfo pkg_descr lbi True -- True meaning inplace-      (withPackageDB lbi ++ [internalPackageDB])+  let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes+      lbi'  = lbi {withPackageDB = withPackageDB lbi ++ [internalPackageDB]}+              -- Use the internal package DB for the exes.+  withComponentsLBI pkg_descr lbi $ \comp clbi -> do+    pre comp+    case comp of+      CLib lib -> do+        info verbosity "Building library..."+        buildLib verbosity pkg_descr lbi lib clbi -  -- Use the internal package db for the exes.-  let lbi' = lbi { withPackageDB = withPackageDB lbi ++ [internalPackageDB] }+        -- Register the library in-place, so exes can depend+        -- on internally defined libraries.+        pwd <- getCurrentDirectory+        let installedPkgInfo =+              (inplaceInstalledPackageInfo pwd distPref pkg_descr lib lbi clbi) {+                -- The inplace registration uses the "-inplace" suffix,+                -- not an ABI hash.+                IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo)+              }+        registerPackage verbosity+          installedPkgInfo pkg_descr lbi True -- True meaning inplace+          (withPackageDB lbi ++ [internalPackageDB]) -  withExeLBI pkg_descr lbi' $ \exe clbi -> do-    info verbosity $ "Building executable " ++ exeName exe ++ "..."-    buildExe verbosity pkg_descr lbi' exe clbi+      CExe exe -> do+        info verbosity $ "Building executable " ++ exeName exe ++ "..."+        buildExe verbosity pkg_descr lbi' exe clbi -  withTestLBI pkg_descr lbi' $ \test clbi ->-    case testInterface test of-        TestSuiteExeV10 _ f -> do-            let exe = Executable-                    { exeName = testName test-                    , modulePath = f-                    , buildInfo = testBuildInfo test-                    }-            info verbosity $ "Building test suite " ++ testName test ++ "..."-            buildExe verbosity pkg_descr lbi' exe clbi-        TestSuiteLibV09 _ m -> do-            pwd <- getCurrentDirectory-            let lib = Library-                    { exposedModules = [ m ]-                    , libExposed = True-                    , libBuildInfo = testBuildInfo test-                    }-                pkg = pkg_descr-                    { package = (package pkg_descr)-                        { pkgName = PackageName $ testName test+      CTest test -> do+        case testInterface test of+            TestSuiteExeV10 _ f -> do+                let exe = Executable+                        { exeName = testName test+                        , modulePath = f+                        , buildInfo = testBuildInfo test                         }-                    , buildDepends = targetBuildDepends $ testBuildInfo test-                    , executables = []-                    , testSuites = []-                    , library = Just lib-                    }-                ipi = (inplaceInstalledPackageInfo-                    pwd distPref pkg lib lbi clbi)-                    { IPI.installedPackageId = inplacePackageId $ packageId ipi-                    }-                testDir = buildDir lbi' </> stubName test-                    </> stubName test ++ "-tmp"-                testLibDep = thisPackageVersion $ package pkg-                exe = Executable-                    { exeName = stubName test-                    , modulePath = stubFilePath test-                    , buildInfo = (testBuildInfo test)-                        { hsSourceDirs = [ testDir ]-                        , targetBuildDepends = testLibDep-                            : (targetBuildDepends $ testBuildInfo test)+                info verbosity $ "Building test suite " ++ testName test ++ "..."+                buildExe verbosity pkg_descr lbi' exe clbi+            TestSuiteLibV09 _ m -> do+                pwd <- getCurrentDirectory+                let lib = Library+                        { exposedModules = [ m ]+                        , libExposed = True+                        , libBuildInfo = testBuildInfo test                         }-                    }-                -- | The stub executable needs a new 'ComponentLocalBuildInfo'-                -- that exposes the relevant test suite library.-                exeClbi = clbi-                    { componentPackageDeps =-                        (IPI.installedPackageId ipi, packageId ipi)-                        : (filter (\(_, x) -> let PackageName name = pkgName x in name == "Cabal" || name == "base")-                            $ componentPackageDeps clbi)-                    }-            info verbosity $ "Building test suite " ++ testName test ++ "..."-            buildLib verbosity pkg lbi' lib clbi-            registerPackage verbosity ipi pkg lbi' True $ withPackageDB lbi'-            buildExe verbosity pkg_descr lbi' exe exeClbi-        TestSuiteUnsupported tt -> die $ "No support for building test suite "-                                      ++ "type " ++ display tt-+                    pkg = pkg_descr+                        { package = (package pkg_descr)+                            { pkgName = PackageName $ testName test+                            }+                        , buildDepends = targetBuildDepends $ testBuildInfo test+                        , executables = []+                        , testSuites = []+                        , library = Just lib+                        }+                    ipi = (inplaceInstalledPackageInfo+                        pwd distPref pkg lib lbi clbi)+                        { IPI.installedPackageId = inplacePackageId $ packageId ipi+                        }+                    testDir = buildDir lbi' </> stubName test+                        </> stubName test ++ "-tmp"+                    testLibDep = thisPackageVersion $ package pkg+                    exe = Executable+                        { exeName = stubName test+                        , modulePath = stubFilePath test+                        , buildInfo = (testBuildInfo test)+                            { hsSourceDirs = [ testDir ]+                            , targetBuildDepends = testLibDep+                                : (targetBuildDepends $ testBuildInfo test)+                            }+                        }+                    -- | The stub executable needs a new 'ComponentLocalBuildInfo'+                    -- that exposes the relevant test suite library.+                    exeClbi = clbi+                        { componentPackageDeps =+                            (IPI.installedPackageId ipi, packageId ipi)+                            : (filter (\(_, x) -> let PackageName name = pkgName x in name == "Cabal" || name == "base")+                                $ componentPackageDeps clbi)+                        }+                info verbosity $ "Building test suite " ++ testName test ++ "..."+                buildLib verbosity pkg lbi' lib clbi+                registerPackage verbosity ipi pkg lbi' True $ withPackageDB lbi'+                buildExe verbosity pkg_descr lbi' exe exeClbi+            TestSuiteUnsupported tt -> die $ "No support for building test suite "+                                          ++ "type " ++ display tt  -- | Initialize a new package db file for libraries defined -- internally to the package.@@ -241,9 +243,8 @@                   -> PackageDescription  -- ^mostly information from the .cabal file                   -> LocalBuildInfo -- ^Configuration information                   -> Verbosity -- ^The verbosity to use-                  -> [ PPSuffixHandler ] -- ^preprocessors to run before compiling                   -> IO ()-initialBuildSteps _distPref pkg_descr lbi verbosity suffixes = do+initialBuildSteps _distPref pkg_descr lbi verbosity = do   -- check that there's something to build   let buildInfos =           map libBuildInfo (maybeToList (library pkg_descr)) ++@@ -255,8 +256,6 @@   createDirectoryIfMissingVerbose verbosity True (buildDir lbi)    writeAutogenFiles verbosity pkg_descr lbi--  preprocessSources pkg_descr lbi False verbosity suffixes  -- | Generate and write out the Paths_<pkg>.hs and cabal_macros.h files --

@@ -72,12 +72,15 @@         "  ) where\n"++         "\n"++         foreign_imports+++        "import qualified Control.Exception as Exception\n"++         "import Data.Version (Version(..))\n"++         "import System.Environment (getEnv)"++         "\n"+++        "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"+++        "catchIO = Exception.catch\n" +++        "\n"++         "\nversion :: Version"++-        "\nversion = " ++ show (packageVersion pkg_descr)++-        "\n"+        "\nversion = " ++ show (packageVersion pkg_descr)         body         | absolute =@@ -140,7 +143,7 @@         mkGetDir _   (Just dirrel) = "getPrefixDirRel " ++ show dirrel         mkGetDir dir Nothing       = "return " ++ show dir -        mkGetEnvOr var expr = "catch (getEnv \""++var'++"\")"+++        mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++                               " (\\_ -> "++expr++")"           where var' = pkgPathEnvVar pkg_descr var @@ -189,20 +192,21 @@ get_prefix_win32 :: String get_prefix_win32 =   "getPrefixDirRel :: FilePath -> IO FilePath\n"++-  "getPrefixDirRel dirRel = do \n"++-  "  let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.\n"++-  "  buf <- mallocArray len\n"++-  "  ret <- getModuleFileName nullPtr buf len\n"++-  "  if ret == 0 \n"++-  "     then do free buf;\n"++-  "             return (prefix `joinFileName` dirRel)\n"++-  "     else do exePath <- peekCString buf\n"++-  "             free buf\n"++-  "             let (bindir,_) = splitFileName exePath\n"++-  "             return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\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 stdcall unsafe \"windows.h GetModuleFileNameA\"\n"++-  "  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32\n"+  "foreign import stdcall unsafe \"windows.h GetModuleFileNameW\"\n"+++  "  c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n"+  get_prefix_hugs :: String get_prefix_hugs =

@@ -80,8 +80,8 @@  data Compiler = Compiler {         compilerId              :: CompilerId,-        compilerLanguages       :: [(Language, String)],-        compilerExtensions      :: [(Extension, String)]+        compilerLanguages       :: [(Language, Flag)],+        compilerExtensions      :: [(Extension, Flag)]     }     deriving (Show, Read) 

@@ -14,7 +14,7 @@ -- 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@@ -69,7 +69,7 @@     , showCompilerId, unsupportedLanguages, unsupportedExtensions     , PackageDB(..), PackageDBStack ) import Distribution.Package-    ( PackageName(PackageName), PackageIdentifier(PackageIdentifier), PackageId+    ( PackageName(PackageName), PackageIdentifier(..), PackageId     , packageName, packageVersion, Package(..)     , Dependency(Dependency), simplifyDependency     , InstalledPackageId(..) )@@ -87,10 +87,11 @@     ( finalizePackageDescription, mapTreeData ) import Distribution.PackageDescription.Check     ( PackageCheck(..), checkPackage, checkPackageFiles )+import Distribution.Simple.Hpc ( enableCoverage ) import Distribution.Simple.Program     ( Program(..), ProgramLocation(..), ConfiguredProgram(..)     , ProgramConfiguration, defaultProgramConfiguration-    , configureAllKnownPrograms, knownPrograms, lookupKnownProgram+    , configureAllKnownPrograms, knownPrograms, lookupKnownProgram, addKnownProgram     , userSpecifyArgss, userSpecifyPaths     , requireProgram, requireProgramVersion     , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf )@@ -100,13 +101,14 @@     ( InstallDirs(..), defaultInstallDirs, combineInstallDirs ) import Distribution.Simple.LocalBuildInfo     ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-    , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId )+    , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId+    , allComponentsBy, Component(..), foldComponent, ComponentName(..) ) import Distribution.Simple.BuildPaths     ( autogenModulesDir ) import Distribution.Simple.Utils     ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose     , intercalate, cabalVersion-    , withFileContents, writeFileAtomic +    , withFileContents, writeFileAtomic     , withTempFile ) import Distribution.System     ( OS(..), buildOS, buildPlatform )@@ -123,13 +125,15 @@ import qualified Distribution.Simple.UHC  as UHC  import Control.Monad-    ( when, unless, foldM, filterM )+    ( when, unless, foldM, filterM, forM ) import Data.List-    ( nub, partition, isPrefixOf, inits )+    ( nub, partition, isPrefixOf, inits, find ) import Data.Maybe-         ( isNothing, catMaybes )+    ( isNothing, catMaybes, mapMaybe ) import Data.Monoid     ( Monoid(..) )+import Data.Graph+    ( SCC(..), graphFromEdges, transposeG, vertices, stronglyConnCompR ) import System.Directory     ( doesFileExist, getModificationTime, createDirectoryIfMissing, getTemporaryDirectory ) import System.Exit@@ -264,6 +268,7 @@           -> 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)@@ -340,7 +345,9 @@          -- 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'+        let pkg_descr =+                enableCoverage (fromFlag (configLibCoverage cfg)) distPref+                $ addExtraIncludeLibDirs pkg_descr0'          when (not (null flags)) $           info verbosity $ "Flags chosen: "@@ -422,13 +429,21 @@              ++ "supported by " ++ display (compilerId comp) ++ ": "              ++ intercalate ", " (map display exts) +        -- configured known/required programs & build tools         let requiredBuildTools = concatMap buildTools (allBuildInfo pkg_descr)-        programsConfig'' <--              configureAllKnownPrograms (lessVerbose verbosity) programsConfig'++        -- add all exes built by this package ("internal exes") to the program+        -- conf; this makes the namespace of build-tools include intrapackage+        -- references to executables+        let programsConfig'' = foldr (addInternalExe buildDir') programsConfig'+                                 (executables pkg_descr)++        programsConfig''' <-+              configureAllKnownPrograms (lessVerbose verbosity) programsConfig''           >>= configureRequiredPrograms verbosity requiredBuildTools -        (pkg_descr', programsConfig''') <- configurePkgconfigPackages verbosity-                                            pkg_descr programsConfig''+        (pkg_descr', programsConfig'''') <-+          configurePkgconfigPackages verbosity pkg_descr programsConfig'''          split_objs <-            if not (fromFlag $ configSplitObjs cfg)@@ -446,7 +461,7 @@         -- needs. Note, this only works because we cannot yet depend on two         -- versions of the same package.         let configLib lib = configComponent (libBuildInfo lib)-            configExe exe = (exeName exe, configComponent(buildInfo exe))+            configExe exe = (exeName exe, configComponent (buildInfo exe))             configTest test = (testName test,                     configComponent(testBuildInfo test))             configComponent bi = ComponentLocalBuildInfo {@@ -465,27 +480,60 @@               where                 names = [ name | Dependency name _ <- targetBuildDepends bi ] -        let lbi = LocalBuildInfo{+        -- Obtains the intrapackage dependencies for the given component+        let ipDeps component =+                 mapMaybe exeDepToComp (buildTools bi)+              ++ mapMaybe libDepToComp (targetBuildDepends bi)+              where+                bi = foldComponent libBuildInfo buildInfo testBuildInfo component+                exeDepToComp (Dependency (PackageName name) _) =+                  CExe `fmap` find ((==) name . exeName)+                                (executables pkg_descr')+                libDepToComp (Dependency pn _)+                  | pn `elem` map packageName internalPkgDeps =+                    CLib `fmap` library pkg_descr'+                libDepToComp _ = Nothing++        let sccs = (stronglyConnCompR . map lkup . vertices . transposeG) g+              where (g, lkup, _) = graphFromEdges+                                 $ allComponentsBy pkg_descr'+                                 $ \c -> (c, key c, map key (ipDeps c))+                    key          = foldComponent (const "library") exeName testName++        -- check for cycles in the dependency graph+        buildOrder <- forM sccs $ \scc -> case scc of+          AcyclicSCC (c,_,_) -> return (foldComponent (const CLibName)+                                                      (CExeName . exeName)+                                                      (CTestName . testName)+                                                      c)+          CyclicSCC vs ->+            die $ "Found cycle in intrapackage dependency graph:\n  "+                ++ intercalate " depends on "+                     (map (\(_,k,_) -> "'" ++ k ++ "'") (vs ++ [head vs]))++        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,-                    buildDir            = distPref </> "build",+                    buildDir            = buildDir',                     scratchDir          = fromFlagOrDefault                                             (distPref </> "scratch")                                             (configScratchDir cfg),                     libraryConfig       = configLib `fmap` library pkg_descr',                     executableConfigs   = configExe `fmap` executables pkg_descr',-                    testSuiteConfigs    = configTest `fmap` filter testEnabled (testSuites pkg_descr'),+                    testSuiteConfigs    = configTest `fmap` testSuites pkg_descr',+                    compBuildOrder      = buildOrder,                     installedPkgs       = packageDependsIndex,                     pkgDescrFile        = Nothing,                     localPkgDescr       = pkg_descr',-                    withPrograms        = programsConfig''',+                    withPrograms        = programsConfig'''',                     withVanillaLib      = fromFlag $ configVanillaLib cfg,                     withProfLib         = fromFlag $ configProfLib cfg,                     withSharedLib       = fromFlag $ configSharedLib cfg,+                    withDynExe          = fromFlag $ configDynExe cfg,                     withProfExe         = fromFlag $ configProfExe cfg,                     withOptimization    = fromFlag $ configOptimization cfg,                     withGHCiLib         = fromFlag $ configGHCiLib cfg,@@ -522,11 +570,20 @@         dirinfo "Documentation"    (docdir dirs)     (docdir relative)          sequence_ [ reportProgram verbosity prog configuredProg-                  | (prog, configuredProg) <- knownPrograms programsConfig''' ]+                  | (prog, configuredProg) <- knownPrograms programsConfig'''' ]          return lbi      where+      addInternalExe bd exe =+        let nm = exeName exe in+        addKnownProgram Program {+          programName         = nm,+          programFindLocation = \_ -> return $ Just $ bd </> nm </> nm,+          programFindVersion  = \_ _ -> return Nothing,+          programPostConf     = \_ _ -> return []+        }+       addExtraIncludeLibDirs pkg_descr =           let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg                                , PD.includeDirs = configExtraIncludeDirs cfg}

@@ -115,7 +115,7 @@ import Distribution.Verbosity import Distribution.Text          ( display, simpleParse )-import Language.Haskell.Extension (Language(..), Extension(..))+import Language.Haskell.Extension (Language(..), Extension(..), KnownExtension(..))  import Control.Monad            ( unless, when, liftM ) import Data.Char                ( isSpace )@@ -358,49 +358,73 @@ getExtensions verbosity ghcProg   | ghcVersion >= Version [6,7] [] = do -    exts <- rawSystemStdout verbosity (programPath ghcProg)+    str <- rawSystemStdout verbosity (programPath ghcProg)               ["--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 $ extensionHacks-          ++ [ (ext, "-X" ++ display ext)-             | Just ext <- map readExtension (lines exts) ]+    let extStrs = if ghcVersion >= Version [7] []+                  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 ghcVersion >= Version [6,8]  [] &&+                         ghcVersion <  Version [6,10] []+                      then -- ghc-6.8 introduced RecordPuns however it+                           -- should have been NamedFieldPuns. We now+                           -- encourage packages to use NamedFieldPuns+                           -- so for compatability 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 ghcVersion <  Version [7,1] []+                      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    where     Just ghcVersion = programVersion ghcProg -    -- ghc-6.8 intorduced RecordPuns however it should have been-    -- NamedFieldPuns. We now encourage packages to use NamedFieldPuns so for-    -- compatability we fake support for it in ghc-6.8 by making it an alias-    -- for the old RecordPuns extension.-    extensionHacks = [ (NamedFieldPuns, "-XRecordPuns")-                     | ghcVersion >= Version [6,8]  []-                    && ghcVersion <  Version [6,10] [] ]- -- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags oldLanguageExtensions :: [(Extension, Flag)] oldLanguageExtensions =-    [(OverlappingInstances       , "-fallow-overlapping-instances")-    ,(TypeSynonymInstances       , "-fglasgow-exts")-    ,(TemplateHaskell            , "-fth")-    ,(ForeignFunctionInterface   , "-fffi")-    ,(NoMonomorphismRestriction  , "-fno-monomorphism-restriction")-    ,(NoMonoPatBinds             , "-fno-mono-pat-binds")-    ,(UndecidableInstances       , "-fallow-undecidable-instances")-    ,(IncoherentInstances        , "-fallow-incoherent-instances")-    ,(Arrows                     , "-farrows")-    ,(Generics                   , "-fgenerics")-    ,(NoImplicitPrelude          , "-fno-implicit-prelude")-    ,(ImplicitParams             , "-fimplicit-params")-    ,(CPP                        , "-cpp")-    ,(BangPatterns               , "-fbang-patterns")+    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)@@ -410,7 +434,7 @@     ,(RankNTypes                 , fglasgowExts)     ,(PolymorphicComponents      , fglasgowExts)     ,(ExistentialQuantification  , fglasgowExts)-    ,(ScopedTypeVariables        , "-fscoped-type-variables")+    ,(ScopedTypeVariables        , fFlag "scoped-type-variables")     ,(FlexibleContexts           , fglasgowExts)     ,(FlexibleInstances          , fglasgowExts)     ,(EmptyDataDecls             , fglasgowExts)@@ -424,13 +448,11 @@     ,(TypeOperators              , fglasgowExts)     ,(GADTs                      , fglasgowExts)     ,(RelaxedPolyRec             , fglasgowExts)-    ,(ExtendedDefaultRules       , "-fextended-default-rules")+    ,(ExtendedDefaultRules       , fFlag "extended-default-rules")     ,(UnboxedTuples              , fglasgowExts)     ,(DeriveDataTypeable         , fglasgowExts)     ,(ConstrainedClassMethods    , fglasgowExts)     ]-    where-      fglasgowExts = "-fglasgow-exts"  getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration                      -> IO PackageIndex@@ -568,7 +590,7 @@              comp (withProfLib lbi) (libBuildInfo lib)    let libTargetDir = pref-      forceVanillaLib = TemplateHaskell `elem` allExtensions libBi+      forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi       -- TH always needs vanilla libs, even when building for profiling    createDirectoryIfMissingVerbose verbosity True libTargetDir@@ -600,6 +622,7 @@      info verbosity "Building C Sources..."      sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref                                                         filename verbosity+                                                        False                                                         (withProfLib lbi)                    createDirectoryIfMissingVerbose verbosity True odir                    runGhcProg args@@ -734,7 +757,7 @@    info verbosity "Building C Sources."    sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi                                           exeDir filename verbosity-                                          (withProfExe lbi)+                                          (withDynExe lbi) (withProfExe lbi)                  createDirectoryIfMissingVerbose verbosity True odir                  runGhcProg args              | filename <- cSources exeBi]@@ -742,7 +765,7 @@   srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath    let cObjs = map (`replaceExtension` objExtension) (cSources exeBi)-  let binArgs linkExe profExe =+  let binArgs linkExe dynExe profExe =              "--make"           :  (if linkExe                  then ["-o", targetDir </> exeNameReal]@@ -754,6 +777,9 @@           ++ ["-l"++lib | lib <- extraLibs exeBi]           ++ ["-L"++libDir | libDir <- extraLibDirs exeBi]           ++ concat [["-framework", f] | f <- PD.frameworks exeBi]+          ++ if dynExe+                then ["-dynamic"]+                else []           ++ if profExe                 then ["-prof",                       "-hisuf", "p_hi",@@ -766,10 +792,10 @@   -- 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 && TemplateHaskell `elem` allExtensions exeBi)-     (runGhcProg (binArgs False False))+  when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi)+     (runGhcProg (binArgs False (withDynExe lbi) False)) -  runGhcProg (binArgs True (withProfExe lbi))+  runGhcProg (binArgs True (withDynExe lbi) (withProfExe lbi))  -- | Filter the "-threaded" flag when profiling as it does not --   work with ghc-6.8 and older.@@ -899,9 +925,9 @@     ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)  constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo-                   -> FilePath -> FilePath -> Verbosity -> Bool+                   -> FilePath -> FilePath -> Verbosity -> Bool -> Bool                    ->(FilePath,[String])-constructCcCmdLine lbi bi clbi pref filename verbosity profiling+constructCcCmdLine lbi bi clbi pref filename verbosity dynamic profiling   =  let odir | compilerVersion (compiler lbi) >= Version [6,4,1] []  = pref               | otherwise = pref </> takeDirectory filename                         -- ghc 6.4.1 fixed a bug in -odir handling@@ -915,6 +941,7 @@          -- option to ghc here when compiling C code, so that the PROFILING          -- macro gets defined. The macro is used in ghc's Rts.h in the          -- definitions of closure layouts (Closures.h).+         ++ ["-dynamic" | dynamic]          ++ ["-prof" | profiling])  ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo

@@ -104,11 +104,13 @@     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 convertModuleName (exposedModules ipi),     Current.hiddenModules      = map convertModuleName (hiddenModules ipi),+    Current.trusted            = False,     Current.importDirs         = importDirs ipi,     Current.libraryDirs        = libraryDirs ipi,     Current.hsLibraries        = hsLibraries ipi,

@@ -139,11 +139,13 @@     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 convertModuleName (exposedModules ipi),     Current.hiddenModules      = map convertModuleName (hiddenModules ipi),+    Current.trusted            = False,     Current.importDirs         = importDirs ipi,     Current.libraryDirs        = libraryDirs ipi,     Current.hsLibraries        = hsLibraries ipi,

@@ -56,8 +56,7 @@ import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD          ( PackageDescription(..), BuildInfo(..), allExtensions-         , Library(..), hasLibs, withLib-         , Executable(..), withExe )+         , Library(..), hasLibs, Executable(..) ) import Distribution.Simple.Compiler          ( Compiler(..), compilerVersion ) import Distribution.Simple.GHC ( ghcLibDir )@@ -65,8 +64,9 @@          ( ConfiguredProgram(..), requireProgramVersion          , rawSystemProgram, rawSystemProgramStdout          , hscolourProgram, haddockProgram )-import Distribution.Simple.PreProcess (ppCpp', ppUnlit,-                                PPSuffixHandler, runSimplePreProcessor)+import Distribution.Simple.PreProcess (ppCpp', ppUnlit+                                      , PPSuffixHandler, runSimplePreProcessor+                                      , preprocessComponent) import Distribution.Simple.Setup         ( defaultHscolourFlags, Flag(..), flagToMaybe, fromFlag         , HaddockFlags(..), HscolourFlags(..) )@@ -78,7 +78,7 @@                                         initialPathTemplateEnv) import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(..), externalPackageDeps-         , ComponentLocalBuildInfo(..), withLibLBI, withExeLBI )+         , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI ) import Distribution.Simple.BuildPaths ( haddockName,                                         hscolourPref, autogenModulesDir,                                         )@@ -112,7 +112,7 @@ import System.IO (hClose, hPutStrLn) import Distribution.Version --- Types +-- Types  -- | record that represents the arguments to the haddock executable, a product monoid. data HaddockArgs = HaddockArgs {@@ -122,7 +122,7 @@  argIgnoreExports :: Any,                         -- ^ ingore export lists in modules?  argLinkSource :: Flag (Template,Template),       -- ^ (template for modules, template for symbols)  argCssFile :: Flag FilePath,                     -- ^ optinal custom css file.- argVerbose :: Any,                            + argVerbose :: Any,  argOutput :: Flag [Output],                      -- ^ Html or Hoogle doc or both?                                   required.  argInterfaces :: [(FilePath, Maybe FilePath)],   -- ^ [(interface file, path to the html docs for links)]  argOutputDir :: Directory,                       -- ^ where to generate the documentation.@@ -164,7 +164,7 @@     -- various sanity checks     let isVersion2   = version >= Version [2,0] [] -    when ( flag haddockHoogle +    when ( flag haddockHoogle            && version > Version [2] []            && version < Version [2,2] []) $          die "haddock 2.0 and 2.1 do not support the --hoogle flag."@@ -188,35 +188,37 @@      -- the tools match the requests, we can proceed -    initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity suffixes-    -    when (flag haddockHscolour) $ hscolour' pkg_descr lbi $ +    initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity++    when (flag haddockHscolour) $ hscolour' pkg_descr lbi suffixes $          defaultHscolourFlags `mappend` haddockToHscolour flags-    -    args <- fmap mconcat . sequence $ -            [ getInterfaces verbosity lbi (flagToMaybe (haddockHtmlLocation flags)) -            , getGhcLibDir  verbosity lbi isVersion2 ] -           ++ map return ++    args <- fmap mconcat . sequence $+            [ getInterfaces verbosity lbi (flagToMaybe (haddockHtmlLocation flags))+            , getGhcLibDir  verbosity lbi isVersion2 ]+           ++ map return             [ fromFlags flags             , fromPackageDescription pkg_descr ] -    withLibLBI pkg_descr lbi $ \lib clbi ->-        withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do-          let bi = libBuildInfo lib-          libArgs  <- fromLibrary tmp lbi lib clbi-          libArgs' <- prepareSources verbosity tmp-                        lbi isVersion2 bi (args `mappend` libArgs)-          runHaddock verbosity confHaddock libArgs'--    when (flag haddockExecutables) $-      withExeLBI pkg_descr lbi $ \exe clbi ->-        withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do-          let bi = buildInfo exe-          exeArgs  <- fromExecutable tmp lbi exe clbi-          exeArgs' <- prepareSources verbosity tmp-                        lbi isVersion2 bi (args `mappend` exeArgs)-          runHaddock verbosity confHaddock exeArgs'-+    let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes+    withComponentsLBI pkg_descr lbi $ \comp clbi -> do+      pre comp+      case comp of+        CLib lib -> do+          withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do+            let bi = libBuildInfo lib+            libArgs  <- fromLibrary tmp lbi lib clbi+            libArgs' <- prepareSources verbosity tmp+                          lbi isVersion2 bi (args `mappend` libArgs)+            runHaddock verbosity confHaddock libArgs'+        CExe exe -> when (flag haddockExecutables) $ do+          withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do+            let bi = buildInfo exe+            exeArgs  <- fromExecutable tmp lbi exe clbi+            exeArgs' <- prepareSources verbosity tmp+                          lbi isVersion2 bi (args `mappend` exeArgs)+            runHaddock verbosity confHaddock exeArgs'+        _ -> return ()   where     verbosity = flag haddockVerbosity     flag f    = fromFlag $ f flags@@ -233,13 +235,13 @@ prepareSources verbosity tmp lbi isVersion2 bi args@HaddockArgs{argTargets=files} =               mapM (mockPP tmp) files >>= \targets -> return args {argTargets=targets}           where-            mockPP pref file = do +            mockPP pref file = do                  let (filePref, fileName) = splitFileName file                      targetDir  = pref </> filePref                      targetFile = targetDir </> fileName                      (targetFileNoext, targetFileExt) = splitExtension $ targetFile                      hsFile = targetFileNoext <.> "hs"-                 +                  assert (targetFileExt `elem` [".lhs",".hs"]) $ return ()                   createDirectoryIfMissing True targetDir@@ -256,7 +258,7 @@                      removeFile targetFile                   return hsFile-            needsCpp = CPP `elem` allExtensions bi+            needsCpp = EnableExtension CPP `elem` allExtensions bi             defines | isVersion2 = []                     | otherwise  = ["-D__HADDOCK__"] @@ -264,7 +266,7 @@ -- constributions to HaddockArgs  fromFlags :: HaddockFlags -> HaddockArgs-fromFlags flags = +fromFlags flags =     mempty {       argHideModules = (maybe mempty (All . not) $ flagToMaybe (haddockInternal flags), mempty),       argLinkSource = if fromFlag (haddockHscolour flags)@@ -282,15 +284,15 @@     }  fromPackageDescription :: PackageDescription -> HaddockArgs-fromPackageDescription pkg_descr = +fromPackageDescription pkg_descr =       mempty {-                argInterfaceFile = Flag $ haddockName pkg_descr,     -                argPackageName = Flag $ packageId $ pkg_descr,              +                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 +      where         desc = PD.description pkg_descr         showPkg = display (packageId pkg_descr)         subtitle | null (synopsis pkg_descr) = ""@@ -310,11 +312,11 @@                                        -- haddock to write them elsewhere.                                        ++ [ "-odir", tmp, "-hidir", tmp                                           , "-stubdir", tmp ],-                            argTargets = inFiles +                            argTargets = inFiles                           }-    where +    where       bi = libBuildInfo lib-      + fromExecutable :: FilePath                -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo                -> IO HaddockArgs@@ -330,9 +332,9 @@                                           , "-stubdir", tmp ],                             argOutputDir = Dir (exeName exe),                             argTitle = Flag (exeName exe),-                            argTargets = inFiles +                            argTargets = inFiles                           }-    where +    where       bi = buildInfo exe  getInterfaces :: Verbosity@@ -343,17 +345,17 @@     let htmlTemplate = fmap toPathTemplate $ location     (packageFlags, warnings) <- haddockPackageFlags lbi htmlTemplate     maybe (return ()) (warn verbosity) warnings-    return $ mempty { +    return $ mempty {                  argInterfaces = packageFlags                } -getGhcLibDir :: Verbosity -> LocalBuildInfo +getGhcLibDir :: Verbosity -> LocalBuildInfo              -> Bool -- ^ are we using haddock-2.x ?              -> IO HaddockArgs-getGhcLibDir verbosity lbi isVersion2 -    | isVersion2 = -        do l <- ghcLibDir verbosity lbi -           return $ mempty { argGhcLibDir = Flag l } +getGhcLibDir verbosity lbi isVersion2+    | isVersion2 =+        do l <- ghcLibDir verbosity lbi+           return $ mempty { argGhcLibDir = Flag l }     | otherwise  =         return mempty @@ -364,7 +366,7 @@ runHaddock verbosity confHaddock args = do   let haddockVersion = fromMaybe (error "unable to determine haddock version")                        (programVersion confHaddock)-  renderArgs verbosity haddockVersion args $ \(flags,result)-> do +  renderArgs verbosity haddockVersion args $ \(flags,result)-> do        rawSystemProgram verbosity confHaddock flags @@ -376,15 +378,15 @@               -> HaddockArgs               -> (([[Char]], FilePath) -> IO a)               -> IO a-renderArgs verbosity version args k = do +renderArgs verbosity version args k = do   createDirectoryIfMissingVerbose verbosity True outputDir   withTempFile outputDir "haddock-prolog.txt" $ \prologFileName h -> do           do              hPutStrLn h $ fromFlag $ argPrologue args-             hClose h +             hClose h              let pflag = (:[]).("--prologue="++) $ prologFileName              k $ (pflag ++ renderPureArgs version args, result)-    where +    where       isVersion2 = version >= Version [2,0] []       outputDir = (unDir $ argOutputDir args)       result = intercalate ", "@@ -398,15 +400,15 @@                      | otherwise = display pkgid               pkgid = arg argPackageName       arg f = fromFlag $ f args-      + renderPureArgs :: Version -> HaddockArgs -> [[Char]]-renderPureArgs version args = concat -    [ +renderPureArgs version args = concat+    [      (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)-     . fromFlag . argInterfaceFile $ args,     -     (\pkgName -> if isVersion2 +     . fromFlag . argInterfaceFile $ args,+     (\pkgName -> if isVersion2                   then ["--optghc=-package-name", "--optghc=" ++ pkgName]-                  else ["--package=" ++ pkgName]) . display . fromFlag . argPackageName $ args,              +                  else ["--package=" ++ pkgName]) . display . fromFlag . argPackageName $ args,      (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) . argHideModules $ args,      bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args,      maybe [] (\(m,e) -> ["--source-module=" ++ m@@ -416,14 +418,14 @@      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)) +     (:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args))               . fromFlag . argTitle $ args,      bool id (const []) isVersion2 . map ("--optghc=" ++) . argGhcFlags $ args,      maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and Nothing?      argTargets $ args-    ] -    where -      renderInterfaces = map (\(i,mh) -> "--read-interface=" ++ maybe "" (++",") mh ++ i)    +    ]+    where+      renderInterfaces = map (\(i,mh) -> "--read-interface=" ++ maybe "" (++",") mh ++ i)       bool a b c = if c then a else b       isVersion2 = version >= Version [2,0] []       isVersion2_5 = version >= Version [2,5] []@@ -481,17 +483,18 @@ 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 suffixes -  hscolour' pkg_descr lbi flags+  initialBuildSteps distPref pkg_descr lbi verbosity+  hscolour' pkg_descr lbi suffixes flags  where    verbosity  = fromFlag (hscolourVerbosity flags)    distPref = fromFlag $ hscolourDistPref flags  hscolour' :: PackageDescription-             -> LocalBuildInfo-             -> HscolourFlags-             -> IO ()-hscolour' pkg_descr lbi flags = do+          -> LocalBuildInfo+          -> [PPSuffixHandler]+          -> HscolourFlags+          -> IO ()+hscolour' pkg_descr lbi suffixes flags = do     let distPref = fromFlag $ hscolourDistPref flags     (hscolourProg, _, _) <-       requireProgramVersion@@ -501,25 +504,26 @@     setupMessage verbosity "Running hscolour for" (packageId pkg_descr)     createDirectoryIfMissingVerbose verbosity True $ hscolourPref distPref pkg_descr -    withLib pkg_descr $ \lib -> do--        let outputDir = hscolourPref distPref pkg_descr </> "src"-        runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib--    when (fromFlag (hscolourExecutables flags)) $-         withExe pkg_descr $ \exe -> do-           let outputDir = hscolourPref distPref pkg_descr </> exeName exe </> "src"-           runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe--  where +    let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes+    withComponentsLBI pkg_descr lbi $ \comp _ -> do+      pre comp+      case comp of+        CLib lib -> do+          let outputDir = hscolourPref distPref pkg_descr </> "src"+          runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib+        CExe exe | fromFlag (hscolourExecutables flags) -> do+          let outputDir = hscolourPref distPref pkg_descr </> exeName exe </> "src"+          runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe+        _ -> return ()+  where     stylesheet = flagToMaybe (hscolourCSS flags)-    +     verbosity  = fromFlag (hscolourVerbosity flags) -    runHsColour prog outputDir moduleFiles = do             +    runHsColour prog outputDir moduleFiles = do          createDirectoryIfMissingVerbose verbosity True outputDir -         case stylesheet of -- copy the CSS file +         case stylesheet of -- copy the CSS file            Nothing | programVersion prog >= Just (Version [1,9] []) ->                        rawSystemProgram verbosity prog                           ["-print-css", "-o" ++ outputDir </> "hscolour.css"]@@ -533,12 +537,12 @@           outFile m = outputDir </> intercalate "-" (ModuleName.components m) <.> "html"  haddockToHscolour :: HaddockFlags -> HscolourFlags-haddockToHscolour flags = -    HscolourFlags { +haddockToHscolour flags =+    HscolourFlags {       hscolourCSS         = haddockHscolourCss flags,       hscolourExecutables = haddockExecutables flags,       hscolourVerbosity   = haddockVerbosity   flags,-      hscolourDistPref    = haddockDistPref    flags +      hscolourDistPref    = haddockDistPref    flags     } ---------------------------------------------------------------------------------------------- -- TODO these should be moved elsewhere.@@ -567,9 +571,9 @@ getSourceFiles :: [FilePath]                   -> [ModuleName.ModuleName]                   -> IO [(ModuleName.ModuleName, FilePath)]-getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $ +getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $     findFileWithExtension ["hs", "lhs"] dirs (ModuleName.toFilePath m)-      >>= maybe (notFound m) (return . normalise) +      >>= maybe (notFound m) (return . normalise)   where     notFound module_ = die $ "can't find source for module " ++ display module_ @@ -585,8 +589,8 @@ -- boilerplate monoid instance. instance Monoid HaddockArgs where     mempty = HaddockArgs {-                argInterfaceFile = mempty,     -                argPackageName = mempty,              +                argInterfaceFile = mempty,+                argPackageName = mempty,                 argHideModules = mempty,                 argIgnoreExports = mempty,                 argLinkSource = mempty,@@ -602,8 +606,8 @@                 argTargets = mempty              }     mappend a b = HaddockArgs {-                argInterfaceFile = mult argInterfaceFile,     -                argPackageName = mult argPackageName,              +                argInterfaceFile = mult argInterfaceFile,+                argPackageName = mult argPackageName,                 argHideModules = mult argHideModules,                 argIgnoreExports = mult argIgnoreExports,                 argLinkSource = mult argLinkSource,

@@ -0,0 +1,185 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Hpc+-- Copyright   :  Thomas Tuegel 2011+--+-- 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.++{- 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. -}++module Distribution.Simple.Hpc+    ( hpcDir+    , enableCoverage+    , tixDir+    , tixFilePath+    , doHpcMarkup+    , findTixFiles+    ) where++import Control.Exception ( bracket )+import Control.Monad ( unless, when )+import Distribution.Compiler ( CompilerFlavor(..) )+import Distribution.ModuleName ( main )+import Distribution.PackageDescription+    ( BuildInfo(..)+    , Library(..)+    , PackageDescription(..)+    , TestSuite(..)+    , testModules+    )+import Distribution.Simple.Utils ( die, notice )+import Distribution.Text+import Distribution.Verbosity ( Verbosity() )+import System.Directory ( doesFileExist, getDirectoryContents, removeFile )+import System.Exit ( ExitCode(..) )+import System.FilePath+import System.IO ( hClose, IOMode(..), openFile, openTempFile )+import System.Process ( runProcess, waitForProcess )++-- -------------------------------------------------------------------------+-- Haskell Program Coverage++-- | Conditionally enable Haskell Program Coverage by adding the necessary+-- GHC options to a PackageDescription.+--+-- TODO: do this differently in the build stage by constructing local build+-- info, not by modifying the original PackageDescription.+--+enableCoverage :: Bool                  -- ^ Enable coverage?+               -> String                -- ^ \"dist/\" prefix+               -> PackageDescription+               -> PackageDescription+enableCoverage False _ x = x+enableCoverage True distPref p =+    p { library = fmap enableLibCoverage (library p)+      , testSuites = map enableTestCoverage (testSuites p)+      }+  where+    enableBICoverage name oldBI =+        let oldOptions = options oldBI+            oldGHCOpts = lookup GHC oldOptions+            newGHCOpts = case oldGHCOpts of+                             Just xs -> (GHC, hpcOpts ++ xs)+                             _ -> (GHC, hpcOpts)+            newOptions = (:) newGHCOpts $ filter ((== GHC) . fst) oldOptions+            hpcOpts = ["-fhpc", "-hpcdir", hpcDir distPref name]+        in oldBI { options = newOptions }+    enableLibCoverage l =+        l { libBuildInfo = enableBICoverage (display $ package p)+                                            (libBuildInfo l)+          }+    enableTestCoverage t =+        t { testBuildInfo = enableBICoverage (testName t) (testBuildInfo t) }++hpcDir :: FilePath  -- ^ \"dist/\" prefix+       -> FilePath  -- ^ Component subdirectory name+       -> FilePath  -- ^ Directory containing component's HPC .mix files+hpcDir distPref name = distPref </> "hpc" </> name++tixDir :: FilePath  -- ^ \"dist/\" prefix+       -> TestSuite -- ^ Test suite+       -> FilePath  -- ^ Directory containing test suite's .tix files+tixDir distPref suite = distPref </> "test" </> testName suite++-- | Path to the .tix file containing a test suite's sum statistics.+tixFilePath :: FilePath     -- ^ \"dist/\" prefix+            -> TestSuite    -- ^ Test suite+            -> FilePath     -- Path to test suite's .tix file+tixFilePath distPref suite = tixDir distPref suite </> testName suite <.> "tix"++-- | Returns a list of all the .tix files in a test suite's .tix file+-- directory. Returned paths are the complete relative path to each file.+findTixFiles :: FilePath        -- ^ \"dist/\" prefix+             -> TestSuite       -- ^ Test suite+             -> IO [FilePath]   -- ^ All .tix files belonging to test suite+findTixFiles distPref suite = do+    files <- getDirectoryContents $ tixDir distPref suite+    let tixFiles = flip filter files $ \x -> takeExtension x == ".tix"+    return $ map (tixDir distPref suite </>) tixFiles++-- | Generate the HTML markup for a test suite.+doHpcMarkup :: Verbosity+            -> FilePath     -- ^ \"dist/\" prefix+            -> String       -- ^ Library name+            -> TestSuite+            -> IO ()+doHpcMarkup verbosity distPref libName suite = do+    tixFiles <- findTixFiles distPref suite+    when (not $ null tixFiles) $ do+        let hpcOptions = map (\x -> "--exclude=" ++ display x) excluded+            unionOptions = [ "sum"+                           , "--union"+                           , "--output=" ++ tixFilePath distPref suite+                           ]+                           ++ hpcOptions ++ tixFiles+            markupOptions = [ "markup"+                            , tixFilePath distPref suite+                            , "--hpcdir=" ++ hpcDir distPref libName+                            , "--destdir=" ++ tixDir distPref suite+                            ]+                            ++ hpcOptions+            excluded = testModules suite ++ [ main ]+            --TODO: use standard process utilities from D.S.Utils+            runHpc opts h = runProcess "hpc" opts Nothing Nothing Nothing+                                       (Just h) (Just h)+        bracket (openHpcTemp $ tixDir distPref suite) deleteIfExists+            $ \hpcOut -> do+            hUnion <- openFile hpcOut AppendMode+            procUnion <- runHpc unionOptions hUnion+            exitUnion <- waitForProcess procUnion+            success <- case exitUnion of+                ExitSuccess -> do+                    hMarkup <- openFile hpcOut AppendMode+                    procMarkup <- runHpc markupOptions hMarkup+                    exitMarkup <- waitForProcess procMarkup+                    case exitMarkup of+                        ExitSuccess -> return True+                        _ -> return False+                _ -> return False+            unless success $ do+                errs <- readFile hpcOut+                die $ "HPC failed:\n" ++ errs+            when success $ notice verbosity+                $ "Test coverage report written to "+                  ++ tixDir distPref suite </> "hpc_index"+                  <.> "html"+            return ()+  where openHpcTemp dir = do+            (f, h) <- openTempFile dir $ "cabal-test-hpc-" <.> "log"+            hClose h >> return f+        deleteIfExists path = do+            exists <- doesFileExist path+            when exists $ removeFile path

@@ -89,13 +89,14 @@ import Distribution.Simple.Setup          ( CopyDest(..) ) import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, installOrdinaryFiles+         ( createDirectoryIfMissingVerbose+         , installOrdinaryFiles, setFileExecutable          , withUTF8FileContents, writeFileAtomic, writeUTF8File          , copyFileVerbose, findFile, findFileWithExtension, findModuleFiles          , rawSystemStdInOut          , die, info, notice ) import Language.Haskell.Extension-         ( Language(Haskell98), Extension(..) )+         ( Language(Haskell98), Extension(..), KnownExtension(..) ) import System.FilePath          ( (</>), takeExtension, (<.>),                                   searchPathSeparator, normalise, takeDirectory ) import Distribution.System@@ -116,8 +117,6 @@          , removeDirectoryRecursive, getHomeDirectory ) import System.Exit          ( ExitCode(ExitSuccess) )-import Distribution.Compat.CopyFile-         ( setFileExecutable ) import Distribution.Compat.Exception  -- -----------------------------------------------------------------------------@@ -176,26 +175,31 @@ -- | The flags for the supported extensions hugsLanguageExtensions :: [(Extension, Flag)] hugsLanguageExtensions =-    [(OverlappingInstances       , "+o")-    ,(IncoherentInstances        , "+oO")-    ,(HereDocuments              , "+H")-    ,(TypeSynonymInstances       , "-98")-    ,(RecursiveDo                , "-98")-    ,(ParallelListComp           , "-98")-    ,(MultiParamTypeClasses      , "-98")-    ,(FunctionalDependencies     , "-98")-    ,(Rank2Types                 , "-98")-    ,(PolymorphicComponents      , "-98")-    ,(ExistentialQuantification  , "-98")-    ,(ScopedTypeVariables        , "-98")-    ,(ImplicitParams             , "-98")-    ,(ExtensibleRecords          , "-98")-    ,(RestrictedTypeSynonyms     , "-98")-    ,(FlexibleContexts           , "-98")-    ,(FlexibleInstances          , "-98")-    ,(ForeignFunctionInterface   , "")-    ,(EmptyDataDecls             , "")-    ,(CPP                        , "")+    let doFlag (f, (enable, disable)) = [(EnableExtension  f, enable),+                                         (DisableExtension f, disable)]+        alwaysOn = ("", ""{- wrong -})+        ext98 = ("-98", ""{- wrong -})+    in concatMap doFlag+    [(OverlappingInstances       , ("+o",  "-o"))+    ,(IncoherentInstances        , ("+oO", "-O"))+    ,(HereDocuments              , ("+H",  "-H"))+    ,(TypeSynonymInstances       , ext98)+    ,(RecursiveDo                , ext98)+    ,(ParallelListComp           , ext98)+    ,(MultiParamTypeClasses      , ext98)+    ,(FunctionalDependencies     , ext98)+    ,(Rank2Types                 , ext98)+    ,(PolymorphicComponents      , ext98)+    ,(ExistentialQuantification  , ext98)+    ,(ScopedTypeVariables        , ext98)+    ,(ImplicitParams             , ext98)+    ,(ExtensibleRecords          , ext98)+    ,(RestrictedTypeSynonyms     , ext98)+    ,(FlexibleContexts           , ext98)+    ,(FlexibleInstances          , ext98)+    ,(ForeignFunctionInterface   , alwaysOn)+    ,(EmptyDataDecls             , alwaysOn)+    ,(CPP                        , alwaysOn)     ]  getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration@@ -337,7 +341,7 @@     srcMainFile <- findFile (hsSourceDirs bi) mainPath     let exeDir = destDir </> exeName exe     let destMainFile = exeDir </> hugsMainFilename exe-    copyModule verbosity (CPP `elem` allExtensions bi) bi lbi srcMainFile destMainFile+    copyModule verbosity (EnableExtension CPP `elem` allExtensions bi) bi lbi srcMainFile destMainFile     let destPathsFile = exeDir </> paths_modulename     copyFileVerbose verbosity (autogenModulesDir lbi </> paths_modulename)                               destPathsFile@@ -359,7 +363,7 @@ --TODO: should not be using mLibSrcDirs at all compileBuildInfo verbosity destDir mLibSrcDirs mods bi lbi = do     -- Pass 1: copy or cpp files from build directory to scratch directory-    let useCpp = CPP `elem` allExtensions bi+    let useCpp = EnableExtension CPP `elem` allExtensions bi     let srcDir = buildDir lbi         srcDirs = nub $ srcDir : hsSourceDirs bi ++ mLibSrcDirs     info verbosity $ "Source directories: " ++ show srcDirs@@ -387,7 +391,7 @@     createDirectoryIfMissingVerbose verbosity True (takeDirectory destFile)     (exts, opts, _) <- getOptionsFromSource srcFile     let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ]-    if cppAll || CPP `elem` exts || "-cpp" `elem` ghcOpts then do+    if cppAll || EnableExtension CPP `elem` exts || "-cpp" `elem` ghcOpts then do         runSimplePreProcessor (ppCpp bi lbi) srcFile destFile verbosity         return ()       else@@ -578,6 +582,8 @@         let hugsOptions = hcOptions Hugs (buildInfo exe)                        ++ languageToFlags (compiler lbi) (defaultLanguage bi)                        ++ extensionsToFlags (compiler lbi) (allExtensions bi)+            --TODO: also need to consider options, extensions etc of deps+            --      see ticket #43         let baseExeFile = progprefix ++ (exeName exe) ++ progsuffix         let exeFile = case buildOS of                           Windows -> binDir </> baseExeFile <.> ".bat"

@@ -560,13 +560,13 @@ # if __HUGS__   return Nothing # else-  allocaBytes long_path_size $ \pPath -> do+  allocaArray long_path_size $ \pPath -> do      r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath      if (r /= 0)         then return Nothing-        else do s <- peekCString pPath; return (Just s)+        else do s <- peekCWString pPath; return (Just s)   where-    long_path_size      = 1024+    long_path_size      = 1024 -- MAX_PATH is 260, this should be plenty # endif  csidl_PROGRAM_FILES :: CInt@@ -574,12 +574,12 @@ -- csidl_PROGRAM_FILES_COMMON :: CInt -- csidl_PROGRAM_FILES_COMMON = 0x002b -foreign import stdcall unsafe "shlobj.h SHGetFolderPathA"+foreign import stdcall unsafe "shlobj.h SHGetFolderPathW"             c_SHGetFolderPath :: Ptr ()                               -> CInt                               -> Ptr ()                               -> CInt-                              -> CString+                              -> CWString                               -> IO CInt #endif 

@@ -64,7 +64,7 @@          ( CompilerFlavor(..), CompilerId(..), Compiler(..)          , PackageDBStack, Flag, languageToFlags, extensionsToFlags ) import Language.Haskell.Extension-         ( Language(Haskell98), Extension(..))+         ( Language(Haskell98), Extension(..), KnownExtension(..)) import Distribution.Simple.Program          ( ConfiguredProgram(..), jhcProgram, ProgramConfiguration          , userMaybeSpecifyPath, requireProgramVersion, lookupProgram@@ -115,10 +115,14 @@ -- | The flags for the supported extensions jhcLanguageExtensions :: [(Extension, Flag)] jhcLanguageExtensions =-    [(TypeSynonymInstances       , "")-    ,(ForeignFunctionInterface   , "")-    ,(NoImplicitPrelude          , "--noprelude")-    ,(CPP                        , "-fcpp")+    [(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

@@ -110,7 +110,7 @@ import Distribution.Text          ( display, simpleParse ) import Language.Haskell.Extension-         ( Language(Haskell98), Extension(..) )+         ( Language(Haskell98), Extension(..), KnownExtension(..) )  import Control.Monad            ( unless, when ) import Data.List@@ -336,7 +336,7 @@              (compiler lbi) (withProfLib lbi) (libBuildInfo lib)    let libTargetDir = pref-      forceVanillaLib = TemplateHaskell `elem` allExtensions libBi+      forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi       -- TH always needs vanilla libs, even when building for profiling    createDirectoryIfMissingVerbose verbosity True libTargetDir@@ -544,7 +544,7 @@   -- 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 && TemplateHaskell `elem` allExtensions exeBi)+  when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi)      (runGhcProg $ lhcWrap (binArgs False False))    runGhcProg (binArgs True (withProfExe lbi))

@@ -48,10 +48,18 @@         LocalBuildInfo(..),         externalPackageDeps,         inplacePackageId,++        -- * Buildable package components+        Component(..),+        foldComponent,+        allComponentsBy,+        ComponentName(..),+        ComponentLocalBuildInfo(..),+        withComponentsLBI,         withLibLBI,         withExeLBI,         withTestLBI,-        ComponentLocalBuildInfo(..),+         -- * Installation directories         module Distribution.Simple.InstallDirs,         absoluteInstallDirs, prefixRelativeInstallDirs,@@ -65,8 +73,9 @@ import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.Program (ProgramConfiguration) import Distribution.PackageDescription-         ( PackageDescription(..), withLib, Library, withExe-         , Executable(exeName), withTest, TestSuite(..) )+         ( PackageDescription(..), withLib, Library(libBuildInfo), withExe+         , Executable(exeName, buildInfo), withTest, TestSuite(..)+         , BuildInfo(buildable) ) import Distribution.Package          ( PackageId, Package(..), InstalledPackageId(..) ) import Distribution.Simple.Compiler@@ -80,7 +89,7 @@ import Distribution.Text          ( display ) -import Data.List (nub)+import Data.List (nub, find)  -- | Data cached after configuration step.  See also -- 'Distribution.Simple.Setup.ConfigFlags'.@@ -104,6 +113,9 @@                 -- ^ Where to put the result of the Hugs build.         libraryConfig       :: Maybe ComponentLocalBuildInfo,         executableConfigs   :: [(String, ComponentLocalBuildInfo)],+        compBuildOrder :: [ComponentName],+                -- ^ All the components to build, ordered by topological sort+                -- over the intrapackage dependency graph         testSuiteConfigs    :: [(String, ComponentLocalBuildInfo)],         installedPkgs :: PackageIndex,                 -- ^ All the info about the installed packages that the@@ -118,6 +130,7 @@         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).         withGHCiLib   :: Bool,  -- ^Whether to build libs suitable for use with GHCi.@@ -127,15 +140,6 @@         progSuffix    :: PathTemplate -- ^Suffix to be appended to installed executables   } deriving (Read, Show) -data ComponentLocalBuildInfo = ComponentLocalBuildInfo {-    -- | 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)]-  }-  deriving (Read, Show)- -- | External package dependencies for the package as a whole, the union of the -- individual 'targetPackageDeps'. externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)]@@ -150,6 +154,51 @@ inplacePackageId :: PackageId -> InstalledPackageId inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace") +-- -----------------------------------------------------------------------------+-- Buildable components++data Component = CLib  Library+               | CExe  Executable+               | CTest TestSuite+               deriving (Show, Eq, Read)++data ComponentName = CLibName  -- currently only a single lib+                   | CExeName  String+                   | CTestName String+                   deriving (Show, Eq, Read)++data ComponentLocalBuildInfo = ComponentLocalBuildInfo {+    -- | 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)]+  }+  deriving (Read, Show)++foldComponent :: (Library -> a)+              -> (Executable -> a)+              -> (TestSuite -> a)+              -> Component+              -> a+foldComponent f _ _ (CLib  lib) = f lib+foldComponent _ f _ (CExe  exe) = f exe+foldComponent _ _ f (CTest tst) = f tst++-- | Obtains all components (libs, exes, or test suites), transformed by the+-- given function.  Useful for gathering dependencies with component context.+allComponentsBy :: PackageDescription+                -> (Component -> a)+                -> [a]+allComponentsBy pkg_descr f =+    [ f (CLib  lib) | Just lib <- [library pkg_descr]+                    , buildable (libBuildInfo lib) ]+ ++ [ f (CExe  exe) | exe <- executables pkg_descr+                    , buildable (buildInfo exe) ]+ ++ [ f (CTest tst) | tst <- testSuites pkg_descr+                    , buildable (testBuildInfo tst)+                    , testEnabled tst ]+ -- |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.@@ -158,8 +207,7 @@ withLibLBI pkg_descr lbi f = withLib pkg_descr $ \lib ->   case libraryConfig lbi of     Just clbi -> f lib clbi-    Nothing   -> die $ "internal error: the package contains a library "-                    ++ "but there is no corresponding configuration data"+    Nothing   -> die missingLibConf  -- | Perform the action on each buildable 'Executable' in the package -- description.  Extended version of 'withExe' that also gives corresponding@@ -169,19 +217,63 @@ withExeLBI pkg_descr lbi f = withExe pkg_descr $ \exe ->   case lookup (exeName exe) (executableConfigs lbi) of     Just clbi -> f exe clbi-    Nothing   -> die $ "internal error: the package contains an executable "-                    ++ exeName exe ++ " but there is no corresponding "-                    ++ "configuration data"+    Nothing   -> die (missingExeConf (exeName exe))  withTestLBI :: PackageDescription -> LocalBuildInfo             -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO ()-withTestLBI pkg_descr lbi f =-    let wrapper test = case lookup (testName test) (testSuiteConfigs lbi) of-            Just clbi -> f test clbi-            Nothing -> die $ "internal error: the package contains a test suite "-                            ++ testName test ++ " but there is no corresponding "-                            ++ "configuration data"-    in withTest pkg_descr wrapper+withTestLBI pkg_descr lbi f = withTest pkg_descr $ \test ->+  case lookup (testName test) (testSuiteConfigs lbi) of+    Just clbi -> f test clbi+    Nothing -> die (missingTestConf (testName test))++-- | 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'+withComponentsLBI :: PackageDescription -> LocalBuildInfo+                  -> (Component -> ComponentLocalBuildInfo -> IO ())+                  -> IO ()+withComponentsLBI pkg_descr lbi f = mapM_ compF (compBuildOrder lbi)+  where+    compF CLibName =+        case library pkg_descr of+          Nothing  -> die missinglib+          Just lib -> case libraryConfig lbi of+                        Nothing   -> die missingLibConf+                        Just clbi -> f (CLib lib) clbi+      where+        missinglib  = "internal error: component list includes a library "+                   ++ "but the package description contains no library"++    compF (CExeName name) =+        case find (\exe -> exeName exe == name) (executables pkg_descr) of+          Nothing  -> die missingexe+          Just exe -> case lookup name (executableConfigs lbi) of+                        Nothing   -> die (missingExeConf name)+                        Just clbi -> f (CExe exe) clbi+      where+        missingexe  = "internal error: component list includes an executable "+                   ++ name ++ " but the package contains no such executable."++    compF (CTestName name) =+        case find (\tst -> testName tst == name) (testSuites pkg_descr) of+          Nothing  -> die missingtest+          Just tst -> case lookup name (testSuiteConfigs lbi) of+                        Nothing   -> die (missingTestConf name)+                        Just clbi -> f (CTest tst) clbi+      where+        missingtest = "internal error: component list includes a test suite "+                   ++ name ++ " but the package contains no such test suite."++missingLibConf :: String+missingExeConf, missingTestConf :: String -> String++missingLibConf       = "internal error: the package contains a library "+                    ++ "but there is no corresponding configuration data"+missingExeConf  name = "internal error: the package contains an executable "+                    ++ name ++ " but there is no corresponding configuration data"+missingTestConf name = "internal error: the package contains a test suite "+                    ++ name ++ " but there is no corresponding configuration data"+  -- ----------------------------------------------------------------------------- -- Wrappers for a couple functions from InstallDirs

@@ -74,7 +74,7 @@ import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex) import Language.Haskell.Extension-         ( Language(Haskell98), Extension(..) )+         ( Language(Haskell98), Extension(..), KnownExtension(..) ) import Distribution.Simple.Program          ( ProgramConfiguration, userMaybeSpecifyPath, programPath          , requireProgram, requireProgramVersion, lookupProgram@@ -132,7 +132,7 @@   let comp = Compiler {         compilerId         = CompilerId NHC nhcVersion,         compilerLanguages  = nhcLanguages,-        compilerExtensions = nhcLanguageExtensions+        compilerExtensions     = nhcLanguageExtensions       }   return (comp, conf'''') @@ -142,14 +142,27 @@ -- | The flags for the supported extensions nhcLanguageExtensions :: [(Extension, Flag)] nhcLanguageExtensions =-    -- NHC doesn't enforce the monomorphism restriction at all.     -- TODO: pattern guards in 1.20-    [(NoMonomorphismRestriction, "")-    ,(ForeignFunctionInterface,  "")-    ,(ExistentialQuantification, "")-    ,(EmptyDataDecls,            "")-    ,(NamedFieldPuns,            "-puns")-    ,(CPP,                       "-cpp")+     -- NHC doesn't enforce the monomorphism restriction at all.+     -- Technically it therefore doesn't support MonomorphismRestriction,+     -- but that would mean it doesn't support Haskell98, so we pretend+     -- that it does.+    [(EnableExtension  MonomorphismRestriction,   "")+    ,(DisableExtension MonomorphismRestriction,   "")+     -- Similarly, I assume the FFI is always on+    ,(EnableExtension  ForeignFunctionInterface,  "")+    ,(DisableExtension ForeignFunctionInterface,  "")+     -- Similarly, I assume existential quantification is always on+    ,(EnableExtension  ExistentialQuantification, "")+    ,(DisableExtension ExistentialQuantification, "")+     -- Similarly, I assume empty data decls is always on+    ,(EnableExtension  EmptyDataDecls,            "")+    ,(DisableExtension EmptyDataDecls,            "")+    ,(EnableExtension  NamedFieldPuns,            "-puns")+    ,(DisableExtension NamedFieldPuns,            "-nopuns")+     -- CPP can't actually be turned off, but we pretend that it can+    ,(EnableExtension  CPP,                       "-cpp")+    ,(DisableExtension CPP,                       "")     ]  getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration

@@ -47,7 +47,7 @@ (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.PreProcess (preprocessSources, knownSuffixHandlers,+module Distribution.Simple.PreProcess (preprocessComponent, knownSuffixHandlers,                                 ppSuffixes, PPSuffixHandler, PreProcessor(..),                                 mkSimplePreProcessor, runSimplePreProcessor,                                 ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs,@@ -56,21 +56,24 @@     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(..), withExe-         , Library(..), withLib, libModules-         , TestSuite(..), withTest, testModules+         ( PackageDescription(..), BuildInfo(..)+         , Executable(..)+         , Library(..), libModules+         , TestSuite(..), testModules          , TestSuiteInterface(..) ) import qualified Distribution.InstalledPackageInfo as Installed          ( InstalledPackageInfo_(..) ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.Compiler          ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion )-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(..), Component(..) ) import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName) import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File@@ -90,7 +93,6 @@          ( Version(..), anyVersion, orLaterVersion ) import Distribution.Verbosity -import Control.Monad (when, unless) import Data.Maybe (fromMaybe) import Data.List (nub) import System.Directory (getModificationTime, doesFileExist)@@ -171,66 +173,60 @@ type PPSuffixHandler     = (String, BuildInfo -> LocalBuildInfo -> PreProcessor) --- |Apply preprocessors to the sources from 'hsSourceDirs', to obtain--- a Haskell source file for each module.-preprocessSources :: PackageDescription-                  -> LocalBuildInfo-                  -> Bool               -- ^ Build for SDist-                  -> Verbosity          -- ^ verbosity-                  -> [PPSuffixHandler]  -- ^ preprocessors to try-                  -> IO ()--preprocessSources pkg_descr lbi forSDist verbosity handlers = do-    withLib pkg_descr $ \ lib -> do-        setupMessage verbosity "Preprocessing library" (packageId pkg_descr)-        let bi = libBuildInfo lib-        let biHandlers = localHandlers bi-        sequence_ [ preprocessFile (hsSourceDirs bi ++ [autogenModulesDir lbi]) (buildDir lbi) forSDist-                                   (ModuleName.toFilePath modu) verbosity-                                   builtinSuffixes biHandlers-                  | modu <- libModules lib ]-    unless (null (executables pkg_descr)) $-        setupMessage verbosity "Preprocessing executables for" (packageId pkg_descr)-    withExe pkg_descr $ \ theExe -> do-        let bi = buildInfo theExe-        let biHandlers = localHandlers bi-        let exeDir = buildDir lbi </> exeName theExe </> exeName theExe ++ "-tmp"-        sequence_ [ preprocessFile (hsSourceDirs bi ++ [autogenModulesDir lbi]) exeDir forSDist-                                   (ModuleName.toFilePath modu) verbosity-                                   builtinSuffixes biHandlers-                  | modu <- otherModules bi]-        preprocessFile (hsSourceDirs bi) exeDir forSDist-                         (dropExtensions (modulePath theExe))-                         verbosity builtinSuffixes biHandlers-    unless (null (testSuites pkg_descr)) $-        setupMessage verbosity "Preprocessing test suites for" (packageId pkg_descr)-    withTest pkg_descr $ \test -> 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-  where hc = compilerFlavor (compiler lbi)-        builtinSuffixes-          | hc == NHC = ["hs", "lhs", "gc"]-          | otherwise = ["hs", "lhs"]-        localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers]-        preProcessTest test exePath testDir = do-            let bi = testBuildInfo test-                biHandlers = localHandlers bi-                sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ]-            sequence_ [ preprocessFile sourceDirs (buildDir lbi) forSDist-                    (ModuleName.toFilePath modu) verbosity builtinSuffixes-                    biHandlers-                    | modu <- testModules test ]-            preprocessFile (testDir : (hsSourceDirs bi)) testDir forSDist-                (dropExtensions $ exePath) verbosity-                builtinSuffixes biHandlers+-- | 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+  where+    builtinSuffixes+      | NHC == compilerFlavor (compiler lbi) = ["hs", "lhs", "gc"]+      | otherwise                            = ["hs", "lhs"]+    localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers]+    pre dirs dir lhndlrs fp =+      preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs+    preProcessTest test exePath testDir = do+        let bi = testBuildInfo test+            biHandlers = localHandlers bi+            sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ]+        sequence_ [ preprocessFile sourceDirs (buildDir lbi) isSrcDist+                (ModuleName.toFilePath modu) verbosity builtinSuffixes+                biHandlers+                | modu <- testModules test ]+        preprocessFile (testDir : (hsSourceDirs bi)) testDir 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@@ -454,7 +450,9 @@        ++ [ "--cflag=" ++ opt           | pkg <- pkgs           , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ]-                ++ [         opt | opt <- Installed.ccOptions   pkg ] ]+                ++ [         opt | opt <- Installed.ccOptions   pkg ]+                ++ [ "-I" ++ autogenModulesDir lbi,+                     "-include", autogenModulesDir lbi </> cppHeaderName ] ]        ++ [ "--lflag=" ++ opt           | pkg <- pkgs           , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs    pkg ]

@@ -30,9 +30,9 @@          ( PackageId, InstalledPackageId(..) ) import Distribution.InstalledPackageInfo          ( InstalledPackageInfo, InstalledPackageInfo_(..)-         , showInstalledPackageInfo, parseInstalledPackageInfo )+         , showInstalledPackageInfo+         , emptyInstalledPackageInfo, fieldsInstalledPackageInfo ) import Distribution.ParseUtils-         ( ParseResult(..) ) import Distribution.Simple.Compiler          ( PackageDB(..), PackageDBStack ) import Distribution.Simple.Program.Types@@ -53,9 +53,15 @@  import Data.Char          ( isSpace )-import Control.Monad-         ( liftM )+import Data.Maybe+         ( fromMaybe )+import Data.List+         ( stripPrefix )+import System.FilePath as FilePath+         ( (</>), splitPath, splitDirectories, joinPath, isPathSeparator )+import qualified System.FilePath.Posix as FilePath.Posix + -- | Call @hc-pkg@ to register a package. -- -- > hc-pkg register {filename | -} [--user | --global | --package-conf]@@ -128,12 +134,28 @@    where     parsePackages str =-      let parse  = liftM setInstalledPackageId . parseInstalledPackageInfo-          parsed = map parse (splitPkgs str)+      let parsed = map parseInstalledPackageInfo' (splitPkgs str)        in case [ msg | ParseFailed msg <- parsed ] of-            []   -> Left [ pkg | ParseOk _ pkg <- parsed ]+            []   -> Left [   setInstalledPackageId+                           . maybe id mungePackagePaths pkgroot+                           $ pkg+                         | ParseOk _ (pkgroot, pkg) <- parsed ]             msgs -> Right msgs +    parseInstalledPackageInfo' =+        parseFieldsFlat fields (Nothing, emptyInstalledPackageInfo)+      where+        fields =     liftFieldFst pkgrootField+               : map liftFieldSnd fieldsInstalledPackageInfo++        pkgrootField =+          simpleField "pkgroot"+            showFilePath    parseFilePathQ+            (fromMaybe "")  (\x _ -> Just x)++        liftFieldFst = liftField fst (\x (_x,y) -> (x,y))+        liftFieldSnd = liftField snd (\y (x,_y) -> (x,y))+     --TODO: this could be a lot faster. We're doing normaliseLineEndings twice     -- and converting back and forth with lines/unlines.     splitPkgs :: String -> [String]@@ -149,7 +171,44 @@                            _: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@@ -230,13 +289,15 @@  dumpInvocation :: ConfiguredProgram                -> Verbosity -> PackageDB -> ProgramInvocation-dumpInvocation hcPkg verbosity packagedb =+dumpInvocation hcPkg _verbosity packagedb =     (programInvocation hcPkg args) {       progInvokeOutputEncoding = IOEncodingUTF8     }   where     args = ["dump", packageDbOpts packagedb]-        ++ verbosityOpts hcPkg verbosity+        ++ verbosityOpts hcPkg silent+           -- We use verbosity level 'silent' because it is important that we+           -- do not contaminate the output with info/debug messages.   packageDbStackOpts :: PackageDBStack -> [String]

@@ -17,6 +17,7 @@ module Distribution.Simple.Program.Types (     -- * Program and functions for constructing them     Program(..),+    internalProgram,     simpleProgram,      -- * Configured program and related functions@@ -26,8 +27,11 @@     ProgramLocation(..),   ) where +import Data.List (nub) +import System.FilePath ((</>))+ import Distribution.Simple.Utils-         ( findProgramLocation )+         ( findProgramLocation, findFirstFile ) import Distribution.Version          ( Version ) import Distribution.Verbosity@@ -104,3 +108,15 @@     programFindVersion  = \_ _ -> return Nothing,     programPostConf     = \_ _ -> return []   }++-- | Make a simple 'internal' program; that is, one that was built as an+-- executable already and is expected to be found in the build directory+internalProgram :: [FilePath] -> String -> Program+internalProgram paths name = Program {+  programName         = name,+  programFindLocation = \_v ->+    findFirstFile id [ path </> name | path <- nub paths ],+    programFindVersion  = \_ _ -> return Nothing,+    programPostConf     = \_ _ -> return []+  }+

@@ -93,7 +93,7 @@          , showInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Simple.Utils-         ( writeUTF8File, writeFileAtomic+         ( writeUTF8File, writeFileAtomic, setFileExecutable          , die, notice, setupMessage ) import Distribution.System          ( OS(..), buildOS )@@ -102,13 +102,12 @@ import Distribution.Version ( Version(..) ) import Distribution.Verbosity as Verbosity          ( Verbosity, normal )-import Distribution.Compat.CopyFile-         ( setFileExecutable )+import Distribution.Compat.Exception+         ( tryIO )  import System.FilePath ((</>), (<.>), isAbsolute) import System.Directory          ( getCurrentDirectory, removeDirectoryRecursive )-import System.IO.Error (try)  import Data.Maybe          ( isJust, fromMaybe, maybeToList )@@ -270,11 +269,13 @@     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     = exposedModules lib,     IPI.hiddenModules      = otherModules bi,+    IPI.trusted            = False,     IPI.importDirs         = [ libdir installDirs | hasModules ],     IPI.libraryDirs        = if hasLibrary                                then libdir installDirs : extraLibDirs bi@@ -375,10 +376,10 @@                   (invocationAsSystemScript buildOS invocation)             else runProgramInvocation verbosity invocation     Hugs -> do-        _ <- try $ removeDirectoryRecursive (libdir installDirs)+        _ <- tryIO $ removeDirectoryRecursive (libdir installDirs)         return ()     NHC -> do-        _ <- try $ removeDirectoryRecursive (libdir installDirs)+        _ <- tryIO $ removeDirectoryRecursive (libdir installDirs)         return ()     _ ->         die ("only unregistering with GHC and Hugs is implemented")

@@ -270,6 +270,7 @@     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.     configConfigureArgs :: [String],      -- ^Extra arguments to @configure@     configOptimization  :: Flag OptimisationLevel,  -- ^Enable optimization.@@ -290,7 +291,8 @@     configConstraints :: [Dependency], -- ^Additional constraints for                                        -- dependencies     configConfigurationsFlags :: FlagAssignment,-    configTests :: Flag Bool     -- ^Enable test suite compilation+    configTests :: Flag Bool,     -- ^Enable test suite compilation+    configLibCoverage :: Flag Bool    -- ^ Enable test suite program coverage   }   deriving (Read,Show) @@ -301,6 +303,7 @@     configVanillaLib   = Flag True,     configProfLib      = Flag False,     configSharedLib    = Flag False,+    configDynExe       = Flag False,     configProfExe      = Flag False,     configOptimization = Flag NormalOptimisation,     configProgPrefix   = Flag (toPathTemplate ""),@@ -311,7 +314,8 @@     configGHCiLib      = Flag True,     configSplitObjs    = Flag False, -- takes longer, so turn off by default     configStripExes    = Flag True,-    configTests  = Flag False+    configTests  = Flag False,+    configLibCoverage = Flag False   }  configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags@@ -388,10 +392,16 @@          configSharedLib (\v flags -> flags { configSharedLib = v })          (boolOpt [] []) +      ,option "" ["executable-dynamic"]+         "Executable dynamic linking"+         configDynExe (\v flags -> flags { configDynExe = v })+         (boolOpt [] [])+       ,option "" ["executable-profiling"]          "Executable profiling"          configProfExe (\v flags -> flags { configProfExe = v })          (boolOpt [] [])+       ,multiOption "optimization"          configOptimization (\v flags -> flags { configOptimization = v })          [optArg' "n" (Flag . flagToOptimisationLevel)@@ -464,6 +474,10 @@          "dependency checking and compilation for test suites listed in the package description file."          configTests (\v flags -> flags { configTests = v })          (boolOpt [] [])+      ,option "" ["library-coverage"]+         "build library and test suites with Haskell Program Coverage enabled. (GHC only)"+         configLibCoverage (\v flags -> flags { configLibCoverage = v })+         (boolOpt [] [])       ]   where     readFlagList :: String -> FlagAssignment@@ -553,6 +567,7 @@     configVanillaLib    = mempty,     configProfLib       = mempty,     configSharedLib     = mempty,+    configDynExe        = mempty,     configProfExe       = mempty,     configConfigureArgs = mempty,     configOptimization  = mempty,@@ -571,7 +586,8 @@     configConstraints   = mempty,     configExtraIncludeDirs    = mempty,     configConfigurationsFlags = mempty,-    configTests   = mempty+    configTests   = mempty,+    configLibCoverage = mempty   }   mappend a b =  ConfigFlags {     configPrograms      = configPrograms b,@@ -583,6 +599,7 @@     configVanillaLib    = combine configVanillaLib,     configProfLib       = combine configProfLib,     configSharedLib     = combine configSharedLib,+    configDynExe        = combine configDynExe,     configProfExe       = combine configProfExe,     configConfigureArgs = combine configConfigureArgs,     configOptimization  = combine configOptimization,@@ -601,7 +618,8 @@     configConstraints   = combine configConstraints,     configExtraIncludeDirs    = combine configExtraIncludeDirs,     configConfigurationsFlags = combine configConfigurationsFlags,-    configTests = combine configTests+    configTests = combine configTests,+    configLibCoverage = combine configLibCoverage   }     where combine field = field a `mappend` field b @@ -745,6 +763,7 @@ -- | Flags to @sdist@: (snapshot, verbosity) data SDistFlags = SDistFlags {     sDistSnapshot  :: Flag Bool,+    sDistDirectory :: Flag FilePath,     sDistDistPref  :: Flag FilePath,     sDistVerbosity :: Flag Verbosity   }@@ -753,6 +772,7 @@ defaultSDistFlags :: SDistFlags defaultSDistFlags = SDistFlags {     sDistSnapshot  = Flag False,+    sDistDirectory = mempty,     sDistDistPref  = Flag defaultDistPref,     sDistVerbosity = Flag normal   }@@ -773,6 +793,11 @@          "Produce a snapshot source distribution"          sDistSnapshot (\v flags -> flags { sDistSnapshot = v })          trueArg++      ,option "" ["output-directory"]+         "Generate a source distribution in the given directory"+         sDistDirectory (\v flags -> flags { sDistDirectory = v })+         (reqArgFlag "DIR")       ]  emptySDistFlags :: SDistFlags@@ -781,11 +806,13 @@ instance Monoid SDistFlags where   mempty = SDistFlags {     sDistSnapshot  = mempty,+    sDistDirectory = mempty,     sDistDistPref  = mempty,     sDistVerbosity = mempty   }   mappend a b = SDistFlags {     sDistSnapshot  = combine sDistSnapshot,+    sDistDirectory = combine sDistDirectory,     sDistDistPref  = combine sDistDistPref,     sDistVerbosity = combine sDistVerbosity   }@@ -1234,6 +1261,7 @@     testHumanLog :: Flag PathTemplate,     testMachineLog :: Flag PathTemplate,     testShowDetails :: Flag TestShowDetails,+    testKeepTix :: Flag Bool,     --TODO: eliminate the test list and pass it directly as positional args to the testHook     testList :: Flag [String],     -- TODO: think about if/how options are passed to test exes@@ -1247,6 +1275,7 @@     testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log",     testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log",     testShowDetails = toFlag Failures,+    testKeepTix = toFlag False,     testList = Flag [],     testOptions = Flag []   }@@ -1287,6 +1316,10 @@                                    (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, "@@ -1314,6 +1347,7 @@     testHumanLog = mempty,     testMachineLog = mempty,     testShowDetails = mempty,+    testKeepTix = mempty,     testList = mempty,     testOptions = mempty   }@@ -1323,6 +1357,7 @@     testHumanLog = combine testHumanLog,     testMachineLog = combine testMachineLog,     testShowDetails = combine testShowDetails,+    testKeepTix = combine testKeepTix,     testList = combine testList,     testOptions = combine testOptions   }

@@ -79,13 +79,13 @@          ( Version(versionBranch) ) import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File-         , installOrdinaryFile, installOrdinaryFiles+         , installOrdinaryFile, installOrdinaryFiles, setFileExecutable          , findFile, findFileWithExtension, matchFileGlob          , withTempDirectory, defaultPackageDesc          , die, warn, notice, setupMessage )-import Distribution.Simple.Setup (SDistFlags(..), fromFlag)-import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessSources)-import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )+import Distribution.Simple.Setup (SDistFlags(..), fromFlag, flagToMaybe)+import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessComponent)+import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), withComponentsLBI ) import Distribution.Simple.BuildPaths ( autogenModuleName ) import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram,                               rawSystemProgram, tarProgram )@@ -99,7 +99,6 @@ import System.Time (getClockTime, toCalendarTime, CalendarTime(..)) import System.Directory          ( doesFileExist, Permissions(executable), getPermissions )-import Distribution.Compat.CopyFile (setFileExecutable) import Distribution.Verbosity (Verbosity) import System.FilePath          ( (</>), (<.>), takeDirectory, dropExtension, isAbsolute )@@ -112,9 +111,6 @@       -> [PPSuffixHandler]  -- ^ extra preprocessors (includes suffixes)       -> IO () sdist pkg mb_lbi flags mkTmpDir pps = do-  let distPref = fromFlag $ sDistDistPref flags-      targetPref = distPref-      tmpTargetDir = mkTmpDir distPref    -- do some QA   printPackageProblems verbosity pkg@@ -122,26 +118,39 @@   when (isNothing mb_lbi) $     warn verbosity "Cannot run preprocessors. Run 'configure' command first." -  createDirectoryIfMissingVerbose verbosity True tmpTargetDir-  withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do+  date <- toCalendarTime =<< getClockTime+  let pkg' | snapshot  = snapshotPackage date pkg+           | otherwise = pkg -    date <- toCalendarTime =<< getClockTime-    let pkg' | snapshot  = snapshotPackage date pkg-             | otherwise = pkg-    setupMessage verbosity "Building source dist for" (packageId pkg')+  case flagToMaybe (sDistDirectory flags) of+    Just targetDir -> do+      generateSourceDir targetDir pkg'+      notice verbosity $ "Source directory created: " ++ targetDir -    -- FIXME This looks a bit suspicious. Should createArchive be passed-    -- the result of prepareSnapshotTree/prepareTree?-    _ <- if snapshot-      then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps-      else prepareTree         verbosity pkg' mb_lbi distPref tmpDir pps-    targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref-    notice verbosity $ "Source tarball created: " ++ targzFile+    Nothing -> do+      createDirectoryIfMissingVerbose verbosity True tmpTargetDir+      withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do+        let targetDir = tmpDir </> tarBallName pkg'+        generateSourceDir targetDir pkg'+        targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref+        notice verbosity $ "Source tarball created: " ++ targzFile    where+    generateSourceDir targetDir pkg' = do++      setupMessage verbosity "Building source dist for" (packageId pkg')+      prepareTree verbosity pkg' mb_lbi distPref targetDir pps+      when snapshot $+        overwriteSnapshotPackageDesc verbosity pkg' targetDir+     verbosity = fromFlag (sDistVerbosity flags)     snapshot  = fromFlag (sDistSnapshot flags) +    distPref     = fromFlag $ sDistDistPref flags+    targetPref   = distPref+    tmpTargetDir = mkTmpDir distPref++ -- |Prepare a directory tree of source files. prepareTree :: Verbosity          -- ^verbosity             -> PackageDescription -- ^info from the cabal file@@ -149,14 +158,14 @@             -> FilePath           -- ^dist dir             -> FilePath           -- ^source tree to populate             -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)-            -> IO FilePath        -- ^the name of the dir created and populated--prepareTree verbosity pkg_descr0 mb_lbi distPref tmpDir pps = do-  let targetDir = tmpDir </> tarBallName pkg_descr+            -> IO ()+prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do   createDirectoryIfMissingVerbose verbosity True targetDir+   -- maybe move the library files into place   withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->     prepareDir verbosity pkg_descr distPref targetDir pps modules libBi+   -- move the executables into place   withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do     prepareDir verbosity pkg_descr distPref targetDir pps [] exeBi@@ -166,6 +175,7 @@         Nothing -> findFile (hsSourceDirs exeBi) mainPath         Just pp -> return pp     copyFileTo verbosity targetDir srcMainFile+   -- move the test suites into place   withTest $ \t -> do     let bi = testBuildInfo t@@ -184,6 +194,7 @@         TestSuiteLibV09 _ m -> do             prep [m] bi         TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " ++ show tp+   flip mapM_ (dataFiles pkg_descr) $ \ filename -> do     files <- matchFileGlob (dataDir pkg_descr </> filename)     let dir = takeDirectory (dataDir pkg_descr </> filename)@@ -214,9 +225,10 @@   -- 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)-      -> preprocessSources pkg_descr (lbi { buildDir = targetDir </> buildDir lbi })-                             True verbosity pps+    Just lbi | not (null pps) -> do+      let lbi' = lbi{ buildDir = targetDir </> buildDir lbi }   +      withComponentsLBI pkg_descr lbi' $ \c _ ->+        preprocessComponent pkg_descr c lbi' True verbosity pps     _ -> return ()    -- setup isn't listed in the description file.@@ -230,7 +242,6 @@   -- the description file itself   descFile <- defaultPackageDesc verbosity   installOrdinaryFile verbosity descFile (targetDir </> descFile)-  return targetDir    where     pkg_descr = mapAllBuildInfo filterAutogenModule pkg_descr0@@ -261,21 +272,24 @@                     -> FilePath           -- ^dist dir                     -> FilePath           -- ^source tree to populate                     -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)-                    -> IO FilePath        -- ^the resulting temp dir-prepareSnapshotTree verbosity pkg mb_lbi distPref tmpDir pps = do-  targetDir <- prepareTree verbosity pkg mb_lbi distPref tmpDir pps-  overwriteSnapshotPackageDesc (packageVersion pkg) targetDir-  return targetDir+                    -> IO ()+prepareSnapshotTree verbosity pkg mb_lbi distPref targetDir pps = do+  prepareTree verbosity pkg mb_lbi distPref targetDir pps+  overwriteSnapshotPackageDesc verbosity pkg targetDir -  where-    overwriteSnapshotPackageDesc version 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 version) . lines+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

@@ -57,11 +57,13 @@ import Distribution.Package     ( PackageId ) import qualified Distribution.PackageDescription as PD-         ( PackageDescription(..), TestSuite(..)+         ( PackageDescription(..), BuildInfo(buildable)+         , TestSuite(..)          , TestSuiteInterface(..), testType, hasTests ) import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar ) import Distribution.Simple.BuildPaths ( exeExtension ) import Distribution.Simple.Compiler ( Compiler(..), CompilerId )+import Distribution.Simple.Hpc ( doHpcMarkup, findTixFiles, tixDir ) import Distribution.Simple.InstallDirs     ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)     , substPathTemplate , toPathTemplate, PathTemplate )@@ -173,11 +175,20 @@     existingEnv <- getEnvironment     let dataDirPath = pwd </> PD.dataDir pkg_descr         shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath)+                        : ("HPCTIXDIR", pwd </> tixDir distPref suite)                         : existingEnv      bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog ->         bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do +            -- Create directory for HPC files.+            createDirectoryIfMissing True $ tixDir distPref suite++            -- Remove old .tix files if appropriate.+            tixFiles <- findTixFiles distPref suite+            unless (fromFlag $ testKeepTix flags)+                $ mapM_ deleteIfExists tixFiles+             -- Write summary notices indicating start of test suite             notice verbosity $ summarizeSuiteStart $ PD.testName suite             appendFile tempLog $ summarizeSuiteStart $ PD.testName suite@@ -221,6 +232,8 @@             -- Write summary notice to terminal indicating end of test suite             notice verbosity $ summarizeSuiteFinish suiteLog' +            doHpcMarkup verbosity distPref (display $ PD.package pkg_descr) suite+             return suiteLog'     where         deleteIfExists file = do@@ -245,7 +258,9 @@         testLogDir = distPref </> "test"         testNames = fromFlag $ testList flags         pkgTests = PD.testSuites pkg_descr-        enabledTests = filter PD.testEnabled pkgTests+        enabledTests = [ t | t <- pkgTests+                           , PD.testEnabled t+                           , PD.buildable (PD.testBuildInfo t) ]          doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog         doTest (suite, mLog) = do

@@ -95,19 +95,23 @@ -- | The flags for the supported extensions. uhcLanguageExtensions :: [(Extension, C.Flag)] uhcLanguageExtensions =-    [(CPP, "--cpp"),-     (PolymorphicComponents, ""),-     (ExistentialQuantification, ""),-     (ForeignFunctionInterface, ""),-     (UndecidableInstances, ""),-     (MultiParamTypeClasses, ""),-     (Rank2Types, ""),-     (PatternSignatures, ""),-     (EmptyDataDecls, ""),-     (NoImplicitPrelude, "--no-prelude"),-     (TypeOperators, ""),-     (OverlappingInstances, ""),-     (FlexibleInstances, "")]+    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 PackageIndex

@@ -79,11 +79,16 @@         installOrdinaryFiles,         installDirectoryContents, +        -- * File permissions+        setFileOrdinary,+        setFileExecutable,+         -- * file names         currentDir,          -- * finding files         findFile,+        findFirstFile,         findFileWithExtension,         findFileWithExtension',         findModuleFile,@@ -160,7 +165,7 @@     ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode     , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) import System.IO.Error as IO.Error-    ( try, isDoesNotExistError, isAlreadyExistsError+    ( isDoesNotExistError, isAlreadyExistsError     , ioeSetFileName, ioeGetFileName, ioeGetErrorString ) #if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)) import System.IO.Error@@ -192,11 +197,11 @@  import Distribution.Compat.CopyFile          ( copyFile, copyOrdinaryFile, copyExecutableFile-         , setDirOrdinary )+         , setFileOrdinary, setFileExecutable, setDirOrdinary ) import Distribution.Compat.TempFile          ( openTempFile, openNewBinaryFile, createTempDirectory ) import Distribution.Compat.Exception-         ( IOException, throwIOIO, catchIO, catchExit, onException )+         ( IOException, throwIOIO, tryIO, catchIO, catchExit, onException ) import Distribution.Verbosity  #ifdef VERSION_base@@ -233,7 +238,7 @@ die msg = ioError (userError msg)  topHandler :: IO a -> IO a-topHandler prog = catch prog handle+topHandler prog = catchIO prog handle   where     handle ioe = do       hFlush stdout@@ -721,7 +726,7 @@      createDir :: FilePath -> (IOException -> IO ()) -> IO ()     createDir dir notExistHandler = do-      r <- try $ createDirectoryVerbose verbosity dir+      r <- tryIO $ createDirectoryVerbose verbosity dir       case (r :: Either IOException ()) of         Right ()                   -> return ()         Left  e@@ -737,7 +742,7 @@               isDir <- doesDirectoryExist dir               if isDir then return ()                        else throwIOIO e-              ) `catch` ((\_ -> return ()) :: IOException -> IO ())+              ) `catchIO` ((\_ -> return ()) :: IOException -> IO ())           | otherwise              -> throwIOIO e  createDirectoryVerbose :: Verbosity -> FilePath -> IO ()@@ -925,7 +930,7 @@ -- rewriteFile :: FilePath -> String -> IO () rewriteFile path newContent =-  flip catch mightNotExist $ do+  flip catchIO mightNotExist $ do     existingContent <- readFile path     _ <- evaluate (length existingContent)     unless (existingContent == newContent) $

@@ -58,16 +58,23 @@ -- * Operating System -- ------------------------------------------------------------ -data OS = Linux | Windows | OSX-        | FreeBSD | OpenBSD | NetBSD-        | Solaris | AIX | HPUX | IRIX+data OS = Linux | Windows | OSX        -- teir 1 desktop OSs+        | FreeBSD | OpenBSD | NetBSD   -- other free unix OSs+        | Solaris | AIX | HPUX | IRIX  -- ageing Unix OSs+        | HaLVM                        -- bare metal / VMs / hypervisors         | OtherOS String   deriving (Eq, Ord, Show, Read) +--TODO: decide how to handle Android and iOS.+-- They are like Linux and OSX but with some differences.+-- Should they be separate from linux/osx, or a subtype?+-- e.g. should we have os(linux) && os(android) true simultaneously?+ knownOSs :: [OS] knownOSs = [Linux, Windows, OSX            ,FreeBSD, OpenBSD, NetBSD-           ,Solaris, AIX, HPUX, IRIX]+           ,Solaris, AIX, HPUX, IRIX+           ,HaLVM]  osAliases :: ClassificationStrictness -> OS -> [String] osAliases Permissive Windows = ["mingw32", "cygwin32"]

@@ -52,13 +52,13 @@                           Parse.string "false") >> return False ]  instance Text Version where-  disp (Version branch _tags) -- Do not display the tags+  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)+      return (Version branch tags)  --TODO: should we ignore the tags?     where       digits = do         first <- Parse.satisfy Char.isDigit

@@ -76,7 +76,7 @@    -- ** 'VersionIntervals' abstract type   -- | The 'VersionIntervals' type and the accompanying functions are exposed-  -- primarily for completeness and testing purposes. In practice +  -- 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.   --@@ -680,7 +680,7 @@            (\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))-           id+           (\(r, p)   -> (Disp.parens r, p))      where dispWild (Version b _) =                Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))

@@ -43,6 +43,7 @@         knownLanguages,          Extension(..),+        KnownExtension(..),         knownExtensions,         deprecatedExtensions   ) where@@ -99,13 +100,11 @@ -- * Extension -- ------------------------------------------------------------ --- Note: if you add a new '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, Hugs, NHC) ----- * also to the 'knownExtensions' list below.- -- | This represents language extensions beyond a base 'Language' definition -- (such as 'Haskell98') that are supported by some implementations, usually -- in some special mode.@@ -115,7 +114,20 @@ -- documented in section 7.2.1 of the GHC User's Guide.  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 (Show, Read, Eq)++data KnownExtension =+   -- | [GHC &#xa7; 7.6.3.4] Allow overlapping class instances,   -- provided there is a unique most specific instance for each use.     OverlappingInstances@@ -149,8 +161,8 @@   -- | [GHC &#xa7; 7.6.1.1] Allow multiple parameters in a type class.   | MultiParamTypeClasses -  -- | [GHC &#xa7; 7.17] Disable the dreaded monomorphism restriction.-  | NoMonomorphismRestriction+  -- | [GHC &#xa7; 7.17] Enable the dreaded monomorphism restriction.+  | MonomorphismRestriction    -- | [GHC &#xa7; 7.6.2] Allow a specification attached to a   -- multi-parameter type class which indicates that some parameters@@ -230,11 +242,11 @@   -- defined in terms of the algebraic structure of a type.   | Generics -  -- | [GHC &#xa7; 7.3.11] Disable the implicit importing of the module-  -- @Prelude@.  When desugaring certain built-in syntax into ordinary-  -- identifiers, use whatever is in scope rather than the @Prelude@-  -- version.-  | NoImplicitPrelude+  -- | [GHC &#xa7; 7.3.11] Enable the implicit importing of the module+  -- @Prelude@.  When disabled, when desugaring certain built-in syntax+  -- into ordinary identifiers, use whatever is in scope rather than the+  -- @Prelude@ -- version.+  | ImplicitPrelude    -- | [GHC &#xa7; 7.3.15] Enable syntax for implicitly binding local names   -- corresponding to the field names of a record.  Puns bind specific@@ -310,13 +322,15 @@    -- | [GHC &#xa7; 7.4.6] Enable generalized algebraic data types, in   -- which type variables may be instantiated on a per-constructor-  -- basis.  Enables \"GADT syntax\" which can be used to declare-  -- GADTs as well as ordinary algebraic types.+  -- basis. Implies GADTSyntax.   | GADTs -  -- | [GHC &#xa7; 7.17.2] Allow pattern bindings to be polymorphic.-  | NoMonoPatBinds+  -- | Enable GADT syntax for declaring ordinary algebraic datatypes.+  | GADTSyntax +  -- | [GHC &#xa7; 7.17.2] Make pattern bindings monomorphic.+  | MonoPatBinds+   -- | [GHC &#xa7; 7.8.8] Relax the requirements on mutually-recursive   -- polymorphic functions.   | RelaxedPolyRec@@ -368,8 +382,8 @@   | 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 +  -- 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@@ -419,110 +433,65 @@   -- | Enable @deriving@ for the @Data.Foldable.Foldable@ class.   | DeriveFoldable -  -- | An unknown extension, identified by the name of its @LANGUAGE@-  -- pragma.-  | UnknownExtension String-  deriving (Show, Read, Eq)+  -- | Enable non-decreasing indentation for 'do' blocks.+  | NondecreasingIndentation +  deriving (Show, Read, Eq, Enum, Bounded)++{-# 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 =-  [ (RecordPuns, Just NamedFieldPuns)-  , (PatternSignatures, Just ScopedTypeVariables)-  ]--knownExtensions :: [Extension]-knownExtensions =-  [ OverlappingInstances-  , UndecidableInstances-  , IncoherentInstances-  , DoRec-  , RecursiveDo-  , ParallelListComp-  , MultiParamTypeClasses-  , NoMonomorphismRestriction-  , FunctionalDependencies-  , Rank2Types-  , RankNTypes-  , PolymorphicComponents-  , ExistentialQuantification-  , ScopedTypeVariables-  , ImplicitParams-  , FlexibleContexts-  , FlexibleInstances-  , EmptyDataDecls-  , CPP--  , KindSignatures-  , BangPatterns-  , TypeSynonymInstances-  , TemplateHaskell-  , ForeignFunctionInterface-  , Arrows-  , Generics-  , NoImplicitPrelude-  , NamedFieldPuns-  , PatternGuards-  , GeneralizedNewtypeDeriving--  , ExtensibleRecords-  , RestrictedTypeSynonyms-  , HereDocuments-  , MagicHash-  , TypeFamilies-  , StandaloneDeriving--  , UnicodeSyntax-  , PatternSignatures-  , UnliftedFFITypes-  , LiberalTypeSynonyms-  , TypeOperators---PArr -- not ready yet, and will probably be renamed to ParallelArrays-  , RecordWildCards-  , RecordPuns-  , DisambiguateRecordFields-  , OverloadedStrings-  , GADTs-  , NoMonoPatBinds-  , RelaxedPolyRec-  , ExtendedDefaultRules-  , UnboxedTuples-  , DeriveDataTypeable-  , ConstrainedClassMethods-  , PackageImports-  , ImpredicativeTypes-  , NewQualifiedOperators-  , PostfixOperators-  , QuasiQuotes-  , TransformListComp-  , ViewPatterns-  , XmlSyntax-  , RegularPatterns--  , TupleSections-  , GHCForeignImportPrim-  , NPlusKPatterns-  , DoAndIfThenElse-  , RebindableSyntax-  , ExplicitForAll-  , DatatypeContexts-  , MonoLocalBinds-  , DeriveFunctor-  , DeriveTraversable-  , DeriveFoldable+  [ (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 recomend 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 other                    = Disp.text (show 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) --- | 'read' for 'Extension's is really really slow so for the Text instance+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@@ -531,17 +500,17 @@ -- 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. ---classifyExtension :: String -> Extension-classifyExtension string@(c:_)-  | inRange (bounds extensionTable) c-  = case lookup string (extensionTable ! c) of-      Just extension    -> extension-      Nothing           -> UnknownExtension string-classifyExtension string = UnknownExtension string+classifyKnownExtension :: String -> Maybe KnownExtension+classifyKnownExtension "" = Nothing+classifyKnownExtension string@(c : _)+  | inRange (bounds knownExtensionTable) c+  = lookup string (knownExtensionTable ! c)+  | otherwise = Nothing -extensionTable :: Array Char [(String, Extension)]-extensionTable =+knownExtensionTable :: Array Char [(String, KnownExtension)]+knownExtensionTable =   accumArray (flip (:)) [] ('A', 'Z')     [ (head str, (str, extension))-    | extension <- knownExtensions+    | extension <- [toEnum 0 ..]     , let str = show extension ]+

@@ -0,0 +1,15 @@+module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import Data.List+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "GlobalBuildDepsNotAdditive1") []+    result <- cabal_build spec+    assertEqual "cabal build should fail - see test-log.txt" False (successful result)+    assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $+        "Failed to load interface for `Prelude'" `isInfixOf` outputText result

@@ -0,0 +1,15 @@+module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import Data.List+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "GlobalBuildDepsNotAdditive2") []+    result <- cabal_build spec+    assertEqual "cabal build should fail - see test-log.txt" False (successful result)+    assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $+        "Failed to load interface for `Prelude'" `isInfixOf` outputText result

@@ -0,0 +1,20 @@+module PackageTests.BuildDeps.InternalLibrary0.Check where++import Test.HUnit+import PackageTests.PackageTester+import Control.Monad+import System.FilePath+import Data.Version+import Data.List (isInfixOf, intercalate)+++suite :: Version -> Test+suite cabalVersion = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary0") []+    result <- cabal_build spec+    assertEqual "cabal build should fail" False (successful result)+    when (cabalVersion >= Version [1, 7] []) $ do+        -- In 1.7 it should tell you how to enable the desired behaviour.+        assertEqual "error should say 'library which is defined within the same package.'" True $+            "library which is defined within the same package." `isInfixOf` (intercalate " " $ lines $ outputText result)+

@@ -0,0 +1,12 @@+module PackageTests.BuildDeps.InternalLibrary1.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary1") []+    result <- cabal_build spec+    assertEqual "cabal build should succeed - see test-log.txt" True (successful result)

@@ -0,0 +1,24 @@+module PackageTests.BuildDeps.InternalLibrary2.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import qualified Data.ByteString.Char8 as C+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary2") []+    let specTI = PackageSpec (directory spec </> "to-install") []++    unregister "InternalLibrary2"+    iResult <- cabal_install specTI                     +    assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult)+    bResult <- cabal_build spec+    assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult)+    unregister "InternalLibrary2"++    (_, _, output) <- run (Just $ 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)+

@@ -0,0 +1,24 @@+module PackageTests.BuildDeps.InternalLibrary3.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import qualified Data.ByteString.Char8 as C+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary3") []+    let specTI = PackageSpec (directory spec </> "to-install") []++    unregister "InternalLibrary3"+    iResult <- cabal_install specTI                     +    assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult)+    bResult <- cabal_build spec+    assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult)+    unregister "InternalLibrary3"++    (_, _, output) <- run (Just $ 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)+

@@ -0,0 +1,24 @@+module PackageTests.BuildDeps.InternalLibrary4.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import qualified Data.ByteString.Char8 as C+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary4") []+    let specTI = PackageSpec (directory spec </> "to-install") []++    unregister "InternalLibrary4"+    iResult <- cabal_install specTI                     +    assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult)+    bResult <- cabal_build spec+    assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult)+    unregister "InternalLibrary4"++    (_, _, output) <- run (Just $ 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)+

@@ -0,0 +1,12 @@+module PackageTests.BuildDeps.SameDepsAllRound.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "SameDepsAllRound") []+    result <- cabal_build spec+    assertEqual "cabal build should succeed - see test-log.txt" True (successful result)

@@ -0,0 +1,18 @@+module PackageTests.BuildDeps.TargetSpecificDeps1.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import Data.List+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "TargetSpecificDeps1") []+    result <- cabal_build spec+    assertEqual "cabal build should fail - see test-log.txt" False (successful result)+    assertBool "error should be in MyLibrary.hs" $+        "MyLibrary.hs:" `isInfixOf` outputText result+    assertBool "error should be \"Could not find module `System.Time\"" $+        "Could not find module `System.Time'" `isInfixOf`+                        (intercalate " " $ lines $ outputText result)

@@ -0,0 +1,13 @@+module PackageTests.BuildDeps.TargetSpecificDeps2.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import Data.List+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "TargetSpecificDeps2") []+    result <- cabal_build spec+    assertEqual "cabal build should succeed - see test-log.txt" True (successful result)

@@ -0,0 +1,17 @@+module PackageTests.BuildDeps.TargetSpecificDeps3.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import Data.List+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "TargetSpecificDeps3") []+    result <- cabal_build spec+    assertEqual "cabal build should fail - see test-log.txt" False (successful result)+    assertBool "error should be in lemon.hs" $+        "lemon.hs:" `isInfixOf` outputText result+    assertBool "error should be \"Could not find module `System.Time\"" $+        "Could not find module `System.Time'" `isInfixOf` (intercalate " " $ lines $ outputText result)

@@ -0,0 +1,192 @@+module PackageTests.PackageTester (+        PackageSpec(..),+        Success(..),+        Result(..),+        cabal_configure,+        cabal_build,+        cabal_test,+        cabal_install,+        unregister,+        run+    ) where++import qualified Control.Exception.Extensible as E+import System.Directory+import System.FilePath+import System.IO+import System.Posix.IO+import System.Process+import System.Exit+import Control.Concurrent.Chan+import Control.Concurrent.MVar+import Control.Concurrent+import Control.Monad+import Data.List+import Data.Maybe+import qualified Data.ByteString.Char8 as C+++data PackageSpec =+    PackageSpec {+        directory  :: FilePath,+        configOpts :: [String]+    }++data Success = Failure | ConfigureSuccess | BuildSuccess | InstallSuccess | TestSuccess deriving (Eq, Show)++data Result = Result {+        successful :: Bool,+        success    :: Success,+        outputText :: String+    }+    deriving Show++nullResult :: Result+nullResult = Result True Failure ""++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 -> IO Result+cabal_configure spec = do+    res <- doCabalConfigure spec+    record spec res+    return res++doCabalConfigure :: PackageSpec -> IO Result+doCabalConfigure spec = do+    cleanResult@(_, _, cleanOutput) <- cabal spec ["clean"]+    requireSuccess cleanResult+    res <- cabal spec $ ["configure", "--user"] ++ configOpts spec+    return $ recordRun res ConfigureSuccess nullResult++doCabalBuild :: PackageSpec -> IO Result+doCabalBuild spec = do+    configResult <- doCabalConfigure spec+    if successful configResult+        then do+            res <- cabal spec ["build"]+            return $ recordRun res BuildSuccess configResult+        else+            return configResult++cabal_build :: PackageSpec -> IO Result+cabal_build spec = do+    res <- doCabalBuild spec+    record spec res+    return res++unregister :: String -> IO ()+unregister libraryName = do+    res@(_, _, output) <- run Nothing "ghc-pkg" ["unregister", "--user", libraryName]+    if "cannot find package" `isInfixOf` output+        then return ()+        else requireSuccess res++-- | Install this library in the user area+cabal_install :: PackageSpec -> IO Result+cabal_install spec = do+    buildResult <- doCabalBuild spec+    res <- if successful buildResult+        then do+            res <- cabal spec ["install"]+            return $ recordRun res InstallSuccess buildResult+        else+            return buildResult+    record spec res+    return res++cabal_test :: PackageSpec -> IO Result+cabal_test spec = do+    res <- cabal spec ["test"]+    let r = recordRun res TestSuccess nullResult+    record spec r+    return r++-- | Returns the command that was issued, the return code, and hte output text+cabal :: PackageSpec -> [String] -> IO (String, ExitCode, String)+cabal spec cabalArgs = do+    wd <- getCurrentDirectory+    r <- run (Just $ directory spec) "ghc"+             [ "--make"+             , "-fhpc"+             , "-package-conf " ++ wd </> "../dist/package.conf.inplace"+             , "Setup.hs"+             ]+    requireSuccess r+    run (Just $ directory spec) (wd </> directory spec </> "Setup") cabalArgs++-- | Returns the command that was issued, the return code, and hte output text+run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String)+run cwd cmd args = do+    -- Posix-specific+    (outf, outf0) <- createPipe+    (errf, errf0) <- createPipe+    outh <- fdToHandle outf+    outh0 <- fdToHandle outf0+    errh <- fdToHandle errf+    errh0 <- fdToHandle errf0+    pid <- runProcess cmd args cwd Nothing Nothing (Just outh0) (Just errh0)++    {-+    -- ghc-6.10.1 specific+    (Just inh, Just outh, Just errh, pid) <-+        createProcess (proc cmd args){ std_in  = CreatePipe,+                                       std_out = CreatePipe,+                                       std_err = CreatePipe,+                                       cwd     = cwd }+    hClose inh -- done with stdin+    -}++    -- fork off a thread to start consuming the output+    outChan <- newChan+    forkIO $ suckH outChan outh+    forkIO $ suckH outChan errh++    output <- suckChan outChan++    hClose outh+    hClose errh++    -- wait on the process+    ex <- waitForProcess pid+    let fullCmd = intercalate " " $ cmd:args+    return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd,+        ex, output)+  where+    suckH chan h = do+        eof <- hIsEOF h+        if eof+            then writeChan chan Nothing+            else do+                c <- hGetChar h+                writeChan chan $ Just c+                suckH chan h+    suckChan chan = sc' chan 2 []+      where+        sc' _ 0 acc = return $ reverse acc+        sc' chan eofs acc = do+            mC <- readChan chan+            case mC of+                Just c -> sc' chan eofs (c:acc)+                Nothing -> sc' chan (eofs-1) acc++requireSuccess :: (String, ExitCode, String) -> IO ()+requireSuccess (cmd, exitCode, output) = do+    case exitCode of+        ExitSuccess -> return ()+        ExitFailure r -> do+            ioError $ userError $ "Command " ++ cmd ++ " failed."++record :: PackageSpec -> Result -> IO ()+record spec res = do+    C.writeFile (directory spec </> "test-log.txt") (C.pack $ outputText res)+

@@ -0,0 +1,57 @@+module PackageTests.TestStanza.Check where++import Test.HUnit+import System.FilePath+import PackageTests.PackageTester+import Data.List (isInfixOf, intercalate)+import Distribution.Version+import Distribution.PackageDescription.Parse+        ( readPackageDescription )+import Distribution.PackageDescription.Configuration+        ( finalizePackageDescription )+import Distribution.Package+        ( PackageIdentifier(..), PackageName(..), Dependency(..) )+import Distribution.PackageDescription+        ( PackageDescription(..), BuildInfo(..), TestSuite(..), Library(..)+        , TestSuiteInterface(..)+        , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary+        , emptyTestSuite, BuildType(..) )+import Distribution.Verbosity (silent)+import Distribution.License (License(..))+import Distribution.ModuleName (fromString)+import Distribution.System (buildPlatform)+import Distribution.Compiler+        ( CompilerId(..), CompilerFlavor(..) )+import Distribution.Text++suite :: Version -> Test+suite cabalVersion = TestCase $ do+    let directory = "PackageTests" </> "TestStanza"+        pdFile = directory </> "my" <.> "cabal"+        spec = PackageSpec directory []+    result <- cabal_configure spec+    let message = "cabal configure should recognize test section"+        test = "unknown section type"+               `isInfixOf`+               (intercalate " " $ lines $ outputText result)+    assertEqual message False test+    genPD <- readPackageDescription silent pdFile+    let compiler = CompilerId GHC $ Version [6, 12, 2] []+        anyV = intersectVersionRanges anyVersion anyVersion+        anticipatedTestSuite = emptyTestSuite+            { testName = "dummy"+            , testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs"+            , testBuildInfo = emptyBuildInfo+                    { targetBuildDepends =+                            [ Dependency (PackageName "base") anyVersion ]+                    , 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

@@ -0,0 +1,47 @@+module PackageTests.TestSuiteExeV10.Check+       ( checkTest+       , checkTestWithHpc+       ) where++import Distribution.PackageDescription ( TestSuite(..), emptyTestSuite )+import Distribution.Simple.Hpc+import Distribution.Version+import Test.HUnit+import System.Directory+import System.FilePath+import PackageTests.PackageTester++dir :: FilePath+dir = "PackageTests" </> "TestSuiteExeV10"++checkTest :: Version -> Test+checkTest cabalVersion = TestCase $ do+    let spec = PackageSpec dir ["--enable-tests"]+    buildResult <- cabal_build spec+    let buildMessage = "\'setup build\' should succeed"+    assertEqual buildMessage True $ successful buildResult+    testResult <- cabal_test spec+    let testMessage = "\'setup test\' should succeed"+    assertEqual testMessage True $ successful testResult++checkTestWithHpc :: Version -> Test+checkTestWithHpc cabalVersion = TestCase $ do+    let spec = PackageSpec dir [ "--enable-tests"+                               , "--enable-library-coverage"+                               ]+    buildResult <- cabal_build spec+    let buildMessage = "\'setup build\' should succeed"+    assertEqual buildMessage True $ successful buildResult+    testResult <- cabal_test spec+    let testMessage = "\'setup test\' should succeed"+    assertEqual testMessage True $ successful testResult+    let dummy = emptyTestSuite { testName = "test-Foo" }+        tixFile = tixFilePath (dir </> "dist") dummy+        tixFileMessage = ".tix file should exist"+        markupDir = tixDir (dir </> "dist") dummy+        markupFile = markupDir </> "hpc_index" <.> "html"+        markupFileMessage = "HPC markup file should exist"+    tixFileExists <- doesFileExist tixFile+    assertEqual tixFileMessage True tixFileExists+    markupFileExists <- doesFileExist markupFile+    assertEqual markupFileMessage True markupFileExists

@@ -0,0 +1,66 @@+-- The intention is that this will be the new unit test framework.+-- Please add any working tests here.  This file should do nothing+-- but import tests from other modules.+--+-- Stephen Blackheath, 2009++module Main where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import qualified Test.HUnit as HUnit+import PackageTests.BuildDeps.SameDepsAllRound.Check+import PackageTests.BuildDeps.TargetSpecificDeps1.Check+import PackageTests.BuildDeps.TargetSpecificDeps1.Check+import PackageTests.BuildDeps.TargetSpecificDeps2.Check+import PackageTests.BuildDeps.TargetSpecificDeps3.Check+import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check+import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check+import PackageTests.BuildDeps.InternalLibrary0.Check+import PackageTests.BuildDeps.InternalLibrary1.Check+import PackageTests.BuildDeps.InternalLibrary2.Check+import PackageTests.BuildDeps.InternalLibrary3.Check+import PackageTests.BuildDeps.InternalLibrary4.Check+import PackageTests.TestStanza.Check+import PackageTests.TestSuiteExeV10.Check+import Distribution.Text (display)+import Distribution.Simple.Utils (cabalVersion)+import Data.Version+import System.Directory++hunit :: TestName -> HUnit.Test -> Test+hunit name test = testGroup name $ hUnitTestToTests test++tests :: Version -> [Test]+tests cabalVersion = [+        hunit "PackageTests/BuildDeps/SameDepsAllRound/" PackageTests.BuildDeps.SameDepsAllRound.Check.suite,+        hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check.suite,+        hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check.suite,+        hunit "PackageTests/BuildDeps/InternalLibrary0/" (PackageTests.BuildDeps.InternalLibrary0.Check.suite cabalVersion),+        hunit "PackageTests/TestStanza/" (PackageTests.TestStanza.Check.suite cabalVersion),+        -- ^ The Test stanza test will eventually be required+        -- only for higher versions.+        hunit "PackageTests/TestSuiteExeV10/Test"+        (PackageTests.TestSuiteExeV10.Check.checkTest cabalVersion),+        hunit "PackageTests/TestSuiteExeV10/TestWithHpc"+        (PackageTests.TestSuiteExeV10.Check.checkTestWithHpc cabalVersion)+    ] +++    -- These tests are only required to pass on cabal version >= 1.7+    (if cabalVersion >= Version [1, 7] []+        then [+            hunit "PackageTests/BuildDeps/TargetSpecificDeps1/" PackageTests.BuildDeps.TargetSpecificDeps1.Check.suite,+            hunit "PackageTests/BuildDeps/TargetSpecificDeps2/" PackageTests.BuildDeps.TargetSpecificDeps2.Check.suite,+            hunit "PackageTests/BuildDeps/TargetSpecificDeps3/" PackageTests.BuildDeps.TargetSpecificDeps3.Check.suite,+            hunit "PackageTests/BuildDeps/InternalLibrary1/" PackageTests.BuildDeps.InternalLibrary1.Check.suite,+            hunit "PackageTests/BuildDeps/InternalLibrary2/" PackageTests.BuildDeps.InternalLibrary2.Check.suite,+            hunit "PackageTests/BuildDeps/InternalLibrary3/" PackageTests.BuildDeps.InternalLibrary3.Check.suite,+            hunit "PackageTests/BuildDeps/InternalLibrary4/" PackageTests.BuildDeps.InternalLibrary4.Check.suite+        ]+        else [])++main = do+    putStrLn $ "Cabal test suite - testing cabal version "++display cabalVersion+    setCurrentDirectory "tests"+    defaultMain (tests cabalVersion)+