Cabal 1.8.0.6 → 1.10.0.0

raw patch · 49 files changed

+3316/−868 lines, 49 filesdep ~basedep ~containersdep ~directoryPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, containers, directory, filepath

API changes (from Hackage documentation)

Files

• Cabal.cabal +11/−12
• Distribution/Compat/TempFile.hs +5/−5
• Distribution/Compiler.hs +2/−2
• Distribution/GetOpt.hs +1/−1
• Distribution/License.hs +1/−1
• Distribution/Make.hs +1/−3
• Distribution/ModuleName.hs +0/−2
• Distribution/PackageDescription.hs +240/−40
• Distribution/PackageDescription/Check.hs +346/−57
• Distribution/PackageDescription/Configuration.hs +45/−20
• Distribution/PackageDescription/Parse.hs +182/−35
• Distribution/ParseUtils.hs +15/−8
• Distribution/Simple.hs +93/−29
• Distribution/Simple/Build.hs +71/−8
• Distribution/Simple/Build/Macros.hs +2/−0
• Distribution/Simple/Build/PathsModule.hs +15/−5
• Distribution/Simple/Compiler.hs +20/−3
• Distribution/Simple/Configure.hs +142/−108
• Distribution/Simple/GHC.hs +92/−62
• Distribution/Simple/Haddock.hs +49/−33
• Distribution/Simple/Hugs.hs +54/−18
• Distribution/Simple/Install.hs +20/−12
• Distribution/Simple/InstallDirs.hs +10/−9
• Distribution/Simple/JHC.hs +10/−4
• Distribution/Simple/LHC.hs +84/−78
• Distribution/Simple/LocalBuildInfo.hs +34/−11
• Distribution/Simple/NHC.hs +15/−9
• Distribution/Simple/PackageIndex.hs +3/−3
• Distribution/Simple/PreProcess.hs +175/−89
• Distribution/Simple/Program.hs +1/−0
• Distribution/Simple/Program/Ar.hs +3/−1
• Distribution/Simple/Program/Builtin.hs +7/−0
• Distribution/Simple/Program/Db.hs +10/−8
• Distribution/Simple/Program/HcPkg.hs +35/−9
• Distribution/Simple/Program/Run.hs +4/−2
• Distribution/Simple/Program/Script.hs +1/−1
• Distribution/Simple/Program/Types.hs +6/−1
• Distribution/Simple/Register.hs +19/−103
• Distribution/Simple/Setup.hs +117/−36
• Distribution/Simple/SrcDist.hs +1/−1
• Distribution/Simple/Test.hs +435/−0
• Distribution/Simple/UHC.hs +296/−0
• Distribution/Simple/UserHooks.hs +16/−3
• Distribution/Simple/Utils.hs +7/−11
• Distribution/TestSuite.hs +310/−0
• Distribution/Verbosity.hs +1/−1
• Distribution/Version.hs +10/−5
• Language/Haskell/Extension.hs +297/−10
• changelog +2/−9

@@ -1,5 +1,5 @@ Name: Cabal-Version: 1.8.0.6+Version: 1.10.0.0 Copyright: 2003-2006, Isaac Jones            2005-2009, Duncan Coutts License: BSD3@@ -18,6 +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 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.@@ -29,11 +30,6 @@   type:     darcs   location: http://darcs.haskell.org/cabal/ -source-repository this-  type:     darcs-  location: http://darcs.haskell.org/cabal-branches/cabal-1.8/-  tag: 1.8.0.6- Flag base4     Description: Choose the even newer, even smaller, split-up base package. @@ -41,15 +37,15 @@     Description: Choose the new smaller, split-up base package.  Library-  build-depends:   base       >= 1   && < 5,-                   filepath   >= 1   && < 1.2+  build-depends:   base       >= 2   && < 5,+                   filepath   >= 1   && < 1.3   if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 }   if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 }   if flag(base3)-    Build-Depends: directory  >= 1   && < 1.1,+    Build-Depends: directory  >= 1   && < 1.2,                    process    >= 1   && < 1.1,                    old-time   >= 1   && < 1.1,-                   containers >= 0.1 && < 0.4,+                   containers >= 0.1 && < 0.5,                    array      >= 0.1 && < 0.4,                    pretty     >= 1   && < 1.1 @@ -59,7 +55,6 @@   ghc-options: -Wall -fno-ignore-asserts   if impl(ghc >= 6.8)     ghc-options: -fwarn-tabs-  cpp-options: "-DCABAL_VERSION=1,8,0,6"   nhc98-Options: -K4M    Exposed-Modules:@@ -107,9 +102,12 @@         Distribution.Simple.Register,         Distribution.Simple.Setup,         Distribution.Simple.SrcDist,+        Distribution.Simple.Test,+        Distribution.Simple.UHC,         Distribution.Simple.UserHooks,         Distribution.Simple.Utils,         Distribution.System,+        Distribution.TestSuite,         Distribution.Text,         Distribution.Verbosity,         Distribution.Version,@@ -122,6 +120,7 @@         Distribution.Compat.CopyFile,         Distribution.Compat.TempFile,         Distribution.Simple.GHC.IPI641,-        Distribution.Simple.GHC.IPI642+        Distribution.Simple.GHC.IPI642,+        Paths_Cabal    Extensions: CPP

@@ -75,7 +75,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 <- openFile path ReadWriteMode@@ -142,7 +142,7 @@            then findTempName (x+1)            else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))        else do-         -- XXX We want to tell fdToHandle what the filepath is,+         -- TODO: We want to tell fdToHandle what the filepath is,          -- as any exceptions etc will only be able to report the          -- fd currently          h <-@@ -161,14 +161,14 @@         filename        = prefix ++ show x ++ suffix         filepath        = dir `combine` filename -        -- XXX bits copied from System.FilePath, since that's not available here+        -- FIXME: bits copied from System.FilePath         combine a b                   | null b = a                   | null a = b                   | last a == pathSeparator = a ++ b                   | otherwise = a ++ [pathSeparator] ++ b --- XXX Should use filepath library+-- FIXME: Should use filepath library pathSeparator :: Char #ifdef mingw32_HOST_OS pathSeparator = '\\'@@ -176,7 +176,7 @@ pathSeparator = '/' #endif --- XXX Copied from GHC.Handle+-- FIXME: Copied from GHC.Handle std_flags, output_flags, rw_flags :: CInt std_flags    = o_NONBLOCK   .|. o_NOCTTY output_flags = std_flags    .|. o_CREAT

@@ -73,12 +73,12 @@ import qualified Data.Char as Char (toLower, isDigit, isAlphaNum) import Control.Monad (when) -data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC+data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC                     | OtherCompiler String   deriving (Show, Read, Eq, Ord)  knownCompilerFlavors :: [CompilerFlavor]-knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC]+knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]  instance Text CompilerFlavor where   disp (OtherCompiler name) = Disp.text name

@@ -99,7 +99,7 @@           -> String                    -- nicely formatted decription of options usageInfo header optDescr = unlines (header:table)    where (ss,ls,ds) = unzip3 [ (sepBy ", " (map (fmtShort ad) sos)-                               ,sepBy ", " (map (fmtLong  ad) los)+                               ,concatMap (fmtLong  ad) (take 1 los)                                ,d)                              | Option sos los ad d <- optDescr ]          ssWidth    = (maximum . map length) ss

@@ -106,7 +106,7 @@ knownLicenses :: [License] knownLicenses = [ GPL  unversioned, GPL  (version [2]),   GPL  (version [3])                 , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3])-                , BSD3, BSD4, MIT+                , BSD3, MIT                 , PublicDomain, AllRightsReserved, OtherLicense]  where    unversioned = Nothing

@@ -15,7 +15,7 @@ -- maintenance and no testing. Perhaps at some point we should stop pretending -- that it works. ----- Uses the parsed command-line from Distribution.Setup in order to build+-- Uses the parsed command-line from "Distribution.Simple.Setup" in order to build -- Haskell tools using a backend build system based on make. Obviously we -- assume that there is a configure script, and that after the ConfigCmd has -- been run, there is a Makefile. Further assumptions:@@ -171,8 +171,6 @@   let destArgs = case fromFlag $ copyDest flags of         NoCopyDest      -> ["install"]         CopyTo path     -> ["copy", "destdir=" ++ path]-        CopyPrefix path -> ["install", "prefix=" ++ path]-                -- CopyPrefix is backwards compat, DEPRECATED   rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs  installAction :: InstallFlags -> [String] -> IO ()

@@ -86,8 +86,6 @@ validModuleComponent (c:cs) = Char.isUpper c                            && all validModuleChar cs --- XXX This is used in Distribution/Simple/PreProcess.hs, so we can't--- deprecate it yet without getting warnings, and thus build failures {-# DEPRECATED simple "use ModuleName.fromString instead" #-} simple :: String -> ModuleName simple str = ModuleName [str]

@@ -7,13 +7,14 @@ -- Portability :  portable -- -- This defines the data structure for the @.cabal@ file format. There are--- several parts to this structure. It has top level info and then 'Library'--- and 'Executable' sections each of which have associated 'BuildInfo' data--- that's used to build the library or exe. To further complicate things there--- is both a 'PackageDescription' and a 'GenericPackageDescription'. This--- distinction relates to cabal configurations. When we initially read a--- @.cabal@ file we get a 'GenericPackageDescription' which has all the--- conditional sections. Before actually building a package we have to decide+-- several parts to this structure. It has top level info and then 'Library',+-- 'Executable', and 'TestSuite' sections each of which have associated+-- 'BuildInfo' data that's used to build the library, exe, or test. To further+-- complicate things there is both a 'PackageDescription' and a+-- 'GenericPackageDescription'. This distinction relates to cabal+-- configurations. When we initially read a @.cabal@ file we get a+-- 'GenericPackageDescription' which has all the conditional sections.+-- Before actually building a package we have to decide -- on each conditional. Once we've done that we get a 'PackageDescription'. -- It was done this way initially to avoid breaking too much stuff when the -- feature was introduced. It could probably do with being rationalised at some@@ -53,6 +54,8 @@         -- * Package descriptions         PackageDescription(..),         emptyPackageDescription,+        specVersion,+        descCabalVersion,         BuildType(..),         knownBuildTypes, @@ -70,10 +73,24 @@         hasExes,         exeModules, +        -- * Tests+        TestSuite(..),+        TestSuiteInterface(..),+        TestType(..),+        testType,+        knownTestTypes,+        emptyTestSuite,+        hasTests,+        withTest,+        testModules,+         -- * Build information         BuildInfo(..),         emptyBuildInfo,         allBuildInfo,+        allLanguages,+        allExtensions,+        usedExtensions,         hcOptions,          -- ** Supplementary build information@@ -87,26 +104,34 @@         CondTree(..), ConfVar(..), Condition(..),          -- * Source repositories-        SourceRepo(..), RepoKind(..), RepoType(..),+        SourceRepo(..),+        RepoKind(..),+        RepoType(..),+        knownRepoTypes,   ) where -import Data.List   (nub)+import Data.List   (nub, intersperse)+import Data.Maybe  (maybeToList) import Data.Monoid (Monoid(mempty, mappend))+import Control.Monad (MonadPlus(mplus)) import Text.PrettyPrint.HughesPJ as Disp import qualified Distribution.Compat.ReadP as Parse-import qualified Data.Char as Char (isAlphaNum, toLower)+import qualified Data.Char as Char (isAlphaNum, isDigit, toLower)  import Distribution.Package          ( PackageName(PackageName), PackageIdentifier(PackageIdentifier)          , Dependency, Package(..) )-import Distribution.ModuleName (ModuleName)-import Distribution.Version  (Version(Version), VersionRange, anyVersion)+import Distribution.ModuleName ( ModuleName )+import Distribution.Version+         ( Version(Version), VersionRange, anyVersion, orLaterVersion+         , asVersionIntervals, LowerBound(..) ) import Distribution.License  (License(AllRightsReserved)) import Distribution.Compiler (CompilerFlavor) import Distribution.System   (OS, Arch) import Distribution.Text          ( Text(..), display )-import Language.Haskell.Extension (Extension)+import Language.Haskell.Extension+         ( Language, Extension )  -- ----------------------------------------------------------------------------- -- The PackageDescription type@@ -139,11 +164,16 @@                                              -- with x-, stored in a                                              -- simple assoc-list.         buildDepends   :: [Dependency],-        descCabalVersion :: VersionRange, -- ^If this package depends on a specific version of Cabal, give that here.+        -- | The version of the Cabal spec that this package description uses.+        -- For historical reasons this is specified with a version range but+        -- only ranges of the form @>= v@ make sense. We are in the process of+        -- transitioning to specifying just a single version, not a range.+        specVersionRaw :: Either Version VersionRange,         buildType      :: Maybe BuildType,         -- components         library        :: Maybe Library,         executables    :: [Executable],+        testSuites     :: [TestSuite],         dataFiles      :: [FilePath],         dataDir        :: FilePath,         extraSrcFiles  :: [FilePath],@@ -154,6 +184,32 @@ instance Package PackageDescription where   packageId = package +-- | The version of the Cabal spec that this package should be interpreted+-- against.+--+-- Historically we used a version range but we are switching to using a single+-- version. Currently we accept either. This function converts into a single+-- version by ignoring upper bounds in the version range.+--+specVersion :: PackageDescription -> Version+specVersion pkg = case specVersionRaw pkg of+  Left  version      -> version+  Right versionRange -> case asVersionIntervals versionRange of+                          []                            -> Version [0] []+                          ((LowerBound version _, _):_) -> version++-- | The range of versions of the Cabal tools that this package is intended to+-- work with.+--+-- This function is deprecated and should not be used for new purposes, only to+-- support old packages that rely on the old interpretation.+--+descCabalVersion :: PackageDescription -> VersionRange+descCabalVersion pkg = case specVersionRaw pkg of+  Left  version      -> orLaterVersion version+  Right versionRange -> versionRange+{-# DEPRECATED descCabalVersion "Use specVersion instead" #-}+ emptyPackageDescription :: PackageDescription emptyPackageDescription     =  PackageDescription {@@ -161,7 +217,7 @@                                                        (Version [] []),                       license      = AllRightsReserved,                       licenseFile  = "",-                      descCabalVersion = anyVersion,+                      specVersionRaw = Right anyVersion,                       buildType    = Nothing,                       copyright    = "",                       maintainer   = "",@@ -179,6 +235,7 @@                       customFieldsPD = [],                       library      = Nothing,                       executables  = [],+                      testSuites   = [],                       dataFiles    = [],                       dataDir      = "",                       extraSrcFiles = [],@@ -311,6 +368,129 @@ exeModules exe = otherModules (buildInfo exe)  -- ---------------------------------------------------------------------------+-- The TestSuite type++-- | A \"test-suite\" stanza in a cabal file.+--+data TestSuite = TestSuite {+        testName      :: String,+        testInterface :: TestSuiteInterface,+        testBuildInfo :: BuildInfo+    }+    deriving (Show, Read, Eq)++-- | The test suite interfaces that are currently defined. Each test suite must+-- specify which interface it supports.+--+-- More interfaces may be defined in future, either new revisions or totally+-- new interfaces.+--+data TestSuiteInterface =++     -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form+     -- of an executable. It returns a zero exit code for success, non-zero for+     -- failure. The stdout and stderr channels may be logged. It takes no+     -- command line parameters and nothing on stdin.+     --+     TestSuiteExeV10 Version FilePath++     -- | Test interface \"detailed-0.9\". The test-suite takes the form of a+     -- library containing a designated module that exports \"tests :: [Test]\".+     --+   | TestSuiteLibV09 Version ModuleName++     -- | A test suite that does not conform to one of the above interfaces for+     -- the given reason (e.g. unknown test type).+     --+   | TestSuiteUnsupported TestType+   deriving (Eq, Read, Show)++instance Monoid TestSuite where+    mempty = TestSuite {+        testName      = mempty,+        testInterface = mempty,+        testBuildInfo = mempty+    }++    mappend a b = TestSuite {+        testName      = combine' testName,+        testInterface = combine  testInterface,+        testBuildInfo = combine  testBuildInfo+    }+        where combine   field = field a `mappend` field b+              combine' f = case (f a, f b) of+                        ("", x) -> x+                        (x, "") -> x+                        (x, y) -> error "Ambiguous values for test field: '"+                            ++ x ++ "' and '" ++ y ++ "'"++instance Monoid TestSuiteInterface where+    mempty  =  TestSuiteUnsupported (TestTypeUnknown mempty (Version [] []))+    mappend a (TestSuiteUnsupported _) = a+    mappend _ b                        = b++emptyTestSuite :: TestSuite+emptyTestSuite = mempty++-- | Does this package have any test suites?+hasTests :: PackageDescription -> Bool+hasTests = any (buildable . testBuildInfo) . testSuites++-- | Perform an action on each buildable 'TestSuite' in a package.+withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO ()+withTest pkg_descr f =+    mapM_ f $ filter (buildable . testBuildInfo) $+        testSuites pkg_descr++-- | Get all the module names from a test suite.+testModules :: TestSuite -> [ModuleName]+testModules test = (case testInterface test of+                     TestSuiteLibV09 _ m -> [m]+                     _                   -> [])+                ++ otherModules (testBuildInfo test)++-- | The \"test-type\" field in the test suite stanza.+--+data TestType = TestTypeExe Version     -- ^ \"type: exitcode-stdio-x.y\"+              | TestTypeLib Version     -- ^ \"type: detailed-x.y\"+              | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\"+    deriving (Show, Read, Eq)++knownTestTypes :: [TestType]+knownTestTypes = [ TestTypeExe (Version [1,0] [])+                   -- 'detailed-0.9' test type is disabled in Cabal-1.10.x+                   -- needs more work on the details of the library interface+              {- , TestTypeLib (Version [0,9] []) -} ]++instance Text TestType where+  disp (TestTypeExe ver)          = text "exitcode-stdio-" <> disp ver+  disp (TestTypeLib ver)          = text "detailed-"       <> disp ver+  disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver++  parse = do+    cs   <- Parse.sepBy1 component (Parse.char '-')+    _    <- Parse.char '-'+    ver  <- parse+    let name = concat (intersperse "-" cs)+    return $! case lowercase name of+      "exitcode-stdio" -> TestTypeExe ver+      "detailed"       -> TestTypeLib ver+      _                -> TestTypeUnknown name ver++    where+      component = do+        cs <- Parse.munch1 Char.isAlphaNum+        if all Char.isDigit cs then Parse.pfail else return cs+        -- each component must contain an alphabetic character, to avoid+        -- ambiguity in identifiers like foo-1 (the 1 is the version number).++testType :: TestSuite -> TestType+testType test = case testInterface test of+  TestSuiteExeV10 ver _         -> TestTypeExe ver+  TestSuiteLibV09 ver _         -> TestTypeLib ver+  TestSuiteUnsupported testtype -> testtype++-- --------------------------------------------------------------------------- -- The BuildInfo type  -- Consider refactoring into executable and library versions.@@ -325,7 +505,13 @@         cSources          :: [FilePath],         hsSourceDirs      :: [FilePath], -- ^ where to look for the haskell module hierarchy         otherModules      :: [ModuleName], -- ^ non-exposed or non-main modules-        extensions        :: [Extension],++        defaultLanguage   :: Maybe Language,-- ^ language used when not explicitly specified+        otherLanguages    :: [Language],    -- ^ other languages used within the package+        defaultExtensions :: [Extension],   -- ^ language extensions used by all modules+        otherExtensions   :: [Extension],   -- ^ other language extensions used within the package+        oldExtensions     :: [Extension],   -- ^ the old extensions field, treated same as 'defaultExtensions'+         extraLibs         :: [String], -- ^ what libraries to link with when compiling a program that uses your package         extraLibDirs      :: [String],         includeDirs       :: [FilePath], -- ^directories to find .h files@@ -353,7 +539,11 @@     cSources          = [],     hsSourceDirs      = [],     otherModules      = [],-    extensions        = [],+    defaultLanguage   = Nothing,+    otherLanguages    = [],+    defaultExtensions = [],+    otherExtensions   = [],+    oldExtensions     = [],     extraLibs         = [],     extraLibDirs      = [],     includeDirs       = [],@@ -376,7 +566,11 @@     cSources          = combineNub cSources,     hsSourceDirs      = combineNub hsSourceDirs,     otherModules      = combineNub otherModules,-    extensions        = combineNub extensions,+    defaultLanguage   = combineMby defaultLanguage,+    otherLanguages    = combineNub otherLanguages,+    defaultExtensions = combineNub defaultExtensions,+    otherExtensions   = combineNub otherExtensions,+    oldExtensions     = combineNub oldExtensions,     extraLibs         = combine    extraLibs,     extraLibDirs      = combineNub extraLibDirs,     includeDirs       = combineNub includeDirs,@@ -391,6 +585,7 @@     where       combine    field = field a `mappend` field b       combineNub field = nub (combine field)+      combineMby field = field b `mplus` field a  emptyBuildInfo :: BuildInfo emptyBuildInfo = mempty@@ -404,7 +599,30 @@                       ++ [ bi | exe <- executables pkg_descr                               , let bi = buildInfo exe                               , buildable bi ]+                      ++ [ bi | tst <- testSuites pkg_descr+                              , let bi = testBuildInfo tst+                              , buildable bi ]+  --FIXME: many of the places where this is used, we actually want to look at+  --       unbuildable bits too, probably need separate functions +-- | The 'Language's used by this component+--+allLanguages :: BuildInfo -> [Language]+allLanguages bi = maybeToList (defaultLanguage bi)+               ++ otherLanguages bi++-- | The 'Extension's that are used somewhere by this component+--+allExtensions :: BuildInfo -> [Extension]+allExtensions bi = usedExtensions bi+                ++ otherExtensions bi++-- | The 'Extensions' that are used by all modules in this component+--+usedExtensions :: BuildInfo -> [Extension]+usedExtensions bi = oldExtensions bi+                 ++ defaultExtensions bi+ type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)])  emptyHookedBuildInfo :: HookedBuildInfo@@ -585,33 +803,15 @@         packageDescription :: PackageDescription,         genPackageFlags       :: [Flag],         condLibrary        :: Maybe (CondTree ConfVar [Dependency] Library),-        condExecutables    :: [(String, CondTree ConfVar [Dependency] Executable)]+        condExecutables    :: [(String, CondTree ConfVar [Dependency] Executable)],+        condTestSuites     :: [(String, CondTree ConfVar [Dependency] TestSuite)]       }     deriving (Show, Eq)  instance Package GenericPackageDescription where   packageId = packageId . packageDescription -{---- XXX: I think we really want a PPrint or Pretty or ShowPretty class.-instance Show GenericPackageDescription where-    show (GenericPackageDescription pkg flgs mlib exes) =-        showPackageDescription pkg ++ "\n" ++-        (render $ vcat $ map ppFlag flgs) ++ "\n" ++-        render (maybe empty (\l -> showStanza "Library" (ppCondTree l showDeps)) mlib)-        ++ "\n" ++-        (render $ vcat $-            map (\(n,ct) -> showStanza ("Executable " ++ n) (ppCondTree ct showDeps)) exes)-      where-        ppFlag (MkFlag name desc dflt manual) =-            showStanza ("Flag " ++ name)-              ((if (null desc) then empty else-                   text ("Description: " ++ desc)) $+$-              text ("Default: " ++ show dflt) $+$-              text ("Manual: " ++ show manual))-        showDeps = fsep . punctuate comma . map showDependency-        showStanza h b = text h <+> lbrace $+$ nest 2 b $+$ rbrace--}+--TODO: make PackageDescription an instance of Text.  -- | A flag can represent a feature to be included, or a way of linking --   a target against its dependencies, or in fact whatever you can think of.@@ -625,7 +825,7 @@  -- | A 'FlagName' is the name of a user-defined configuration flag newtype FlagName = FlagName String-    deriving (Eq, Ord, Show)+    deriving (Eq, Ord, Show, Read)  -- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to -- 'Bool' flag values. It represents the flags chosen by the user or

@@ -62,13 +62,15 @@         checkPackageFileNames,   ) where -import Data.Maybe (isNothing, catMaybes, fromMaybe)+import Data.Maybe+         ( isNothing, isJust, catMaybes, maybeToList, fromMaybe ) import Data.List  (sort, group, isPrefixOf, nub, find) import Control.Monad          ( filterM, liftM ) import qualified System.Directory as System          ( doesFileExist, doesDirectoryExist ) +import Distribution.Package ( pkgName ) import Distribution.PackageDescription import Distribution.PackageDescription.Configuration          ( flattenPackageDescription, finalizePackageDescription )@@ -83,18 +85,23 @@  import Distribution.Version          ( Version(..)-         , VersionRange, withinRange, foldVersionRange'+         , VersionRange(..), foldVersionRange'          , anyVersion, noVersion, thisVersion, laterVersion, earlierVersion          , orLaterVersion, orEarlierVersion          , unionVersionRanges, intersectVersionRanges-         , asVersionIntervals, LowerBound(..), UpperBound(..) )+         , asVersionIntervals, UpperBound(..), isNoVersion ) import Distribution.Package          ( PackageName(PackageName), packageName, packageVersion          , Dependency(..) )+ import Distribution.Text-         ( display )-import qualified Language.Haskell.Extension as Extension-import Language.Haskell.Extension (Extension(..))+         ( display, disp )+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint ((<>), (<+>))++import qualified Language.Haskell.Extension as Extension (deprecatedExtensions)+import Language.Haskell.Extension+         ( Language(UnknownLanguage), knownLanguages, Extension(..) ) import System.FilePath          ( (</>), takeExtension, isRelative, isAbsolute          , splitDirectories,  splitPath )@@ -196,20 +203,39 @@   , check (null (executables pkg) && isNothing (library pkg)) $       PackageBuildImpossible         "No executables and no library found. Nothing to do."++  , check (not (null exeDuplicates)) $+      PackageBuildImpossible $ "Duplicate executable sections "+        ++ commaSep exeDuplicates+  , check (not (null testDuplicates)) $+      PackageBuildImpossible $ "Duplicate test sections "+        ++ commaSep testDuplicates++    --TODO: this seems to duplicate a check on the testsuites+  , check (not (null testsThatAreExes)) $+      PackageBuildImpossible $ "These test sections share names with executable sections: "+        ++ commaSep testsThatAreExes   ]+  --TODO: check for name clashes case insensitively: windows file systems cannot cope.    ++ maybe []  checkLibrary    (library pkg)   ++ concatMap checkExecutable (executables pkg)+  ++ concatMap (checkTestSuite pkg) (testSuites pkg)    ++ catMaybes [ -    check (not $ cabalVersion `withinRange` requiredCabalVersion) $+    check (specVersion pkg > cabalVersion) $       PackageBuildImpossible $-           "This package requires Cabal version: "-        ++ display requiredCabalVersion+           "This package description follows version "+        ++ display (specVersion pkg) ++ " of the Cabal specification. This "+        ++ "tool only supports up to version " ++ display cabalVersion ++ "."   ]--  where requiredCabalVersion = descCabalVersion pkg+  where+    exeNames = map exeName $ executables pkg+    testNames = map testName $ testSuites pkg+    exeDuplicates = dups exeNames+    testDuplicates = dups testNames+    testsThatAreExes = filter (flip elem exeNames) testNames  checkLibrary :: Library -> [PackageCheck] checkLibrary lib =@@ -217,13 +243,12 @@      check (not (null moduleDuplicates)) $        PackageBuildWarning $-         "Duplicate modules in library: " ++ commaSep moduleDuplicates+            "Duplicate modules in library: "+         ++ commaSep (map display moduleDuplicates)   ] -  where moduleDuplicates = [ display module_-                           | let modules = exposedModules lib-                                        ++ otherModules (libBuildInfo lib)-                           , (module_:_:_) <- group (sort modules) ]+  where+    moduleDuplicates = dups (libModules lib)  checkExecutable :: Executable -> [PackageCheck] checkExecutable exe =@@ -242,13 +267,62 @@   , check (not (null moduleDuplicates)) $        PackageBuildWarning $             "Duplicate modules in executable '" ++ exeName exe ++ "': "-         ++ commaSep moduleDuplicates+         ++ commaSep (map display moduleDuplicates)   ]+  where+    moduleDuplicates = dups (exeModules exe) -  where moduleDuplicates = [ display module_-                           | let modules = otherModules (buildInfo exe)-                           , (module_:_:_) <- group (sort modules) ]+checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck]+checkTestSuite pkg test =+  catMaybes [ +    case testInterface test of+      TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $+        PackageBuildWarning $+             quote (display tt) ++ " is not a known type of test suite. "+          ++ "The known test suite types are: "+          ++ commaSep (map display knownTestTypes)++      TestSuiteUnsupported tt -> Just $+        PackageBuildWarning $+             quote (display tt) ++ " is not a supported test suite version. "+          ++ "The known test suite types are: "+          ++ commaSep (map display knownTestTypes)+      _ -> Nothing++  , check (not $ null moduleDuplicates) $+      PackageBuildWarning $+           "Duplicate modules in test suite '" ++ testName test ++ "': "+        ++ commaSep (map display moduleDuplicates)++  , check mainIsWrongExt $+      PackageBuildImpossible $+           "The 'main-is' field must specify a '.hs' or '.lhs' file "+        ++ "(even if it is generated by a preprocessor)."++  , check exeNameClash $+      PackageBuildImpossible $+           "The test suite " ++ testName test+        ++ " has the same name as an executable."++  , check libNameClash $+      PackageBuildImpossible $+           "The test suite " ++ testName test+        ++ " has the same name as the package."+  ]+  where+    moduleDuplicates = dups $ testModules test++    mainIsWrongExt = case testInterface test of+      TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]+      _                   -> False++    exeNameClash = testName test `elem` [ exeName exe | exe <- executables pkg ]+    libNameClash = testName test `elem` [ libName+                                        | _lib <- maybeToList (library pkg)+                                        , let PackageName libName =+                                                pkgName (package pkg) ]+ -- ------------------------------------------------------------ -- * Additional pure checks -- ------------------------------------------------------------@@ -282,10 +356,21 @@         "Unknown compiler " ++ commaSep (map quote unknownCompilers)                             ++ " in 'tested-with' field." +  , check (not (null unknownLanguages)) $+      PackageBuildWarning $+        "Unknown languages: " ++ commaSep unknownLanguages+   , check (not (null unknownExtensions)) $       PackageBuildWarning $         "Unknown extensions: " ++ commaSep unknownExtensions +  , check (not (null languagesUsedAsExtensions)) $+      PackageBuildWarning $+           "Languages listed as extensions: "+        ++ commaSep languagesUsedAsExtensions+        ++ ". Languages must be specified in either the 'default-language' "+        ++ " or the 'other-languages' field."+   , check (not (null deprecatedExtensions)) $       PackageDistSuspicious $            "Deprecated extensions: "@@ -313,16 +398,39 @@   , check (length (synopsis pkg) >= 80) $       PackageDistSuspicious         "The 'synopsis' field is rather long (max 80 chars is recommended)."++    -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12"+  , check (not (null testedWithImpossibleRanges)) $+      PackageDistInexcusable $+           "Invalid 'tested-with' version range: "+        ++ commaSep (map display testedWithImpossibleRanges)+        ++ ". To indicate that you have tested a package with multiple "+        ++ "different versions of the same compiler use multiple entries, "+        ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not "+        ++ "'tested-with: GHC==6.10.4 && ==6.12.3'."   ]   where     unknownCompilers  = [ name | (OtherCompiler name, _) <- testedWith pkg ]+    unknownLanguages  = [ name | bi <- allBuildInfo pkg+                               , UnknownLanguage name <- allLanguages bi ]     unknownExtensions = [ name | bi <- allBuildInfo pkg-                               , UnknownExtension name <- extensions bi ]+                               , UnknownExtension name <- allExtensions bi+                               , name `notElem` map display knownLanguages ]     deprecatedExtensions = nub $ catMaybes       [ find ((==ext) . fst) Extension.deprecatedExtensions       | bi <- allBuildInfo pkg-      , ext <- extensions bi ]+      , ext <- allExtensions bi ]+    languagesUsedAsExtensions =+      [ name | bi <- allBuildInfo pkg+             , UnknownExtension name <- allExtensions bi+             , name `elem` map display knownLanguages ] +    testedWithImpossibleRanges =+      [ Dependency (PackageName (display compiler)) vr+      | (compiler, vr) <- testedWith pkg+      , isNoVersion vr ]++ checkLicense :: PackageDescription -> [PackageCheck] checkLicense pkg =   catMaybes [@@ -424,8 +532,8 @@    , checkFlags ["-fasm"] $       PackageDistInexcusable $-           "'ghc-options: -fasm' is unnecessary and breaks on all "-        ++ "arches except for x86, x86-64 and ppc."+           "'ghc-options: -fasm' is unnecessary and will not work on CPU "+        ++ "architectures other than x86, x86-64, ppc or sparc."    , checkFlags ["-fvia-C"] $       PackageDistSuspicious $@@ -664,19 +772,83 @@  --TODO: use the tar path checks on all the above paths --- | Check that if the package uses new syntax that it declares the--- @\"cabal-version: >= x.y\"@ version correctly.+-- | Check that the package declares the version in the @\"cabal-version\"@+-- field correctly. -- checkCabalVersion :: PackageDescription -> [PackageCheck] checkCabalVersion pkg =   catMaybes [ +    -- check syntax of cabal-version field+    check (specVersion pkg >= Version [1,10] []+           && not simpleSpecVersionRangeSyntax) $+      PackageBuildWarning $+           "Packages relying on Cabal 1.10 or later must only specify a "+        ++ "version range of the form 'cabal-version: >= x.y'. Use "+        ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'."++    -- check syntax of cabal-version field+  , check (specVersion pkg < Version [1,9] []+           && not simpleSpecVersionRangeSyntax) $+      PackageDistSuspicious $+           "It is recommended that the 'cabal-version' field only specify a "+        ++ "version range of the form '>= x.y'. Use "+        ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'. "+        ++ "Tools based on Cabal 1.10 and later will ignore upper bounds."++    -- check syntax of cabal-version field+  , checkVersion [1,12] simpleSpecVersionSyntax $+      PackageBuildWarning $+           "With Cabal 1.10 or earlier, the 'cabal-version' field must use "+        ++ "range syntax rather than a simple version number. Use "+        ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'."++    -- check use of test suite stanzas+  , checkVersion [1,10] (not (null $ testSuites pkg)) $+      PackageDistInexcusable $+           "The package uses test suite stanzas. To use this new syntax, "+        ++ "the package needs to specify at least 'cabal-version: >= 1.10'."++    -- check use of default-language field+    -- note that we do not need to do an equivalent check for the+    -- other-language field since that one does not change behaviour+  , checkVersion [1,10] (any isJust (buildInfoField defaultLanguage)) $+      PackageBuildWarning $+           "To use the 'default-language' field the package needs to specify "+        ++ "at least 'cabal-version: >= 1.10'."++  , check (specVersion pkg >= Version [1,10] []+           && (any isNothing (buildInfoField defaultLanguage))) $+      PackageBuildWarning $+           "Packages using 'cabal-version: >= 1.10' must specify the "+        ++ "'default-language' field for each component (e.g. Haskell98 or "+        ++ "Haskell2010). If a component uses different languages in "+        ++ "different modules then list the other ones in the "+        ++ "'other-languages' field."++    -- check use of default-extensions field+    -- don't need to do the equivalent check for other-extensions+  , checkVersion [1,10] (any (not . null) (buildInfoField defaultExtensions)) $+      PackageBuildWarning $+           "To use the 'default-extensions' field the package needs to specify "+        ++ "at least 'cabal-version: >= 1.10'."++    -- check use of extensions field+  , check (specVersion pkg >= Version [1,10] []+           && (any (not . null) (buildInfoField oldExtensions))) $+      PackageBuildWarning $+           "For packages using 'cabal-version: >= 1.10' the 'extensions' "+        ++ "field is deprecated. The new 'default-extensions' field lists "+        ++ "extensions that are used in all modules in the component, while "+        ++ "the 'other-extensions' field lists extensions that are used in "+        ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma."+     -- check use of "foo (>= 1.0 && < 1.4) || >=1.8 " version-range syntax-    checkVersion [1,8] (not (null versionRangeExpressions)) $+  , checkVersion [1,8] (not (null versionRangeExpressions)) $       PackageDistInexcusable $            "The package uses full version-range expressions "         ++ "in a 'build-depends' field: "-        ++ commaSep (map display versionRangeExpressions)+        ++ commaSep (map displayRawDependency versionRangeExpressions)         ++ ". To use this new syntax the package needs to specify at least "         ++ "'cabal-version: >= 1.8'. Alternatively, if broader compatibility "         ++ "is important, then convert to conjunctive normal form, and use "@@ -693,6 +865,26 @@            [ display (Dependency name (eliminateWildcardSyntax versionRange))            | Dependency name versionRange <- depsUsingWildcardSyntax ] +    -- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax+  , checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $+      PackageDistInexcusable $+           "The package uses full version-range expressions "+        ++ "in a 'tested-with' field: "+        ++ commaSep (map displayRawDependency testedWithVersionRangeExpressions)+        ++ ". To use this new syntax the package needs to specify at least "+        ++ "'cabal-version: >= 1.8'."++    -- check use of "tested-with: GHC == 6.12.*" syntax+  , checkVersion [1,6] (not (null testedWithUsingWildcardSyntax)) $+      PackageDistInexcusable $+           "The package uses wildcard syntax in the 'tested-with' field: "+        ++ commaSep (map display testedWithUsingWildcardSyntax)+        ++ ". To use this new syntax the package need to specify at least "+        ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability "+        ++ "is important then use: " ++ commaSep+           [ display (Dependency name (eliminateWildcardSyntax versionRange))+           | Dependency name versionRange <- testedWithUsingWildcardSyntax ]+     -- check use of "data-files: data/*.txt" syntax   , checkVersion [1,6] (not (null dataFilesUsingGlobSyntax)) $       PackageDistInexcusable $@@ -715,7 +907,7 @@     -- check use of "source-repository" section   , checkVersion [1,6] (not (null (sourceRepos pkg))) $       PackageDistInexcusable $-           "The 'source-repository' section is new in Cabal-1.6. "+           "The 'source-repository' section is new in Cabal 1.6. "         ++ "Unfortunately it messes up the parser in earlier Cabal versions "         ++ "so you need to specify 'cabal-version: >= 1.6'." @@ -728,38 +920,35 @@         ++ "compatability with earlier Cabal versions then use 'OtherLicense'."      -- check for new language extensions-  , checkVersion [1,2,3] (not (null usedExtensionsThatNeedCabal12)) $+  , checkVersion [1,2,3] (not (null mentionedExtensionsThatNeedCabal12)) $       PackageDistInexcusable $            "Unfortunately the language extensions "-        ++ commaSep (map (quote . display) usedExtensionsThatNeedCabal12)+        ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal12)         ++ " break the parser in earlier Cabal versions so you need to "         ++ "specify 'cabal-version: >= 1.2.3'. Alternatively if you require "         ++ "compatability with earlier Cabal versions then you may be able to "         ++ "use an equivalent compiler-specific flag." -  , checkVersion [1,4] (not (null usedExtensionsThatNeedCabal14)) $+  , checkVersion [1,4] (not (null mentionedExtensionsThatNeedCabal14)) $       PackageDistInexcusable $            "Unfortunately the language extensions "-        ++ commaSep (map (quote . display) usedExtensionsThatNeedCabal14)+        ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal14)         ++ " break the parser in earlier Cabal versions so you need to "         ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "         ++ "compatability with earlier Cabal versions then you may be able to "         ++ "use an equivalent compiler-specific flag."   ]   where+    -- Perform a check on packages that use a version of the spec less than+    -- the version given. This is for cases where a new Cabal version adds+    -- a new feature and we want to check that it is not used prior to that+    -- version.     checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck     checkVersion ver cond pc-      | packageName pkg == PackageName "Cabal" = Nothing-      | requiresAtLeast (Version ver []) = Nothing-      | not cond  = Nothing-      | otherwise = Just pc--    requiresAtLeast :: Version -> Bool-    requiresAtLeast = case cabalVersionIntervals of-      (LowerBound ver' _,_):_ -> (ver' >=)-      _                       -> const False-     where cabalVersionIntervals = asVersionIntervals (descCabalVersion pkg)+      | specVersion pkg >= Version ver []      = Nothing+      | otherwise                              = check cond pc +    buildInfoField field         = map field (allBuildInfo pkg)     dataFilesUsingGlobSyntax     = filter usesGlobSyntax (dataFiles pkg)     extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg)     usesGlobSyntax str = case parseFileGlob str of@@ -768,17 +957,49 @@      versionRangeExpressions =         [ dep | dep@(Dependency _ vr) <- buildDepends pkg-              , depth vr > (2::Int) ]-        where depth = foldVersionRange'-                        1 (const 1)-                        (const 1) (const 1)-                        (const 1) (const 1)-                        (const (const 1))-                        (+) (+)+              , usesNewVersionRangeSyntax vr ] +    testedWithVersionRangeExpressions =+        [ Dependency (PackageName (display compiler)) vr+        | (compiler, vr) <- testedWith pkg+        , usesNewVersionRangeSyntax vr ]++    simpleSpecVersionRangeSyntax =+        either (const True)+               (foldVersionRange'+                      True+                      (\_ -> False)+                      (\_ -> False) (\_ -> False)+                      (\_ -> True)  -- >=+                      (\_ -> False)+                      (\_ _ -> False)+                      (\_ _ -> False) (\_ _ -> False)+                      id)+               (specVersionRaw pkg)++    -- is the cabal-version field a simple version number, rather than a range+    simpleSpecVersionSyntax =+      either (const True) (const False) (specVersionRaw pkg)++    usesNewVersionRangeSyntax :: VersionRange -> Bool+    usesNewVersionRangeSyntax =+        (> 2) -- uses the new syntax if depth is more than 2+      . foldVersionRange'+          (1 :: Int)+          (const 1)+          (const 1) (const 1)+          (const 1) (const 1)+          (const (const 1))+          (+) (+)+          (const 3) -- uses new ()'s syntax+     depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg                                     , usesWildcardSyntax vr ] +    testedWithUsingWildcardSyntax = [ Dependency (PackageName (display compiler)) vr+                                    | (compiler, vr) <- testedWith pkg+                                    , usesWildcardSyntax vr ]+     usesWildcardSyntax :: VersionRange -> Bool     usesWildcardSyntax =       foldVersionRange'@@ -786,7 +1007,7 @@         (const False) (const False)         (const False) (const False)         (\_ _ -> True) -- the wildcard case-        (||) (||)+        (||) (||) id      eliminateWildcardSyntax =       foldVersionRange'@@ -794,19 +1015,20 @@         laterVersion earlierVersion         orLaterVersion orEarlierVersion         (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v'))-        intersectVersionRanges unionVersionRanges+        intersectVersionRanges unionVersionRanges id      compatLicenses = [ GPL Nothing, LGPL Nothing, BSD3, BSD4                      , PublicDomain, AllRightsReserved, OtherLicense ] -    usedExtensions = [ ext | bi <- allBuildInfo pkg, ext <- extensions bi ]-    usedExtensionsThatNeedCabal12 =-      nub (filter (`elem` compatExtensionsExtra) usedExtensions)+    mentionedExtensions = [ ext | bi <- allBuildInfo pkg+                                , ext <- allExtensions bi ]+    mentionedExtensionsThatNeedCabal12 =+      nub (filter (`elem` compatExtensionsExtra) mentionedExtensions)      -- As of Cabal-1.4 we can add new extensions without worrying about     -- breaking old versions of cabal.-    usedExtensionsThatNeedCabal14 =-      nub (filter (`notElem` compatExtensions) usedExtensions)+    mentionedExtensionsThatNeedCabal14 =+      nub (filter (`notElem` compatExtensions) mentionedExtensions)      -- The known extensions in Cabal-1.2.3     compatExtensions =@@ -833,6 +1055,39 @@       , ConstrainedClassMethods       ] +-- | A variation on the normal 'Text' instance, shows any ()'s in the original+-- textual syntax. We need to show these otherwise it's confusing to users when+-- we complain of their presense but do not pretty print them!+--+displayRawVersionRange :: VersionRange -> String+displayRawVersionRange =+   Disp.render+ . fst+ . foldVersionRange'                         -- precedence:+     -- All the same as the usual pretty printer, except for the parens+     (         Disp.text "-any"                           , 0 :: Int)+     (\v   -> (Disp.text "==" <> disp v                   , 0))+     (\v   -> (Disp.char '>'  <> disp v                   , 0))+     (\v   -> (Disp.char '<'  <> disp v                   , 0))+     (\v   -> (Disp.text ">=" <> disp v                   , 0))+     (\v   -> (Disp.text "<=" <> disp v                   , 0))+     (\v _ -> (Disp.text "==" <> dispWild v               , 0))+     (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2))+     (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1))+     (\(r,  _ )          -> (Disp.parens r, 0)) -- parens++  where+    dispWild (Version b _) =+           Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))+        <> Disp.text ".*"+    punct p p' | p < p'    = Disp.parens+               | otherwise = id++displayRawDependency :: Dependency -> String+displayRawDependency (Dependency pkg vr) =+  display pkg ++ " " ++ displayRawVersionRange vr++ -- ------------------------------------------------------------ -- * Checks on the GenericPackageDescription -- ------------------------------------------------------------@@ -966,9 +1221,11 @@   setupError      <- checkSetupExists     ops pkg   configureError  <- checkConfigureExists ops pkg   localPathErrors <- checkLocalPathsExist ops pkg+  vcsLocation     <- checkMissingVcsInfo  ops pkg    return $ catMaybes [licenseError, setupError, configureError]         ++ localPathErrors+        ++ vcsLocation  checkLicenseExists :: Monad m => CheckPackageContentOps m                    -> PackageDescription@@ -1023,6 +1280,35 @@            }          | (dir, kind) <- missing ] +checkMissingVcsInfo :: Monad m => CheckPackageContentOps m+                    -> PackageDescription+                    -> m [PackageCheck]+checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do+    vcsInUse <- liftM or $ mapM (doesDirectoryExist ops) repoDirnames+    if vcsInUse+      then return [ PackageDistSuspicious message ]+      else return []+  where+    repoDirnames = [ dirname | repo    <- knownRepoTypes+                             , dirname <- repoTypeDirname repo ]+    message  = "When distributing packages it is encouraged to specify source "+            ++ "control information in the .cabal file using one or more "+            ++ "'source-repository' sections. See the Cabal user guide for "+            ++ "details."++checkMissingVcsInfo _ _ = return []++repoTypeDirname :: RepoType -> [FilePath]+repoTypeDirname Darcs      = ["_darcs"]+repoTypeDirname Git        = [".git"]+repoTypeDirname SVN        = [".svn"]+repoTypeDirname CVS        = ["CVS"]+repoTypeDirname Mercurial  = [".hg"]+repoTypeDirname GnuArch    = [".arch-params"]+repoTypeDirname Bazaar     = [".bzr"]+repoTypeDirname Monotone   = ["_MTN"]+repoTypeDirname _          = []+ -- ------------------------------------------------------------ -- * Checks involving files in the package -- ------------------------------------------------------------@@ -1123,3 +1409,6 @@  commaSep :: [String] -> String commaSep = intercalate ", "++dups :: Ord a => [a] -> [a]+dups xs = [ x | (x:_:_) <- group (sort xs) ]

@@ -1,7 +1,8 @@ {-# OPTIONS -cpp #-} -- OPTIONS required for ghc-6.4.x compat, and must appear first {-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -cpp #-}+-- -fno-warn-deprecations for use of Map.foldWithKey+{-# OPTIONS_GHC -cpp -fno-warn-deprecations #-} {-# OPTIONS_NHC98 -cpp #-} {-# OPTIONS_JHC -fcpp #-} -----------------------------------------------------------------------------@@ -63,7 +64,7 @@          ( GenericPackageDescription(..), PackageDescription(..)          , Library(..), Executable(..), BuildInfo(..)          , Flag(..), FlagName(..), FlagAssignment-         , CondTree(..), ConfVar(..), Condition(..) )+         , CondTree(..), ConfVar(..), Condition(..), TestSuite(..) ) import Distribution.Version          ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) import Distribution.Compiler@@ -139,7 +140,7 @@                                   && compVer `withinRange` vr     interp (Flag  f)   = Left f --- XXX: Add instances and check+-- TODO: Add instances and check -- -- prop_sC_idempotent cond a o = cond' == cond'' --   where@@ -221,9 +222,9 @@ -- assignments. -- -- In case of failure, the _smallest_ number of of missing dependencies is--- returned. [XXX: Could also be specified with a function argument.]+-- returned. [TODO: Could also be specified with a function argument.] ----- XXX: The current algorithm is rather naive.  A better approach would be to:+-- TODO: The current algorithm is rather naive.  A better approach would be to: -- -- * Rule out possible paths, by taking a look at the associated dependencies. --@@ -414,22 +415,33 @@  -- | Collect up the targets in a TargetSet of tagged targets, storing the -- dependencies as we go.-flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(String, Executable)])-flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets+flattenTaggedTargets :: TargetSet PDTagged ->+        (Maybe Library, [(String, Executable)], [(String, TestSuite)])+flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], []) targets   where-    untag (_, Lib _) (Just _, _) = bug "Only one library expected"-    untag (deps, Lib l) (Nothing, exes) = (Just l', exes)+    untag (_, Lib _) (Just _, _, _) = bug "Only one library expected"+    untag (deps, Lib l) (Nothing, exes, tests) = (Just l', exes, tests)       where         l' = l {                 libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }             }-    untag (deps, Exe n e) (mlib, exes)+    untag (deps, Exe n e) (mlib, exes, tests)         | any ((== n) . fst) exes = bug "Exe with same name found"-        | otherwise = (mlib, exes ++ [(n, e')])+        | any ((== n) . fst) tests = bug "Test sharing name of exe found"+        | otherwise = (mlib, exes ++ [(n, e')], tests)       where         e' = e {                 buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps }             }+    untag (deps, Test n t) (mlib, exes, tests)+        | any ((== n) . fst) tests = bug "Test with same name found"+        | any ((== n) . fst) exes = bug "Test sharing name of exe found"+        | otherwise = (mlib, exes, tests ++ [(n, t')])+      where+        t' = t {+            testBuildInfo = (testBuildInfo t)+                { targetBuildDepends = fromDepMap deps }+            }     untag (_, PDNull) x = x  -- actually this should not happen, but let's be liberal  @@ -437,7 +449,7 @@ -- Convert GenericPackageDescription to PackageDescription -- -data PDTagged = Lib Library | Exe String Executable | PDNull deriving Show+data PDTagged = Lib Library | Exe String Executable | Test String TestSuite | PDNull deriving Show  instance Monoid PDTagged where     mempty = PDNull@@ -445,6 +457,7 @@     x `mappend` PDNull = x     Lib l `mappend` Lib l' = Lib (l `mappend` l')     Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e')+    Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t')     _ `mappend` _ = bug "Cannot combine incompatible tags"  -- | Create a package description with all configurations resolved.@@ -481,11 +494,12 @@              -- ^ Either missing dependencies or the resolved package              -- description along with the flag assignments chosen. finalizePackageDescription userflags satisfyDep (Platform arch os) impl constraints-        (GenericPackageDescription pkg flags mlib0 exes0) =+        (GenericPackageDescription pkg flags mlib0 exes0 tests0) =     case resolveFlags of-      Right ((mlib, exes'), targetSet, flagVals) ->+      Right ((mlib, exes', tests'), targetSet, flagVals) ->         Right ( pkg { library = mlib                     , executables = exes'+                    , testSuites = tests'                     , buildDepends = fromDepMap (overallDependencies targetSet)                       --TODO: we need to find a way to avoid pulling in deps                       -- for non-buildable components. However cannot simply@@ -496,16 +510,18 @@        Left missing -> Left missing   where-    -- Combine lib and exes into one list of @CondTree@s with tagged data+    -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data     condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 )                 ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0+                ++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0      resolveFlags =         case resolveWithFlags flagChoices os arch impl constraints condTrees check of           Right (targetSet, fs) ->-              let (mlib, exes) = flattenTaggedTargets targetSet in+              let (mlib, exes, tests) = flattenTaggedTargets targetSet in               Right ( (fmap libFillInDefaults mlib,-                       map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes),+                       map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes,+                       map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests),                      targetSet, fs)           Left missing      -> Left missing @@ -537,17 +553,18 @@ -- joined into one field, which may not be possible in the original package -- description, due to the use of exclusive choices (if ... else ...). ----- XXX: One particularly tricky case is defaulting.  In the original package+-- TODO: One particularly tricky case is defaulting.  In the original package -- description, e.g., the source directory might either be the default or a -- certain, explicitly set path.  Since defaults are filled in only after the -- package has been resolved and when no explicit value has been set, the -- default path will be missing from the package description returned by this -- function. flattenPackageDescription :: GenericPackageDescription -> PackageDescription-flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0) =+flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0) =     pkg { library = mlib         , executables = reverse exes-        , buildDepends = ldeps ++ reverse edeps+        , testSuites = reverse tests+        , buildDepends = ldeps ++ reverse edeps ++ reverse tdeps         }   where     (mlib, ldeps) = case mlib0 of@@ -555,9 +572,13 @@                     (Just (libFillInDefaults l), ds)         Nothing -> (Nothing, [])     (exes, edeps) = foldr flattenExe ([],[]) exes0+    (tests, tdeps) = foldr flattenTst ([],[]) tests0     flattenExe (n, t) (es, ds) =         let (e, ds') = ignoreConditions t in         ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds )+    flattenTst (n, t) (es, ds) =+        let (e, ds') = ignoreConditions t in+        ( (testFillInDefaults $ e { testName = n }) : es, ds' ++ ds )  -- This is in fact rather a hack.  The original version just overrode the -- default values, however, when adding conditions we had to switch to a@@ -573,6 +594,10 @@ exeFillInDefaults :: Executable -> Executable exeFillInDefaults exe@(Executable { buildInfo = bi }) =     exe { buildInfo = biFillInDefaults bi }++testFillInDefaults :: TestSuite -> TestSuite+testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) =+    tst { testBuildInfo = biFillInDefaults bi }  biFillInDefaults :: BuildInfo -> BuildInfo biFillInDefaults bi =

@@ -62,21 +62,25 @@  import Data.Char  (isSpace) import Data.Maybe (listToMaybe, isJust)+import Data.Monoid ( Monoid(..) ) import Data.List  (nub, unfoldr, partition, (\\)) import Control.Monad (liftM, foldM, when, unless) import System.Directory (doesFileExist)  import Distribution.Text          ( Text(disp, parse), display, simpleParse )+import Distribution.Compat.ReadP+         ((+++), option) import Text.PrettyPrint.HughesPJ  import Distribution.ParseUtils hiding (parseFields) import Distribution.PackageDescription import Distribution.Package-         ( PackageName(..), PackageIdentifier(..), Dependency(..)-         , packageName, packageVersion )+         ( PackageIdentifier(..), Dependency(..), packageName, packageVersion )+import Distribution.ModuleName ( ModuleName ) import Distribution.Version-        ( anyVersion, isAnyVersion, withinRange )+        ( Version(Version), orLaterVersion+        , LowerBound(..), asVersionIntervals ) import Distribution.Verbosity (Verbosity) import Distribution.Compiler  (CompilerFlavor(..)) import Distribution.PackageDescription.Configuration (parseCondition, freeVars)@@ -98,8 +102,8 @@            disp                   parse            packageVersion         (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}})  , simpleField "cabal-version"-           disp                   parse-           descCabalVersion       (\v pkg -> pkg{descCabalVersion=v})+           (either disp disp)     (liftM Left parse +++ liftM Right parse)+           specVersionRaw         (\v pkg -> pkg{specVersionRaw=v})  , simpleField "build-type"            (maybe empty disp)     (fmap Just parse)            buildType              (\t pkg -> pkg{buildType=t})@@ -207,6 +211,94 @@ storeXFieldsExe _ _ = Nothing  -- ---------------------------------------------------------------------------+-- The TestSuite type++-- | An intermediate type just used for parsing the test-suite stanza.+-- After validation it is converted into the proper 'TestSuite' type.+data TestSuiteStanza = TestSuiteStanza {+       testStanzaTestType   :: Maybe TestType,+       testStanzaMainIs     :: Maybe FilePath,+       testStanzaTestModule :: Maybe ModuleName,+       testStanzaBuildInfo  :: BuildInfo+     }++emptyTestStanza :: TestSuiteStanza+emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty++testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza]+testSuiteFieldDescrs =+    [ simpleField "type"+        (maybe empty disp)    (fmap Just parse)+        testStanzaTestType    (\x suite -> suite { testStanzaTestType = x })+    , simpleField "main-is"+        (maybe empty showFilePath)  (fmap Just parseFilePathQ)+        testStanzaMainIs      (\x suite -> suite { testStanzaMainIs = x })+    , simpleField "test-module"+        (maybe empty disp)    (fmap Just parseModuleNameQ)+        testStanzaTestModule  (\x suite -> suite { testStanzaTestModule = x })+    ]+    ++ map biToTest binfoFieldDescrs+  where+    biToTest = liftField testStanzaBuildInfo+                         (\bi suite -> suite { testStanzaBuildInfo = bi })++storeXFieldsTest :: UnrecFieldParser TestSuiteStanza+storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) =+    Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}+storeXFieldsTest _ _ = Nothing++validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite+validateTestSuite line stanza =+    case testStanzaTestType stanza of+      Nothing ->+        syntaxError line $+             "The 'type' field is required for test suites. "+          ++ "The available test types are: "+          ++ intercalate ", " (map display knownTestTypes)++      Just tt@(TestTypeUnknown _ _) ->+        return emptyTestSuite {+          testInterface = TestSuiteUnsupported tt,+          testBuildInfo = testStanzaBuildInfo stanza+        }++      Just tt | tt `notElem` knownTestTypes ->+        return emptyTestSuite {+          testInterface = TestSuiteUnsupported tt,+          testBuildInfo = testStanzaBuildInfo stanza+        }++      Just tt@(TestTypeExe ver) ->+        case testStanzaMainIs stanza of+          Nothing   -> syntaxError line (missingField "main-is" tt)+          Just file -> do+            when (isJust (testStanzaTestModule stanza)) $+              warning (extraField "test-module" tt)+            return emptyTestSuite {+              testInterface = TestSuiteExeV10 ver file,+              testBuildInfo = testStanzaBuildInfo stanza+            }++      Just tt@(TestTypeLib ver) ->+        case testStanzaTestModule stanza of+          Nothing      -> syntaxError line (missingField "test-module" tt)+          Just module_ -> do+            when (isJust (testStanzaMainIs stanza)) $+              warning (extraField "main-is" tt)+            return emptyTestSuite {+              testInterface = TestSuiteLibV09 ver module_,+              testBuildInfo = testStanzaBuildInfo stanza+            }++  where+    missingField name tt = "The '" ++ name ++ "' field is required for the "+                        ++ display tt ++ " test suite type."++    extraField   name tt = "The '" ++ name ++ "' field is not used for the '"+                        ++ display tt ++ "' test suite type."+++-- --------------------------------------------------------------------------- -- The BuildInfo type  @@ -235,9 +327,23 @@  , listField   "c-sources"            showFilePath       parseFilePathQ            cSources           (\paths binfo -> binfo{cSources=paths})++ , simpleField "default-language"+           (maybe empty disp) (option Nothing (fmap Just parseLanguageQ))+           defaultLanguage    (\lang  binfo -> binfo{defaultLanguage=lang})+ , listField   "other-languages"+           disp               parseLanguageQ+           otherLanguages     (\langs binfo -> binfo{otherLanguages=langs})+ , listField   "default-extensions"+           disp               parseExtensionQ+           defaultExtensions  (\exts  binfo -> binfo{defaultExtensions=exts})+ , listField   "other-extensions"+           disp               parseExtensionQ+           otherExtensions    (\exts  binfo -> binfo{otherExtensions=exts})  , listField   "extensions"            disp               parseExtensionQ-           extensions         (\exts  binfo -> binfo{extensions=exts})+           oldExtensions      (\exts  binfo -> binfo{oldExtensions=exts})+  , listField   "extra-libraries"            showToken          parseTokenQ            extraLibs          (\xs    binfo -> binfo{extraLibs=xs})@@ -264,7 +370,7 @@            ghcProfOptions        (\val binfo -> binfo{ghcProfOptions=val})  , listField   "ghc-shared-options"            text               parseTokenQ-           ghcProfOptions        (\val binfo -> binfo{ghcSharedOptions=val})+           ghcSharedOptions      (\val binfo -> binfo{ghcSharedOptions=val})  , optsField   "ghc-options"  GHC            options            (\path  binfo -> binfo{options=path})  , optsField   "hugs-options" Hugs@@ -469,10 +575,14 @@                    _ -> parseFail err      let cabalVersionNeeded =-          head $ [ versionRange+          head $ [ minVersionBound versionRange                  | Just versionRange <- [ simpleParse v                                         | F _ "cabal-version" v <- fields0 ] ]-              ++ [anyVersion]+              ++ [Version [0] []]+        minVersionBound versionRange =+          case asVersionIntervals versionRange of+            []                            -> Version [0] []+            ((LowerBound version _, _):_) -> version      handleFutureVersionParseFailure cabalVersionNeeded $ do @@ -507,14 +617,14 @@            -- 'getBody' assumes that the remaining fields only consist of           -- flags, lib and exe sections.-        (repos, flags, mlib, exes) <- getBody+        (repos, flags, mlib, exes, tests) <- getBody         warnIfRest  -- warn if getBody did not parse up to the last field.-        when (not (oldSyntax fields0)) $  -- warn if we use new syntax-          maybeWarnCabalVersion pkg       -- without Cabal >= 1.2-        checkForUndefinedFlags flags mlib exes+          -- warn about using old/new syntax with wrong cabal-version:+        maybeWarnCabalVersion (not $ oldSyntax fields0) pkg+        checkForUndefinedFlags flags mlib exes tests         return $ GenericPackageDescription                    pkg { sourceRepos = repos }-                   flags mlib exes+                   flags mlib exes tests    where     oldSyntax flds = all isSimpleField flds@@ -522,21 +632,37 @@         syntaxError (fst (head tabs)) $           "Do not use tabs for indentation (use spaces instead)\n"           ++ "  Tabs were used at (line,column): " ++ show tabs-    maybeWarnCabalVersion pkg =-        when (packageName pkg /= PackageName "Cabal" -- supress warning for Cabal-           && isAnyVersion (descCabalVersion pkg)) $-          lift $ warning $-            "A package using section syntax should require\n"-            ++ "\"Cabal-Version: >= 1.2\" or equivalent." +    maybeWarnCabalVersion newsyntax pkg+      | newsyntax && specVersion pkg < Version [1,2] []+      = lift $ warning $+             "A package using section syntax must specify at least\n"+          ++ "'cabal-version: >= 1.2'."++    maybeWarnCabalVersion newsyntax pkg+      | not newsyntax && specVersion pkg >= Version [1,2] []+      = lift $ warning $+             "A package using 'cabal-version: "+          ++ displaySpecVersion (specVersionRaw pkg)+          ++ "' must use section syntax. See the Cabal user guide for details."+      where+        displaySpecVersion (Left version)       = display version+        displaySpecVersion (Right versionRange) =+          case asVersionIntervals versionRange of+            [] {- impossible -}           -> display versionRange+            ((LowerBound version _, _):_) -> display (orLaterVersion version)++    maybeWarnCabalVersion _ _ = return ()++     handleFutureVersionParseFailure cabalVersionNeeded parseBody =       (unless versionOk (warning message) >> parseBody)         `catchParseError` \parseError -> case parseError of         TabsError _   -> parseFail parseError         _ | versionOk -> parseFail parseError           | otherwise -> fail message-      where versionOk = cabalVersion `withinRange` cabalVersionNeeded-            message   = "This package requires Cabal version: "+      where versionOk = cabalVersionNeeded <= cabalVersion+            message   = "This package requires at least Cabal version "                      ++ display cabalVersionNeeded      -- "Sectionize" an old-style Cabal file.  A sectionized file has:@@ -598,13 +724,14 @@         _ -> return (reverse acc)      ---    -- body ::= { repo | flag | library | executable }+   -- at most one lib+    -- body ::= { repo | flag | library | executable | test }+   -- at most one lib     --     -- The body consists of an optional sequence of declarations of flags and     -- an arbitrary number of executables and at most one library.     getBody :: PM ([SourceRepo], [Flag]                   ,Maybe (CondTree ConfVar [Dependency] Library)-                  ,[(String, CondTree ConfVar [Dependency] Executable)])+                  ,[(String, CondTree ConfVar [Dependency] Executable)]+                  ,[(String, CondTree ConfVar [Dependency] TestSuite)])     getBody = peekField >>= \mf -> case mf of       Just (Section line_no sec_type sec_label sec_fields)         | sec_type == "executable" -> do@@ -613,18 +740,27 @@             exename <- lift $ runP line_no "executable" parseTokenQ sec_label             flds <- collectFields parseExeFields sec_fields             skipField-            (repos, flags, lib, exes) <- getBody-            return (repos, flags, lib, exes ++ [(exename, flds)])+            (repos, flags, lib, exes, tests) <- getBody+            return (repos, flags, lib, exes ++ [(exename, flds)], tests) +        | sec_type == "test-suite" -> do+            when (null sec_label) $ lift $ syntaxError line_no+                "'test-suite' needs one argument (the test suite's name)"+            testname <- lift $ runP line_no "test" parseTokenQ sec_label+            flds <- collectFields (parseTestFields line_no) sec_fields+            skipField+            (repos, flags, lib, exes, tests) <- getBody+            return (repos, flags, lib, exes, tests ++ [(testname, flds)])+         | sec_type == "library" -> do             when (not (null sec_label)) $ lift $               syntaxError line_no "'library' expects no argument"             flds <- collectFields parseLibFields sec_fields             skipField-            (repos, flags, lib, exes) <- getBody+            (repos, flags, lib, exes, tests) <- getBody             when (isJust lib) $ lift $ syntaxError line_no               "There can only be one library section in a package description."-            return (repos, flags, Just flds, exes)+            return (repos, flags, Just flds, exes, tests)          | sec_type == "flag" -> do             when (null sec_label) $ lift $@@ -635,8 +771,8 @@                     (MkFlag (FlagName (lowercase sec_label)) "" True False)                     sec_fields             skipField-            (repos, flags, lib, exes) <- getBody-            return (repos, flag:flags, lib, exes)+            (repos, flags, lib, exes, tests) <- getBody+            return (repos, flag:flags, lib, exes, tests)          | sec_type == "source-repository" -> do             when (null sec_label) $ lift $ syntaxError line_no $@@ -660,8 +796,8 @@                     })                     sec_fields             skipField-            (repos, flags, lib, exes) <- getBody-            return (repo:repos, flags, lib, exes)+            (repos, flags, lib, exes, tests) <- getBody+            return (repo:repos, flags, lib, exes, tests)          | otherwise -> do             lift $ warning $ "Ignoring unknown section type: " ++ sec_type@@ -672,7 +808,7 @@               "Construct not supported at this position: " ++ show f             skipField             getBody-      Nothing -> return ([], [], Nothing, [])+      Nothing -> return ([], [], Nothing, [], [])      -- Extracts all fields in a block and returns a 'CondTree'.     --@@ -710,18 +846,27 @@     parseLibFields :: [Field] -> PM Library     parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary +    -- Note: we don't parse the "executable" field here, hence the tail hack.     parseExeFields :: [Field] -> PM Executable-    parseExeFields = lift . parseFields executableFieldDescrs storeXFieldsExe emptyExecutable+    parseExeFields = lift . parseFields (tail executableFieldDescrs) storeXFieldsExe emptyExecutable +    parseTestFields :: LineNo -> [Field] -> PM TestSuite+    parseTestFields line fields = do+        x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest+                                emptyTestStanza fields+        lift $ validateTestSuite line x+     checkForUndefinedFlags ::         [Flag] ->         Maybe (CondTree ConfVar [Dependency] Library) ->         [(String, CondTree ConfVar [Dependency] Executable)] ->+        [(String, CondTree ConfVar [Dependency] TestSuite)] ->         PM ()-    checkForUndefinedFlags flags mlib exes = do+    checkForUndefinedFlags flags mlib exes tests = do         let definedFlags = map flagName flags         maybe (return ()) (checkCondTreeFlags definedFlags) mlib         mapM_ (checkCondTreeFlags definedFlags . snd) exes+        mapM_ (checkCondTreeFlags definedFlags . snd) tests      checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()     checkCondTreeFlags definedFlags ct = do@@ -824,6 +969,8 @@ writePackageDescription :: FilePath -> PackageDescription -> IO () writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) +--TODO: make this use section syntax+-- add equivalent for GenericPackageDescription showPackageDescription :: PackageDescription -> String showPackageDescription pkg = render $      ppPackage pkg

@@ -57,7 +57,7 @@         parseFilePathQ, parseTokenQ, parseTokenQ',         parseModuleNameQ, parseBuildTool, parsePkgconfigDependency,         parseOptVersion, parsePackageNameQ, parseVersionRangeQ,-        parseTestedWithQ, parseLicenseQ, parseExtensionQ,+        parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ,         parseSepList, parseCommaList, parseOptCommaList,         showFilePath, showToken, showTestedWith, showFreeText, parseFreeText,         field, simpleField, listField, spaceListField, commaListField,@@ -78,7 +78,8 @@          ( Text(..) ) import Distribution.Simple.Utils          ( intercalate, lowercase, normaliseLineEndings )-import Language.Haskell.Extension (Extension)+import Language.Haskell.Extension+         ( Language, Extension )  import Text.PrettyPrint.HughesPJ hiding (braces) import Data.Char (isSpace, toLower, isAlphaNum, isDigit)@@ -597,16 +598,19 @@  parseOptVersion :: ReadP r Version parseOptVersion = parseQuoted ver <++ ver-  where ver = parse <++ return noVersion+  where ver :: ReadP r Version+        ver = parse <++ return noVersion         noVersion = Version{ versionBranch=[], versionTags=[] }  parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) parseTestedWithQ = parseQuoted tw <++ tw-  where tw = do compiler <- parseCompilerFlavorCompat-                skipSpaces-                version <- parse <++ return anyVersion-                skipSpaces-                return (compiler,version)+  where +    tw :: ReadP r (CompilerFlavor,VersionRange)+    tw = do compiler <- parseCompilerFlavorCompat+            skipSpaces+            version <- parse <++ return anyVersion+            skipSpaces+            return (compiler,version)  parseLicenseQ :: ReadP r License parseLicenseQ = parseQuoted parse <++ parse@@ -615,6 +619,9 @@ -- because the "compat" version of ReadP isn't quite powerful enough.  In -- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a -- Hence the trick above to make 'lic' polymorphic.++parseLanguageQ :: ReadP r Language+parseLanguageQ = parseQuoted parse <++ parse  parseExtensionQ :: ReadP r Extension parseExtensionQ = parseQuoted parse <++ parse

@@ -54,6 +54,15 @@ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} +{-+Work around this warning:+libraries/Cabal/Distribution/Simple.hs:78:0:+    Warning: In the use of `runTests'+             (imported from Distribution.Simple.UserHooks):+             Deprecated: "Please use the new testing interface instead!"+-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}+ module Distribution.Simple (         module Distribution.Package,         module Distribution.Version,@@ -99,11 +108,12 @@  import Distribution.Simple.Configure          ( getPersistBuildConfig, maybeGetPersistBuildConfig-         , writePersistBuildConfig, checkPersistBuildConfig+         , writePersistBuildConfig, checkPersistBuildConfigOutdated          , configure, checkForeignDeps )  import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) import Distribution.Simple.BuildPaths ( srcPref)+import Distribution.Simple.Test (test) import Distribution.Simple.Install (install) import Distribution.Simple.Haddock (haddock, hscolour) import Distribution.Simple.Utils@@ -184,7 +194,8 @@      progs = addKnownPrograms (hookedPrograms hooks) defaultProgramConfiguration     commands =-      [configureCommand progs `commandAddAction` configureAction    hooks+      [configureCommand progs `commandAddAction` \fs as ->+                                                 configureAction    hooks fs as >> return ()       ,buildCommand     progs `commandAddAction` buildAction        hooks       ,installCommand         `commandAddAction` installAction      hooks       ,copyCommand            `commandAddAction` copyAction         hooks@@ -207,7 +218,7 @@       overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler]       overridesPP = unionBy (\x y -> fst x == fst y) -configureAction :: UserHooks -> ConfigFlags -> Args -> IO ()+configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo configureAction hooks flags args = do                 let distPref = fromFlag $ configDistPref flags                 pbi <- preConf hooks args flags@@ -224,11 +235,16 @@                 localbuildinfo0 <- confHook hooks epkg_descr flags                  -- remember the .cabal filename if we know it-                let localbuildinfo = localbuildinfo0{ pkgDescrFile = mb_pd_file }+                -- and all the extra command line args+                let localbuildinfo = localbuildinfo0 {+                                       pkgDescrFile = mb_pd_file,+                                       extraConfigArgs = args+                                     }                 writePersistBuildConfig distPref localbuildinfo                  let pkg_descr = localPkgDescr localbuildinfo                 postConf hooks args flags pkg_descr localbuildinfo+                return localbuildinfo               where                 verbosity = fromFlag (configVerbosity flags)                 confPkgDescr :: IO (Maybe FilePath, GenericPackageDescription)@@ -246,7 +262,7 @@   let distPref  = fromFlag $ buildDistPref flags       verbosity = fromFlag $ buildVerbosity flags -  lbi <- getBuildConfig hooks distPref+  lbi <- getBuildConfig hooks verbosity distPref   progs <- reconfigurePrograms verbosity              (buildProgramPaths flags)              (buildProgramArgs flags)@@ -258,9 +274,10 @@  hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () hscolourAction hooks flags args-    = do let distPref = fromFlag $ hscolourDistPref flags+    = do let distPref  = fromFlag $ hscolourDistPref flags+             verbosity = fromFlag $ hscolourVerbosity flags          hookedAction preHscolour hscolourHook postHscolour-                      (getBuildConfig hooks distPref)+                      (getBuildConfig hooks verbosity distPref)                       hooks flags args  haddockAction :: UserHooks -> HaddockFlags -> Args -> IO ()@@ -268,7 +285,7 @@   let distPref  = fromFlag $ haddockDistPref flags       verbosity = fromFlag $ haddockVerbosity flags -  lbi <- getBuildConfig hooks distPref+  lbi <- getBuildConfig hooks verbosity distPref   progs <- reconfigurePrograms verbosity              (haddockProgramPaths flags)              (haddockProgramArgs flags)@@ -293,16 +310,18 @@  copyAction :: UserHooks -> CopyFlags -> Args -> IO () copyAction hooks flags args-    = do let distPref = fromFlag $ copyDistPref flags+    = do let distPref  = fromFlag $ copyDistPref flags+             verbosity = fromFlag $ copyVerbosity flags          hookedAction preCopy copyHook postCopy-                      (getBuildConfig hooks distPref)+                      (getBuildConfig hooks verbosity distPref)                       hooks flags args  installAction :: UserHooks -> InstallFlags -> Args -> IO () installAction hooks flags args-    = do let distPref = fromFlag $ installDistPref flags+    = do let distPref  = fromFlag $ installDistPref flags+             verbosity = fromFlag $ installVerbosity flags          hookedAction preInst instHook postInst-                      (getBuildConfig hooks distPref)+                      (getBuildConfig hooks verbosity distPref)                       hooks flags args  sdistAction :: UserHooks -> SDistFlags -> Args -> IO ()@@ -322,23 +341,35 @@  testAction :: UserHooks -> TestFlags -> Args -> IO () testAction hooks flags args = do-                let distPref = fromFlag $ testDistPref flags-                localbuildinfo <- getBuildConfig hooks distPref-                let pkg_descr = localPkgDescr localbuildinfo-                runTests hooks args False pkg_descr localbuildinfo+    let distPref  = fromFlag $ testDistPref flags+        verbosity = fromFlag $ testVerbosity flags+    localBuildInfo <- getBuildConfig hooks verbosity distPref+    let pkg_descr = localPkgDescr localBuildInfo+    -- It is safe to do 'runTests' before the new test handler because the+    -- default action is a no-op and if the package uses the old test interface+    -- the new handler will find no tests.+    runTests hooks args False pkg_descr localBuildInfo+    --FIXME: this is a hack, passing the args inside the flags+    -- it's because the args to not get passed to the main test hook+    let flags' = flags { testList = Flag args }+    hookedAction preTest testHook postTest+            (getBuildConfig hooks verbosity distPref)+            hooks flags' args  registerAction :: UserHooks -> RegisterFlags -> Args -> IO () registerAction hooks flags args-    = do let distPref = fromFlag $ regDistPref flags+    = do let distPref  = fromFlag $ regDistPref flags+             verbosity = fromFlag $ regVerbosity flags          hookedAction preReg regHook postReg-                      (getBuildConfig hooks distPref)+                      (getBuildConfig hooks verbosity distPref)                       hooks flags args  unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () unregisterAction hooks flags args-    = do let distPref = fromFlag $ regDistPref flags+    = do let distPref  = fromFlag $ regDistPref flags+             verbosity = fromFlag $ regVerbosity flags          hookedAction preUnreg unregHook postUnreg-                      (getBuildConfig hooks distPref)+                      (getBuildConfig hooks verbosity distPref)                       hooks flags args  hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo)@@ -354,23 +385,50 @@    let pkg_descr0 = localPkgDescr localbuildinfo    --pkg_descr0 <- get_pkg_descr (get_verbose flags)    let pkg_descr = updatePackageDescription pbi pkg_descr0-   -- XXX: should we write the modified package descr back to the+   -- 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 -getBuildConfig :: UserHooks -> FilePath -> IO LocalBuildInfo-getBuildConfig hooks distPref = do-  lbi <- getPersistBuildConfig distPref-  case pkgDescrFile lbi of-    Nothing -> return ()-    Just pkg_descr_file -> checkPersistBuildConfig distPref pkg_descr_file-  return lbi {+getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo+getBuildConfig hooks verbosity distPref = do+  lbi_wo_programs <- getPersistBuildConfig distPref+  -- Restore info about unconfigured programs, since it is not serialized+  let lbi = lbi_wo_programs {     withPrograms = restoreProgramConfiguration                      (builtinPrograms ++ hookedPrograms hooks)-                     (withPrograms lbi)+                     (withPrograms lbi_wo_programs)   } +  case pkgDescrFile lbi of+    Nothing -> return lbi+    Just pkg_descr_file -> do+      outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file+      if outdated+        then reconfigure pkg_descr_file lbi+        else return lbi++  where+    reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo+    reconfigure pkg_descr_file lbi = do+      notice verbosity $ pkg_descr_file ++ " has been changed. "+                      ++ "Re-configuring with most recently used options. " +                      ++ "If this fails, please run configure manually.\n"+      let cFlags = configFlags lbi+      let cFlags' = cFlags {+            -- Since the list of unconfigured programs is not serialized,+            -- restore it to the same value as normally used at the beginning+            -- of a conigure run:+            configPrograms = restoreProgramConfiguration+                               (builtinPrograms ++ hookedPrograms hooks)+                               (configPrograms cFlags),++            -- Use the current, not saved verbosity level:+            configVerbosity = Flag verbosity+          }+      configureAction hooks cFlags' (extraConfigArgs lbi)++ -- -------------------------------------------------------------------------- -- Cleaning @@ -417,6 +475,7 @@        postConf  = finalChecks,        buildHook = defaultBuildHook,        copyHook  = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params+       testHook = defaultTestHook,        instHook  = defaultInstallHook,        sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h),        cleanHook = \p _ _ f -> clean p f,@@ -537,6 +596,11 @@     Just infoFile -> do       info verbosity $ "Reading parameters from " ++ infoFile       readHookedBuildInfo verbosity infoFile++defaultTestHook :: PackageDescription -> LocalBuildInfo+                -> UserHooks -> TestFlags -> IO ()+defaultTestHook pkg_descr localbuildinfo _ flags =+    test pkg_descr localbuildinfo flags  defaultInstallHook :: PackageDescription -> LocalBuildInfo                    -> UserHooks -> InstallFlags -> IO ()

@@ -57,17 +57,19 @@ import qualified Distribution.Simple.LHC  as LHC import qualified Distribution.Simple.NHC  as NHC import qualified Distribution.Simple.Hugs as Hugs+import qualified Distribution.Simple.UHC  as UHC  import qualified Distribution.Simple.Build.Macros      as Build.Macros import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule  import Distribution.Package-         ( Package(..), PackageId, InstalledPackageId(..) )+         ( Package(..), PackageName(..), PackageIdentifier(..)+         , thisPackageVersion ) import Distribution.Simple.Compiler          ( CompilerFlavor(..), compilerFlavor, PackageDB(..) ) import Distribution.PackageDescription-         ( PackageDescription(..), BuildInfo(..)-         , Library(..), Executable(..) )+         ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)+         , TestSuite(..), TestSuiteInterface(..) ) import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.ModuleName as ModuleName @@ -77,11 +79,13 @@          ( preprocessSources, PPSuffixHandler ) import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(compiler, buildDir, withPackageDB)-         , ComponentLocalBuildInfo, withLibLBI, withExeLBI )+         , ComponentLocalBuildInfo(..), withLibLBI, withExeLBI+         , inplacePackageId, withTestLBI ) import Distribution.Simple.BuildPaths          ( autogenModulesDir, autogenModuleName, cppHeaderName ) import Distribution.Simple.Register          ( registerPackage, inplaceInstalledPackageInfo )+import Distribution.Simple.Test ( stubFilePath, stubName ) import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, rewriteFile          , die, info, setupMessage )@@ -130,7 +134,8 @@             IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo)           }     registerPackage verbosity-      installedPkgInfo pkg_descr lbi True{-inplace-} internalPackageDB+      installedPkgInfo pkg_descr lbi True -- True meaning inplace+      (withPackageDB lbi ++ [internalPackageDB])    -- Use the internal package db for the exes.   let lbi' = lbi { withPackageDB = withPackageDB lbi ++ [internalPackageDB] }@@ -139,10 +144,64 @@     info verbosity $ "Building executable " ++ exeName exe ++ "..."     buildExe verbosity pkg_descr lbi' exe clbi --- Quick hack in 1.8 branch, it's done properly in HEAD-inplacePackageId :: PackageId -> InstalledPackageId-inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace")+  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+                        }+                    , 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. createInternalPackageDB :: FilePath -> IO PackageDB@@ -152,6 +211,8 @@     writeFile dbFile "[]"     return packageDB +-- TODO: build separate libs in separate dirs so that we can build+-- multiple libs, e.g. for 'LibTest' library-style testsuites buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo                       -> Library            -> ComponentLocalBuildInfo -> IO () buildLib verbosity pkg_descr lbi lib clbi =@@ -161,6 +222,7 @@     LHC  -> LHC.buildLib  verbosity pkg_descr lbi lib clbi     Hugs -> Hugs.buildLib verbosity pkg_descr lbi lib clbi     NHC  -> NHC.buildLib  verbosity pkg_descr lbi lib clbi+    UHC  -> UHC.buildLib  verbosity pkg_descr lbi lib clbi     _    -> die "Building is not supported with this compiler."  buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo@@ -172,6 +234,7 @@     LHC  -> LHC.buildExe  verbosity pkg_descr lbi exe clbi     Hugs -> Hugs.buildExe verbosity pkg_descr lbi exe clbi     NHC  -> NHC.buildExe  verbosity pkg_descr lbi exe clbi+    UHC  -> UHC.buildExe  verbosity pkg_descr lbi exe clbi     _    -> die "Building is not supported with this compiler."  initialBuildSteps :: FilePath -- ^"dist" prefix

@@ -10,6 +10,7 @@ -- -- When using CPP you get --+-- > VERSION_<package> -- > MIN_VERSION_<package>(A,B,C) -- -- for each /package/ in @build-depends@, which is true if the version of@@ -40,6 +41,7 @@   "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" :   [ concat     ["/* package ",display pkgid," */\n"+    ,"#define VERSION_",pkgname," ",show (display version),"\n"     ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n"     ,"  (major1) <  ",major1," || \\\n"     ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"

@@ -15,7 +15,7 @@ -- at runtime. This code should probably be split off into another module. -- module Distribution.Simple.Build.PathsModule (-    generate+    generate, pkgPathEnvVar   ) where  import Distribution.System@@ -142,10 +142,7 @@          mkGetEnvOr var expr = "catch (getEnv \""++var'++"\")"++                               " (\\_ -> "++expr++")"-          where var' = showPkgName (packageName pkg_descr) ++ "_" ++ var-                showPkgName = map fixchar . display-                fixchar '-' = '_'-                fixchar c   = c+          where var' = pkgPathEnvVar pkg_descr var          -- In several cases we cannot make relocatable installations         absolute =@@ -175,6 +172,19 @@           compilerFlavor (compiler lbi) == GHC &&             (compilerVersion (compiler lbi)               `withinRange` orLaterVersion (Version [6,6,1] []))++-- | Generates the name of the environment variable controlling the path+-- component of interest.+pkgPathEnvVar :: PackageDescription+              -> String     -- ^ path component; one of \"bindir\", \"libdir\",+                            -- \"datadir\" or \"libexecdir\"+              -> String     -- ^ environment variable name+pkgPathEnvVar pkg_descr var =+    showPkgName (packageName pkg_descr) ++ "_" ++ var+    where+        showPkgName = map fixchar . display+        fixchar '-' = '_'+        fixchar c   = c  get_prefix_win32 :: String get_prefix_win32 =

@@ -64,6 +64,8 @@          -- * Support for language extensions         Flag,+        languageToFlags,+        unsupportedLanguages,         extensionsToFlags,         unsupportedExtensions   ) where@@ -71,13 +73,14 @@ import Distribution.Compiler import Distribution.Version (Version(..)) import Distribution.Text (display)-import Language.Haskell.Extension (Extension(..))+import Language.Haskell.Extension (Language(Haskell98), Extension)  import Data.List (nub) import Data.Maybe (catMaybes, isNothing)  data Compiler = Compiler {         compilerId              :: CompilerId,+        compilerLanguages       :: [(Language, String)],         compilerExtensions      :: [(Extension, String)]     }     deriving (Show, Read)@@ -105,7 +108,7 @@ data PackageDB = GlobalPackageDB                | UserPackageDB                | SpecificPackageDB FilePath-    deriving (Eq, Show, Read)+    deriving (Eq, Ord, Show, Read)  -- | We typically get packages from several databases, and stack them -- together. This type lets us be explicit about that stacking. For example@@ -157,8 +160,22 @@   _             -> error $ "Can't parse optimisation level " ++ s  -- --------------------------------------------------------------- * Extensions+-- * Languages and Extensions -- ------------------------------------------------------------++unsupportedLanguages :: Compiler -> [Language] -> [Language]+unsupportedLanguages comp langs =+  [ lang | lang <- langs+         , isNothing (languageToFlag comp lang) ]++languageToFlags :: Compiler -> Maybe Language -> [Flag]+languageToFlags comp = filter (not . null)+                     . catMaybes . map (languageToFlag comp)+                     . maybe [Haskell98] (\x->[x])++languageToFlag :: Compiler -> Language -> Maybe Flag+languageToFlag comp ext = lookup ext (compilerLanguages comp)+  -- |For the given compiler, return the extensions it does not support. unsupportedExtensions :: Compiler -> [Extension] -> [Extension]

@@ -53,7 +53,7 @@ module Distribution.Simple.Configure (configure,                                       writePersistBuildConfig,                                       getPersistBuildConfig,-                                      checkPersistBuildConfig,+                                      checkPersistBuildConfigOutdated,                                       maybeGetPersistBuildConfig,                                       localBuildInfoFile,                                       getInstalledPackages,@@ -66,7 +66,8 @@  import Distribution.Simple.Compiler     ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion-    , showCompilerId, unsupportedExtensions, PackageDB(..), PackageDBStack )+    , showCompilerId, unsupportedLanguages, unsupportedExtensions+    , PackageDB(..), PackageDBStack ) import Distribution.Package     ( PackageName(PackageName), PackageIdentifier(PackageIdentifier), PackageId     , packageName, packageVersion, Package(..)@@ -78,12 +79,12 @@ import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.PackageDescription as PD-    ( PackageDescription(..), GenericPackageDescription(..)-    , Library(..), hasLibs, Executable(..), BuildInfo(..)+    ( PackageDescription(..), specVersion, GenericPackageDescription(..)+    , Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions     , HookedBuildInfo, updatePackageDescription, allBuildInfo-    , FlagName(..) )+    , FlagName(..), TestSuite(..) ) import Distribution.PackageDescription.Configuration-    ( finalizePackageDescription )+    ( finalizePackageDescription, flattenPackageDescription ) import Distribution.PackageDescription.Check     ( PackageCheck(..), checkPackage, checkPackageFiles ) import Distribution.Simple.Program@@ -91,7 +92,7 @@     , ProgramConfiguration, defaultProgramConfiguration     , configureAllKnownPrograms, knownPrograms, lookupKnownProgram     , userSpecifyArgss, userSpecifyPaths-    , lookupProgram, requireProgram, requireProgramVersion+    , requireProgram, requireProgramVersion     , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf ) import Distribution.Simple.Setup     ( ConfigFlags(..), CopyDest(..), fromFlag, fromFlagOrDefault, flagToMaybe )@@ -99,18 +100,18 @@     ( InstallDirs(..), defaultInstallDirs, combineInstallDirs ) import Distribution.Simple.LocalBuildInfo     ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-    , absoluteInstallDirs, prefixRelativeInstallDirs )+    , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId )+import Distribution.Simple.BuildPaths+    ( autogenModulesDir ) import Distribution.Simple.Utils     ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose-    , intercalate, cabalVersion, cabalBootstrapping+    , intercalate, cabalVersion     , withFileContents, writeFileAtomic      , withTempFile ) import Distribution.System     ( OS(..), buildOS, buildPlatform ) import Distribution.Version-    ( Version(..), anyVersion, orLaterVersion, withinRange-    , isSpecificVersion, isAnyVersion-    , LowerBound(..), asVersionIntervals )+         ( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion ) import Distribution.Verbosity     ( Verbosity, lessVerbose ) @@ -119,13 +120,14 @@ import qualified Distribution.Simple.LHC  as LHC import qualified Distribution.Simple.NHC  as NHC import qualified Distribution.Simple.Hugs as Hugs+import qualified Distribution.Simple.UHC  as UHC  import Control.Monad     ( when, unless, foldM, filterM ) import Data.List     ( nub, partition, isPrefixOf, inits ) import Data.Maybe-    ( fromMaybe, isNothing )+         ( isNothing, catMaybes ) import Data.Monoid     ( Monoid(..) ) import System.Directory@@ -221,9 +223,7 @@   where  currentCabalId :: PackageIdentifier-currentCabalId = PackageIdentifier (PackageName "Cabal") currentVersion-  where currentVersion | cabalBootstrapping = Version [0] []-                       | otherwise          = cabalVersion+currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion  currentCompilerId :: PackageIdentifier currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName)@@ -244,12 +244,11 @@  -- |Check that localBuildInfoFile is up-to-date with respect to the -- .cabal file.-checkPersistBuildConfig :: FilePath -> FilePath -> IO ()-checkPersistBuildConfig distPref pkg_descr_file = do+checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool+checkPersistBuildConfigOutdated distPref pkg_descr_file = do   t0 <- getModificationTime pkg_descr_file   t1 <- getModificationTime $ localBuildInfoFile distPref-  when (t0 > t1) $-    die (pkg_descr_file ++ " has been changed, please re-configure.")+  return (t0 > t1)  -- |@dist\/setup-config@ localBuildInfoFile :: FilePath -> FilePath@@ -311,16 +310,20 @@                 Installed.sourcePackageId = pid               }             internalPackageSet = PackageIndex.fromList [internalPackage]-        maybeInstalledPackageSet <- getInstalledPackages (lessVerbose verbosity) comp+        installedPackageSet <- getInstalledPackages (lessVerbose verbosity) comp                                       packageDbs programsConfig'          let -- Constraint test function for the solver-            dependencySatisfiable = case maybeInstalledPackageSet of-              Nothing   -> const True -- we do not know what is available so-                                      -- we pretend everything is available-              Just pkgs -> not . null . PackageIndex.lookupDependency pkgs'-                where-                  pkgs' = PackageIndex.insert internalPackage pkgs+            dependencySatisfiable =+                not . null . PackageIndex.lookupDependency pkgs'+              where+                pkgs' = PackageIndex.insert internalPackage installedPackageSet+            pkg_descr0'' =+                --TODO: avoid disabling tests entirely, we otherwise cannot+                -- perform semantic checks, see also checkPackageProblems+                if fromFlag (configTests cfg)+                    then pkg_descr0+                    else pkg_descr0 { condTestSuites = [] }          (pkg_descr0', flags) <-                 case finalizePackageDescription@@ -329,7 +332,7 @@                        Distribution.System.buildPlatform                        (compilerId comp)                        (configConstraints cfg)-                       pkg_descr0+                       pkg_descr0''                 of Right r -> return r                    Left missing ->                        die $ "At least the following dependencies are missing:\n"@@ -349,18 +352,7 @@         checkPackageProblems verbosity pkg_descr0           (updatePackageDescription pbi pkg_descr) -        let installedPackageSet = fromMaybe bogusPackageSet maybeInstalledPackageSet-            -- FIXME: For Hugs, nhc98 and other compilers we do not know what-            -- packages are already installed, so we just make some up, pretend-            -- that they do exist and just hope for the best. We make them up-            -- based on what other package the package we're currently building-            -- happens to depend on. See 'inventBogusPackageInfo' below.-            -- Let's hope they really are installed... :-)-            bogusDependencies = map inventBogusPackageInfo-                                    (buildDepends pkg_descr)-            bogusPackageSet = PackageIndex.fromList bogusDependencies--            selectDependencies =+        let selectDependencies =                 (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ]))               . map (selectDependency internalPackageSet installedPackageSet) @@ -416,8 +408,15 @@         let installDirs = combineInstallDirs fromFlagOrDefault                             defaultDirs (configInstallDirs cfg) -        -- check extensions-        let extlist = nub $ concatMap extensions (allBuildInfo pkg_descr)+        -- check languages and extensions+        let langlist = nub $ catMaybes $ map defaultLanguage (allBuildInfo pkg_descr)+        let langs = unsupportedLanguages comp langlist+        when (not (null langs)) $+          die $ "The package " ++ display (packageId pkg_descr0)+             ++ " requires the following languages which are not "+             ++ "supported by " ++ display (compilerId comp) ++ ": "+             ++ intercalate ", " (map display langs)+        let extlist = nub $ concatMap allExtensions (allBuildInfo pkg_descr)         let exts = unsupportedExtensions comp extlist         when (not (null exts)) $           die $ "The package " ++ display (packageId pkg_descr0)@@ -450,6 +449,8 @@         -- versions of the same package.         let configLib lib = configComponent (libBuildInfo lib)             configExe exe = (exeName exe, configComponent(buildInfo exe))+            configTest test = (testName test,+                    configComponent(testBuildInfo test))             configComponent bi = ComponentLocalBuildInfo {               componentPackageDeps =                 if newPackageDepsBehaviour pkg_descr'@@ -467,6 +468,10 @@                 names = [ name | Dependency name _ <- targetBuildDepends bi ]          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",@@ -475,6 +480,7 @@                                             (configScratchDir cfg),                     libraryConfig       = configLib `fmap` library pkg_descr',                     executableConfigs   = configExe `fmap` executables pkg_descr',+                    testSuiteConfigs    = configTest `fmap` testSuites pkg_descr',                     installedPkgs       = packageDependsIndex,                     pkgDescrFile        = Nothing,                     localPkgDescr       = pkg_descr',@@ -531,25 +537,9 @@           in pkg_descr{ library     = modifyLib        `fmap` library pkg_descr                       , executables = modifyExecutable  `map` executables pkg_descr} --- Quick hack in 1.8 branch, it's done properly in HEAD-inplacePackageId :: PackageId -> InstalledPackageId-inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace")- -- ----------------------------------------------------------------------------- -- Configuring package dependencies --- |Converts build dependencies to a versioned dependency.  only sets--- version information for exact versioned dependencies.-inventBogusPackageInfo :: Dependency -> InstalledPackageInfo-inventBogusPackageInfo (Dependency s vr) =-  emptyInstalledPackageInfo {-    Installed.sourcePackageId = case isSpecificVersion vr of-      -- if they specify the exact version, use that:-      Just v -> PackageIdentifier s v-      -- otherwise, just set it to empty-      Nothing -> PackageIdentifier s (Version [] [])-  }- reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () reportProgram verbosity prog Nothing     = info verbosity $ "No " ++ programName prog ++ " found"@@ -630,16 +620,18 @@  getInstalledPackages :: Verbosity -> Compiler                      -> PackageDBStack -> ProgramConfiguration-                     -> IO (Maybe PackageIndex)+                     -> IO PackageIndex getInstalledPackages verbosity comp packageDBs progconf = do   info verbosity "Reading installed packages..."   case compilerFlavor comp of-    GHC -> Just `fmap` GHC.getInstalledPackages verbosity packageDBs progconf-    Hugs-> Just `fmap`Hugs.getInstalledPackages verbosity packageDBs progconf-    JHC -> Just `fmap` JHC.getInstalledPackages verbosity packageDBs progconf-    LHC -> Just `fmap` LHC.getInstalledPackages verbosity packageDBs progconf-    NHC -> Just `fmap` NHC.getInstalledPackages verbosity packageDBs progconf-    _   -> return Nothing+    GHC -> GHC.getInstalledPackages verbosity packageDBs progconf+    Hugs->Hugs.getInstalledPackages verbosity packageDBs progconf+    JHC -> JHC.getInstalledPackages verbosity packageDBs progconf+    LHC -> LHC.getInstalledPackages verbosity packageDBs progconf+    NHC -> NHC.getInstalledPackages verbosity packageDBs progconf+    UHC -> UHC.getInstalledPackages verbosity comp packageDBs progconf+    flv -> die $ "don't know how to find the installed packages for "+              ++ display flv  -- | Currently the user interface specifies the package dbs to use with just a -- single valued option, a 'PackageDB'. However internally we represent the@@ -664,13 +656,8 @@ -- specified is >= a certain minimum. Otherwise, for compatibility we use the -- old behaviour. newPackageDepsBehaviour :: PackageDescription -> Bool-newPackageDepsBehaviour pkg_descr =-   minVersionRequired >= newPackageDepsBehaviourMinVersion-  where-    minVersionRequired =-      case asVersionIntervals (descCabalVersion pkg_descr) of-        []                      -> Version [0] []-        ((LowerBound v _, _):_) -> v+newPackageDepsBehaviour pkg =+   specVersion pkg >= newPackageDepsBehaviourMinVersion  -- ----------------------------------------------------------------------------- -- Configuring program dependencies@@ -804,9 +791,15 @@                  LHC.configure  verbosity hcPath Nothing ghcConf       Hugs -> Hugs.configure verbosity hcPath hcPkg conf       NHC  -> NHC.configure  verbosity hcPath hcPkg conf+      UHC  -> UHC.configure  verbosity hcPath hcPkg conf       _    -> die "Unknown compiler"  +-- Try to build a test C program which includes every header and links every+-- lib. If that fails, try to narrow it down by preprocessing (only) and linking+-- with individual headers and libs.  If none is the obvious culprit then give a+-- generic error message.+-- TODO: produce a log file from the compiler errors, if any. checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () checkForeignDeps pkg lbi verbosity = do   ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling lucky@@ -822,22 +815,23 @@             ok <- builds (makeProgram headers) args             if ok then success else failure -        -- NOTE: if some package-local header has errors,-        -- we will report that this header is missing.-        -- Maybe additional tests for local headers are needed-        -- for better diagnostics         findOffendingHdr =-            ifBuildsWith allHeaders cppArgs+            ifBuildsWith allHeaders ccArgs                          (return Nothing)                          (go . tail . inits $ allHeaders)             where               go [] = return Nothing       -- cannot happen-              go (hdrs:hdrsInits) = do+              go (hdrs:hdrsInits) =+                    -- Try just preprocessing first                     ifBuildsWith hdrs cppArgs-                                 (go hdrsInits)-                                 (return . Just . last $ hdrs)+                      -- If that works, try compiling too+                      (ifBuildsWith hdrs ccArgs+                        (go hdrsInits)+                        (return . Just . Right . last $ hdrs))+                      (return . Just . Left . last $ hdrs) -              cppArgs = "-c":commonCcArgs -- don't try to link+              cppArgs = "-E":commonCppArgs -- preprocess only+              ccArgs  = "-c":commonCcArgs  -- don't try to link          findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs)                                        (return [])@@ -845,8 +839,8 @@          libExists lib = builds (makeProgram []) (makeLdArgs [lib]) -        commonCcArgs  = programArgs gccProg-                     ++ hcDefines (compiler lbi)+        commonCppArgs = hcDefines (compiler lbi)+                     ++ [ "-I" ++ autogenModulesDir lbi ]                      ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ]                      ++ ["-I."]                      ++ collectField PD.cppOptions@@ -858,6 +852,12 @@                         | dep <- deps                         , opt <- Installed.ccOptions dep ] +        commonCcArgs  = commonCppArgs+                     ++ collectField PD.ccOptions+                     ++ [ opt+                        | dep <- deps+                        , opt <- Installed.ccOptions dep ]+         commonLdArgs  = [ "-L" ++ dir | dir <- collectField PD.extraLibDirs ]                      ++ collectField PD.ldOptions                      ++ [ "-L" ++ dir@@ -872,7 +872,6 @@          collectField f = concatMap f allBi         allBi = allBuildInfo pkg-        Just gccProg = lookupProgram  gccProgram (withPrograms lbi)         deps = PackageIndex.topologicalOrder (installedPkgs lbi)          builds program args = do@@ -888,35 +887,57 @@            `catchIO`   (\_ -> return False)            `catchExit` (\_ -> return False) -        explainErrors Nothing [] = return ()-        explainErrors hdr libs   = die $ unlines $-             (if plural then "Missing dependencies on foreign libraries:"-                        else "Missing dependency on a foreign library:")-           : case hdr of-               Nothing -> []-               Just h  -> ["* Missing header file: " ++ h ]+        explainErrors Nothing [] = return () -- should be impossible!+        explainErrors hdr libs = die $ unlines $+             [ if plural+                 then "Missing dependencies on foreign libraries:"+                 else "Missing dependency on a foreign library:"+             | missing ]+          ++ case hdr of+               Just (Left h) -> ["* Missing (or bad) header file: " ++ h ]+               _             -> []           ++ case libs of                []    -> []                [lib] -> ["* Missing C library: " ++ lib]                _     -> ["* Missing C libraries: " ++ intercalate ", " libs]-          ++ [if plural then messagePlural else messageSingular]+          ++ [if plural then messagePlural else messageSingular | missing]+          ++ case hdr of+               Just (Left  _) -> [ headerCppMessage ]+               Just (Right h) -> [ (if missing then "* " else "")+                                   ++ "Bad header file: " ++ h+                                 , headerCcMessage ]+               _              -> []+           where-            plural = length libs >= 2-            messageSingular =-                 "This problem can usually be solved by installing the system "-              ++ "package that provides this library (you may need the "-              ++ "\"-dev\" version). If the library is already installed "-              ++ "but in a non-standard location then you can use the flags "-              ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "-              ++ "where it is."-            messagePlural =-                 "This problem can usually be solved by installing the system "-              ++ "packages that provide these libraries (you may need the "-              ++ "\"-dev\" versions). If the libraries are already installed "-              ++ "but in a non-standard location then you can use the flags "-              ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "-              ++ "where they are."+            plural  = length libs >= 2+            -- Is there something missing? (as opposed to broken)+            missing = not (null libs)+                   || case hdr of Just (Left _) -> True; _ -> False +        messageSingular =+             "This problem can usually be solved by installing the system "+          ++ "package that provides this library (you may need the "+          ++ "\"-dev\" version). If the library is already installed "+          ++ "but in a non-standard location then you can use the flags "+          ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "+          ++ "where it is."+        messagePlural =+             "This problem can usually be solved by installing the system "+          ++ "packages that provide these libraries (you may need the "+          ++ "\"-dev\" versions). If the libraries are already installed "+          ++ "but in a non-standard location then you can use the flags "+          ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "+          ++ "where they are."+        headerCppMessage =+             "If the header file does exist, it may contain errors that "+          ++ "are caught by the C compiler at the preprocessing stage. "+          ++ "In this case you can re-run configure with the verbosity "+          ++ "flag -v3 to see the error messages."+        headerCcMessage =+             "The header file contains a compile error. "+          ++ "You can re-run configure with the verbosity flag "+          ++ "-v3 to see the error messages from the C compiler."+         --FIXME: share this with the PreProcessor module         hcDefines :: Compiler -> [String]         hcDefines comp =@@ -949,7 +970,7 @@                      -> GenericPackageDescription                      -> PackageDescription                      -> IO ()-checkPackageProblems verbosity gpkg pkg = do+checkPackageProblems verbosity gpkg pkg0 = do   ioChecks      <- checkPackageFiles pkg "."   let pureChecks = checkPackage gpkg (Just pkg)       errors   = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ]@@ -958,3 +979,16 @@     then mapM_ (warn verbosity) warnings     else do mapM_ (hPutStrLn stderr . ("Error: " ++)) errors             exitWith (ExitFailure 1)+  where+    -- TODO: Sigh, this is a fairly unpleasent hack. The issue is that+    -- we want to check test-suite sections even when tests are disabled.+    -- When tests are disabled we have to exclude the test-suite sections+    -- when resolving the conditionals. But the checks we do are done+    -- on the post-resolved form! Ug. A better solution would be either+    -- 1) to do the checks on the pre-resolved form+    -- 2) to resolve in two steps: find a flag assignment, then apply it+    --    that'd allow us to find the flag assingment ignoring tests+    --    but then to apply it anyway.+    -- In the meantime we stick the tests back in before checking by+    -- flattening the pre-resovled form.+    pkg = pkg0 { testSuites = testSuites (flattenPackageDescription gpkg) }

@@ -65,17 +65,18 @@         buildLib, buildExe,         installLib, installExe,         libAbiHash,+        registerPackage,         ghcOptions,-        ghcVerbosityOptions+        ghcVerbosityOptions,+        ghcPackageDbOptions,+        ghcLibDir,  ) where  import qualified Distribution.Simple.GHC.IPI641 as IPI641 import qualified Distribution.Simple.GHC.IPI642 as IPI642-import Distribution.Simple.Setup-         ( CopyFlags(..), fromFlag ) import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..), Executable(..), withExe-         , Library(..), libModules, hcOptions )+         ( PackageDescription(..), BuildInfo(..), Executable(..)+         , Library(..), libModules, hcOptions, usedExtensions, allExtensions ) import Distribution.InstalledPackageInfo          ( InstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo@@ -83,8 +84,8 @@ import Distribution.Simple.PackageIndex (PackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..),-           absoluteInstallDirs )+         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)+         , absoluteInstallDirs ) import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) import Distribution.Simple.BuildPaths import Distribution.Simple.Utils@@ -105,7 +106,7 @@ import Distribution.Simple.Compiler          ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion          , OptimisationLevel(..), PackageDB(..), PackageDBStack-         , Flag, extensionsToFlags )+         , Flag, languageToFlags, extensionsToFlags ) import Distribution.Version          ( Version(..), anyVersion, orLaterVersion ) import Distribution.System@@ -113,7 +114,7 @@ import Distribution.Verbosity import Distribution.Text          ( display, simpleParse )-import Language.Haskell.Extension (Extension(..))+import Language.Haskell.Extension (Language(..), Extension(..))  import Control.Monad            ( unless, when ) import Data.Char                ( isSpace )@@ -154,11 +155,13 @@     ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " "     ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion -  languageExtensions <- getLanguageExtensions verbosity ghcProg+  languages  <- getLanguages verbosity ghcProg+  extensions <- getExtensions verbosity ghcProg    let comp = Compiler {         compilerId             = CompilerId GHC ghcVersion,-        compilerExtensions     = languageExtensions+        compilerLanguages      = languages,+        compilerExtensions     = extensions       }       conf''' = configureToolchain ghcProg conf'' -- configure gcc and ld   return (comp, conf''')@@ -279,8 +282,17 @@         then return ["-x"]         else return [] -getLanguageExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)]-getLanguageExtensions verbosity ghcProg+getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)]+getLanguages _ ghcProg+  -- TODO: should be using --supported-languages rather than hard coding+  | ghcVersion >= Version [7] [] = return [(Haskell98,   "-XHaskell98")+                                          ,(Haskell2010, "-XHaskell2010")]+  | otherwise                    = return [(Haskell98,   "")]+  where+    Just ghcVersion = programVersion ghcProg++getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)]+getExtensions verbosity ghcProg   | ghcVersion >= Version [6,7] [] = do      exts <- rawSystemStdout verbosity (programPath ghcProg)@@ -380,6 +392,11 @@         _  -> index -- No (or multiple) ghc rts package is registered!!                     -- Feh, whatever, the ghc testsuite does some crazy stuff. +ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath+ghcLibDir verbosity lbi =+    (reverse . dropWhile isSpace . reverse) `fmap`+     rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"]+ ghcLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath ghcLibDir' verbosity ghcProg =     (reverse . dropWhile isSpace . reverse) `fmap`@@ -488,7 +505,7 @@              comp (withProfLib lbi) (libBuildInfo lib)    let libTargetDir = pref-      forceVanillaLib = TemplateHaskell `elem` extensions libBi+      forceVanillaLib = TemplateHaskell `elem` allExtensions libBi       -- TH always needs vanilla libs, even when building for profiling    createDirectoryIfMissingVerbose verbosity True libTargetDir@@ -686,7 +703,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` extensions exeBi)+  when (withProfExe lbi && TemplateHaskell `elem` allExtensions exeBi)      (runGhcProg (binArgs False False))    runGhcProg (binArgs True (withProfExe lbi))@@ -791,7 +808,8 @@            NormalOptimisation  -> ["-O"]            MaximumOptimisation -> ["-O2"])      ++ hcOptions GHC bi-     ++ extensionsToFlags (compiler lbi) (extensions bi)+     ++ languageToFlags   (compiler lbi) (defaultLanguage bi)+     ++ extensionsToFlags (compiler lbi) (usedExtensions bi)     where       ghcVer = compilerVersion (compiler lbi) @@ -815,7 +833,7 @@   where     specific (SpecificPackageDB db) = [ "-package-conf", db ]     specific _ = ierror-    ierror     = error "internal error: unexpected package db stack"+    ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)  constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo                    -> FilePath -> FilePath -> Verbosity -> Bool@@ -839,7 +857,7 @@ ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo              -> FilePath -> [String] ghcCcOptions lbi bi clbi odir-     =  ["-I" ++ dir | dir <- PD.includeDirs bi]+     =  ["-I" ++ dir | dir <- odir : PD.includeDirs bi]      ++ ghcPackageDbOptions (withPackageDB lbi)      ++ ghcPackageFlags lbi clbi      ++ ["-optc" ++ opt | opt <- PD.ccOptions bi]@@ -855,26 +873,25 @@ -- Installing  -- |Install executables for GHC.-installExe :: CopyFlags -- ^verbosity+installExe :: Verbosity            -> LocalBuildInfo            -> InstallDirs FilePath -- ^Where to copy the files to            -> FilePath  -- ^Build location            -> (FilePath, FilePath)  -- ^Executable (prefix,suffix)            -> PackageDescription+           -> Executable            -> IO ()-installExe flags lbi installDirs buildPref (progprefix, progsuffix) pkg_descr-    = do let verbosity = fromFlag (copyVerbosity flags)-             binDir = bindir installDirs-         createDirectoryIfMissingVerbose verbosity True binDir-         withExe pkg_descr $ \Executable { exeName = e } -> do-             let exeFileName = e <.> exeExtension-                 fixedExeBaseName = progprefix ++ e ++ progsuffix-                 installBinary dest = do-                     installExecutableFile verbosity-                       (buildPref </> e </> exeFileName)-                       (dest <.> exeExtension)-                     stripExe verbosity lbi exeFileName (dest <.> exeExtension)-             installBinary (binDir </> fixedExeBaseName)+installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do+  let binDir = bindir installDirs+  createDirectoryIfMissingVerbose verbosity True binDir+  let exeFileName = exeName exe <.> exeExtension+      fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix+      installBinary dest = do+          installExecutableFile verbosity+            (buildPref </> exeName exe </> exeFileName)+            (dest <.> exeExtension)+          stripExe verbosity lbi exeFileName (dest <.> exeExtension)+  installBinary (binDir </> fixedExeBaseName)  stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () stripExe verbosity lbi name path = when (stripExes lbi) $@@ -894,39 +911,39 @@        _   -> []  -- |Install for ghc, .hi, .a and, if --with-ghci given, .o-installLib    :: CopyFlags -- ^verbosity+installLib    :: Verbosity               -> LocalBuildInfo               -> FilePath  -- ^install location               -> FilePath  -- ^install location for dynamic librarys               -> FilePath  -- ^Build location-              -> PackageDescription -> IO ()-installLib flags lbi targetDir dynlibTargetDir builtDir-              pkg@PackageDescription{library=Just lib} = do-        -- copy .hi files over:-        let verbosity = fromFlag (copyVerbosity flags)-            copyHelper installFun src dst n = do-              createDirectoryIfMissingVerbose verbosity True dst-              installFun verbosity (src </> n) (dst </> n)-            copy       = copyHelper installOrdinaryFile-            copyShared = copyHelper installExecutableFile-            copyModuleFiles ext =-              findModuleFiles [builtDir] [ext] (libModules lib)-                >>= installOrdinaryFiles verbosity targetDir-        ifVanilla $ copyModuleFiles "hi"-        ifProf    $ copyModuleFiles "p_hi"-        ifShared  $ copyModuleFiles "dyn_hi"+              -> PackageDescription+              -> Library+              -> IO ()+installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do+  -- copy .hi files over:+  let copyHelper installFun src dst n = do+        createDirectoryIfMissingVerbose verbosity True dst+        installFun verbosity (src </> n) (dst </> n)+      copy       = copyHelper installOrdinaryFile+      copyShared = copyHelper installExecutableFile+      copyModuleFiles ext =+        findModuleFiles [builtDir] [ext] (libModules lib)+          >>= installOrdinaryFiles verbosity targetDir+  ifVanilla $ copyModuleFiles "hi"+  ifProf    $ copyModuleFiles "p_hi"+  ifShared  $ copyModuleFiles "dyn_hi" -        -- copy the built library files over:-        ifVanilla $ copy builtDir targetDir vanillaLibName-        ifProf    $ copy builtDir targetDir profileLibName-        ifGHCi    $ copy builtDir targetDir ghciLibName-        ifShared  $ copyShared builtDir dynlibTargetDir sharedLibName+  -- copy the built library files over:+  ifVanilla $ copy builtDir targetDir vanillaLibName+  ifProf    $ copy builtDir targetDir profileLibName+  ifGHCi    $ copy builtDir targetDir ghciLibName+  ifShared  $ copyShared builtDir dynlibTargetDir sharedLibName -        -- run ranlib if necessary:-        ifVanilla $ updateLibArchive verbosity lbi-                                     (targetDir </> vanillaLibName)-        ifProf    $ updateLibArchive verbosity lbi-                                     (targetDir </> profileLibName)+  -- run ranlib if necessary:+  ifVanilla $ updateLibArchive verbosity lbi+                               (targetDir </> vanillaLibName)+  ifProf    $ updateLibArchive verbosity lbi+                               (targetDir </> profileLibName)    where     vanillaLibName = mkLibName pkgid@@ -943,9 +960,6 @@     ifGHCi    = when (hasLib && withGHCiLib    lbi)     ifShared  = when (hasLib && withSharedLib  lbi) -installLib _ _ _ _ _ PackageDescription{library=Nothing}-    = die $ "Internal Error. installLibGHC called with no library."- -- | On MacOS X we have to call @ranlib@ to regenerate the archive index after -- copying. This is because the silly MacOS X linker checks that the archive -- index is not older than the file itself, which means simply@@ -957,3 +971,19 @@     (ranlib, _) <- requireProgram verbosity ranlibProgram (withPrograms lbi)     rawSystemProgram verbosity ranlib [path]   | otherwise = return ()+++-- -----------------------------------------------------------------------------+-- Registering++registerPackage+  :: Verbosity+  -> InstalledPackageInfo+  -> PackageDescription+  -> LocalBuildInfo+  -> Bool+  -> PackageDBStack+  -> IO ()+registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do+  let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)+  HcPkg.reregister verbosity ghcPkg packageDbs (Right installedPkgInfo)

@@ -55,18 +55,21 @@          ( PackageIdentifier, Package(..), packageName ) import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD-         (PackageDescription(..), BuildInfo(..),-          Library(..), hasLibs, withLib,-          Executable(..), withExe)+         ( PackageDescription(..), BuildInfo(..), allExtensions+         , Library(..), hasLibs, withLib+         , Executable(..), withExe ) import Distribution.Simple.Compiler          ( Compiler(..), compilerVersion )+import Distribution.Simple.GHC ( ghcLibDir ) import Distribution.Simple.Program          ( ConfiguredProgram(..), requireProgramVersion-         , rawSystemProgram, rawSystemProgramStdoutConf, rawSystemProgramStdout-         , hscolourProgram, haddockProgram, ghcProgram )+         , rawSystemProgram, rawSystemProgramStdout+         , hscolourProgram, haddockProgram ) import Distribution.Simple.PreProcess (ppCpp', ppUnlit,                                 PPSuffixHandler, runSimplePreProcessor) import Distribution.Simple.Setup+        ( defaultHscolourFlags, Flag(..), flagToMaybe, fromFlag+        , HaddockFlags(..), HscolourFlags(..) ) import Distribution.Simple.Build (initialBuildSteps) import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate,                                         PathTemplateVariable(..),@@ -103,7 +106,6 @@ import Control.Exception (assert) import Data.Monoid import Data.Maybe    ( fromMaybe, listToMaybe )-import Data.Char     (isSpace)  import System.FilePath((</>), (<.>), splitFileName, splitExtension,                        normalise, splitPath, joinPath)@@ -198,18 +200,22 @@             [ fromFlags flags             , fromPackageDescription pkg_descr ] -    withLibLBI pkg_descr lbi $ \lib clbi -> do-        let bi = libBuildInfo lib-        libArgs <- fromLibrary lbi lib clbi-        prepareSources verbosity lbi isVersion2 bi (args `mappend` libArgs) $-             runHaddock verbosity confHaddock+    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 -> do-        let bi = buildInfo exe-        exeArgs <- fromExecutable lbi exe clbi-        prepareSources verbosity lbi  isVersion2 bi (args `mappend` exeArgs) $-             runHaddock verbosity confHaddock+      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'    where     verbosity = flag haddockVerbosity@@ -218,15 +224,14 @@ -- | performs cpp and unlit preprocessing where needed on the files in -- | argTargets, which must have an .hs or .lhs extension. prepareSources :: Verbosity+                  -> FilePath                   -> LocalBuildInfo                   -> Bool            -- haddock == 2.*                   -> BuildInfo                   -> HaddockArgs-                  -> (HaddockArgs -> IO a)-                  -> IO a-prepareSources verbosity lbi isVersion2 bi args@HaddockArgs{argTargets=files} k =-              withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp ->-                   mapM (mockPP tmp) files >>= \targets -> k args {argTargets=targets}+                  -> IO HaddockArgs+prepareSources verbosity tmp lbi isVersion2 bi args@HaddockArgs{argTargets=files} =+              mapM (mockPP tmp) files >>= \targets -> return args {argTargets=targets}           where             mockPP pref file = do                   let (filePref, fileName) = splitFileName file@@ -251,7 +256,7 @@                      removeFile targetFile                   return hsFile-            needsCpp = CPP `elem` extensions bi+            needsCpp = CPP `elem` allExtensions bi             defines | isVersion2 = []                     | otherwise  = ["-D__HADDOCK__"] @@ -287,22 +292,38 @@         subtitle | null (synopsis pkg_descr) = ""                  | otherwise                 = ": " ++ synopsis pkg_descr -fromLibrary :: LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO HaddockArgs-fromLibrary lbi lib clbi =+fromLibrary :: FilePath+            -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo+            -> IO HaddockArgs+fromLibrary tmp lbi lib clbi =             do inFiles <- map snd `fmap` getLibSourceFiles lbi lib                return $ mempty {                             argHideModules = (mempty,otherModules $ bi),-                            argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi),+                            argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi)+                                       -- Noooooooooo!!!!!111+                                       -- haddock stomps on our precious .hi+                                       -- and .o files. Workaround by telling+                                       -- haddock to write them elsewhere.+                                       ++ [ "-odir", tmp, "-hidir", tmp+                                          , "-stubdir", tmp ],                             argTargets = inFiles                            }     where        bi = libBuildInfo lib       -fromExecutable :: LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO HaddockArgs-fromExecutable lbi exe clbi =+fromExecutable :: FilePath+               -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo+               -> IO HaddockArgs+fromExecutable tmp lbi exe clbi =             do inFiles <- map snd `fmap` getExeSourceFiles lbi exe                return $ mempty {-                            argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi),+                            argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi)+                                       -- Noooooooooo!!!!!111+                                       -- haddock stomps on our precious .hi+                                       -- and .o files. Workaround by telling+                                       -- haddock to write them elsewhere.+                                       ++ [ "-odir", tmp, "-hidir", tmp+                                          , "-stubdir", tmp ],                             argOutputDir = Dir (exeName exe),                             argTitle = Flag (exeName exe),                             argTargets = inFiles @@ -546,11 +567,6 @@ -- | The directory where we put build results for an executable exeBuildDir :: LocalBuildInfo -> Executable -> FilePath exeBuildDir lbi exe = buildDir lbi </> exeName exe </> exeName exe ++ "-tmp"--ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath-ghcLibDir verbosity lbi = -    (reverse . dropWhile isSpace . reverse) `fmap`-     rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"]  --------------------------------------------------------------------------------------------- 

@@ -46,24 +46,26 @@     getInstalledPackages,     buildLib,     buildExe,-    install+    install,+    registerPackage,   ) where  import Distribution.Package          ( PackageName, PackageIdentifier(..), InstalledPackageId(..)          , packageName ) import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo+         ( InstalledPackageInfo, emptyInstalledPackageInfo          , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId                                 , sourcePackageId )-         , emptyInstalledPackageInfo, parseInstalledPackageInfo )+         , parseInstalledPackageInfo, showInstalledPackageInfo ) import Distribution.PackageDescription-         ( PackageDescription(..), BuildInfo(..), hcOptions,-           Executable(..), withExe, Library(..), withLib, libModules )+         ( PackageDescription(..), BuildInfo(..), hcOptions, allExtensions+         , Executable(..), withExe, Library(..), withLib, libModules ) import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..), Compiler(..), Flag+         ( CompilerFlavor(..), CompilerId(..)+         , Compiler(..), Flag, languageToFlags, extensionsToFlags          , PackageDB(..), PackageDBStack ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex)@@ -79,18 +81,21 @@ import Distribution.Simple.PreProcess.Unlit                                 ( unlit ) import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) )+         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)+         , InstallDirs(..), absoluteInstallDirs ) import Distribution.Simple.BuildPaths                                 ( autogenModuleName, autogenModulesDir,                                   dllExtension )+import Distribution.Simple.Setup+         ( CopyDest(..) ) import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, installOrdinaryFiles-         , withUTF8FileContents, writeFileAtomic, copyFileVerbose-         , findFile, findFileWithExtension, findModuleFiles+         , withUTF8FileContents, writeFileAtomic, writeUTF8File+         , copyFileVerbose, findFile, findFileWithExtension, findModuleFiles          , rawSystemStdInOut          , die, info, notice ) import Language.Haskell.Extension-                                ( Extension(..) )+         ( Language(Haskell98), Extension(..) ) import System.FilePath          ( (</>), takeExtension, (<.>),                                   searchPathSeparator, normalise, takeDirectory ) import Distribution.System@@ -130,6 +135,7 @@    let comp = Compiler {         compilerId             = CompilerId Hugs version,+        compilerLanguages      = hugsLanguages,         compilerExtensions     = hugsLanguageExtensions       }   return (comp, conf'')@@ -164,6 +170,9 @@     months = [ "January", "February", "March", "April", "May", "June", "July"              , "August", "September", "October", "November", "December" ] +hugsLanguages :: [(Language, Flag)]+hugsLanguages = [(Haskell98, "")] --default is 98 mode+ -- | The flags for the supported extensions hugsLanguageExtensions :: [(Extension, Flag)] hugsLanguageExtensions =@@ -194,9 +203,9 @@ getInstalledPackages verbosity packagedbs conf = do   homedir       <- getHomeDirectory   (hugsProg, _) <- requireProgram verbosity hugsProgram conf-  let bindir = takeDirectory (programPath hugsProg)-      libdir = takeDirectory bindir </> "lib" </> "hugs"-      dbdirs = nub (concatMap (packageDbPaths homedir libdir) packagedbs)+  let hugsbindir = takeDirectory (programPath hugsProg)+      hugslibdir = takeDirectory hugsbindir </> "lib" </> "hugs"+      dbdirs = nub (concatMap (packageDbPaths homedir hugslibdir) packagedbs)   indexes  <- mapM getIndividualDBPackages dbdirs   return $! mconcat indexes @@ -312,6 +321,8 @@   where     paths_modulename = ModuleName.toFilePath (autogenModuleName pkg_descr)                          <.> ".hs"+    --TODO: switch to using autogenModulesDir as a search dir, rather than+    --      always copying the file over.  -- |Building an executable for Hugs. buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo@@ -326,7 +337,7 @@     srcMainFile <- findFile (hsSourceDirs bi) mainPath     let exeDir = destDir </> exeName exe     let destMainFile = exeDir </> hugsMainFilename exe-    copyModule verbosity (CPP `elem` extensions bi) bi lbi srcMainFile destMainFile+    copyModule verbosity (CPP `elem` allExtensions bi) bi lbi srcMainFile destMainFile     let destPathsFile = exeDir </> paths_modulename     copyFileVerbose verbosity (autogenModulesDir lbi </> paths_modulename)                               destPathsFile@@ -345,9 +356,10 @@                  -> BuildInfo                  -> LocalBuildInfo                  -> IO ()+--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` extensions bi+    let useCpp = CPP `elem` allExtensions bi     let srcDir = buildDir lbi         srcDirs = nub $ srcDir : hsSourceDirs bi ++ mLibSrcDirs     info verbosity $ "Source directories: " ++ show srcDirs@@ -534,6 +546,7 @@ -- \<prefix>\/lib\/hugs\/programs\/\<exename>. install     :: Verbosity -- ^verbosity+    -> LocalBuildInfo     -> FilePath  -- ^Library install location     -> FilePath  -- ^Program install location     -> FilePath  -- ^Executable install location@@ -542,7 +555,8 @@     -> (FilePath,FilePath)  -- ^Executable (prefix,suffix)     -> PackageDescription     -> IO ()-install verbosity libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do+--FIXME: this script should be generated at build time, just installed at this stage+install verbosity lbi libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do     removeDirectoryRecursive libDir `catchIO` \_ -> return ()     withLib pkg_descr $ \ lib ->       findModuleFiles [buildPref] hugsInstallSuffixes (libModules lib)@@ -551,6 +565,7 @@     when (any (buildable . buildInfo) (executables pkg_descr)) $         createDirectoryIfMissingVerbose verbosity True binDir     withExe pkg_descr $ \ exe -> do+        let bi = buildInfo exe         let theBuildDir = buildProgDir </> exeName exe         let installDir = installProgDir </> exeName exe         let targetDir = targetProgDir </> exeName exe@@ -560,9 +575,9 @@                                          : otherModules (buildInfo exe))           >>= installOrdinaryFiles verbosity installDir         let targetName = "\"" ++ (targetDir </> hugsMainFilename exe) ++ "\""-        -- FIX (HUGS): use extensions, and options from file too?-        -- see http://hackage.haskell.org/trac/hackage/ticket/43         let hugsOptions = hcOptions Hugs (buildInfo exe)+                       ++ languageToFlags (compiler lbi) (defaultLanguage bi)+                       ++ extensionsToFlags (compiler lbi) (allExtensions bi)         let baseExeFile = progprefix ++ (exeName exe) ++ progsuffix         let exeFile = case buildOS of                           Windows -> binDir </> baseExeFile <.> ".bat"@@ -588,3 +603,24 @@ hugsMainFilename :: Executable -> FilePath hugsMainFilename exe = "Main" <.> ext   where ext = takeExtension (modulePath exe)++-- -----------------------------------------------------------------------------+-- Registering++registerPackage+  :: Verbosity+  -> InstalledPackageInfo+  -> PackageDescription+  -> LocalBuildInfo+  -> Bool+  -> PackageDBStack+  -> IO ()+registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do+  --TODO: prefer to have it based on the packageDbs, but how do we know+  -- the package subdir based on the name? the user can set crazy libsubdir+  let installDirs = absoluteInstallDirs pkg lbi NoCopyDest+      pkgdir  | inplace   = buildDir lbi+              | otherwise = libdir installDirs+  createDirectoryIfMissingVerbose verbosity True pkgdir+  writeUTF8File (pkgdir </> "package.conf")+                (showInstalledPackageInfo installedPkgInfo)

@@ -65,6 +65,7 @@ import qualified Distribution.Simple.JHC  as JHC import qualified Distribution.Simple.LHC  as LHC import qualified Distribution.Simple.Hugs as Hugs+import qualified Distribution.Simple.UHC  as UHC  import Control.Monad (when, unless) import System.Directory@@ -73,6 +74,8 @@          ( takeFileName, takeDirectory, (</>), isAbsolute )  import Distribution.Verbosity+import Distribution.Text+         ( display )  -- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" -- actions.  Move files into place based on the prefix argument.  FIX:@@ -148,23 +151,28 @@   when (hasLibs pkg_descr) $ installIncludeFiles verbosity pkg_descr incPref    case compilerFlavor (compiler lbi) of-     GHC  -> do withLib pkg_descr $ \_ ->-                  GHC.installLib flags lbi libPref dynlibPref buildPref pkg_descr-                withExe pkg_descr $ \_ ->-                  GHC.installExe flags lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr-     LHC  -> do withLib pkg_descr $ \_ ->-                  LHC.installLib flags lbi libPref dynlibPref buildPref pkg_descr-                withExe pkg_descr $ \_ ->-                  LHC.installExe flags lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr-     JHC  -> do withLib pkg_descr $ JHC.installLib verbosity libPref buildPref pkg_descr-                withExe pkg_descr $ JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr+     GHC  -> do withLib pkg_descr $+                  GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr+                withExe pkg_descr $+                  GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr+     LHC  -> do withLib pkg_descr $+                  LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr+                withExe pkg_descr $+                  LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr+     JHC  -> do withLib pkg_descr $+                  JHC.installLib verbosity libPref buildPref pkg_descr+                withExe pkg_descr $+                  JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr      Hugs -> do        let targetProgPref = progdir (absoluteInstallDirs pkg_descr lbi NoCopyDest)        let scratchPref = scratchDir lbi-       Hugs.install verbosity libPref progPref binPref targetProgPref scratchPref (progPrefixPref, progSuffixPref) pkg_descr+       Hugs.install verbosity lbi libPref progPref binPref targetProgPref scratchPref (progPrefixPref, progSuffixPref) pkg_descr      NHC  -> do withLib pkg_descr $ NHC.installLib verbosity libPref buildPref (packageId pkg_descr)                 withExe pkg_descr $ NHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref)-     _    -> die ("only installing with GHC, JHC, Hugs or nhc98 is implemented")+     UHC  -> do withLib pkg_descr $ UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr+     _    -> die $ "installing with "+                ++ display (compilerFlavor (compiler lbi))+                ++ " is not implemented"   return ()   -- register step should be performed by caller. 

@@ -236,6 +236,7 @@            Hugs   -> "hugs" </> "packages" </> "$pkg"            JHC    -> "$compiler"            LHC    -> "$compiler"+           UHC    -> "$pkgid"            _other -> "$pkgid" </> "$compiler",       dynlibdir    = "$libdir",       libexecdir   = case buildOS of@@ -315,12 +316,7 @@        _              -> id)   . appendSubdirs (</>)   . fmap fromPathTemplate-  $ substituteInstallDirTemplates env dirs {-      prefix = case copydest of-        -- possibly override the prefix-        CopyPrefix p -> toPathTemplate p-        _            -> prefix dirs-    }+  $ substituteInstallDirTemplates env dirs   where     env = initialPathTemplateEnv pkgId compilerId @@ -329,7 +325,6 @@ data CopyDest   = NoCopyDest   | CopyTo FilePath-  | CopyPrefix FilePath         -- DEPRECATED   deriving (Eq, Show)  -- | Check which of the paths are relative to the installation $prefix.@@ -373,6 +368,7 @@ data PathComponent =        Ordinary FilePath      | Variable PathTemplateVariable+     deriving Eq  data PathTemplateVariable =        PrefixVar     -- ^ The @$prefix@ path variable@@ -390,6 +386,8 @@      | OSVar         -- ^ The operating system name, eg @windows@ or @linux@      | ArchVar       -- ^ The cpu architecture name, eg @i386@ or @x86_64@      | ExecutableNameVar -- ^ The executable name; used in shell wrappers+     | TestSuiteNameVar   -- ^ The name of the test suite being run+     | TestSuiteResultVar -- ^ The result of the test suite being run, eg @pass@, @fail@, or @error@.   deriving Eq  type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]@@ -418,7 +416,6 @@                   Just (PathTemplate components) -> components                   Nothing                        -> [component] - -- | The initial environment has all the static stuff but no paths initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> PathTemplateEnv initialPathTemplateEnv pkgId compilerId =@@ -483,6 +480,8 @@   show OSVar         = "os"   show ArchVar       = "arch"   show ExecutableNameVar = "executablename"+  show TestSuiteNameVar   = "test-suite"+  show TestSuiteResultVar = "result"  instance Read PathTemplateVariable where   readsPrec _ s =@@ -504,7 +503,9 @@                  ,("compiler",   CompilerVar)                  ,("os",         OSVar)                  ,("arch",       ArchVar)-                 ,("executablename", ExecutableNameVar)]+                 ,("executablename", ExecutableNameVar)+                 ,("test-suite", TestSuiteNameVar)+                 ,("result", TestSuiteResultVar)]  instance Show PathComponent where   show (Ordinary path) = path

@@ -50,7 +50,7 @@  import Distribution.PackageDescription as PD        ( PackageDescription(..), BuildInfo(..), Executable(..)-       , Library(..), libModules, hcOptions )+       , Library(..), libModules, hcOptions, usedExtensions ) import Distribution.InstalledPackageInfo          ( emptyInstalledPackageInfo, ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo@@ -62,8 +62,9 @@                                 ( autogenModulesDir, exeExtension ) import Distribution.Simple.Compiler          ( CompilerFlavor(..), CompilerId(..), Compiler(..)-         , PackageDBStack, Flag, extensionsToFlags )-import Language.Haskell.Extension (Extension(..))+         , PackageDBStack, Flag, languageToFlags, extensionsToFlags )+import Language.Haskell.Extension+         ( Language(Haskell98), Extension(..)) import Distribution.Simple.Program          ( ConfiguredProgram(..), jhcProgram, ProgramConfiguration          , userMaybeSpecifyPath, requireProgramVersion, lookupProgram@@ -103,10 +104,14 @@   let Just version = programVersion jhcProg       comp = Compiler {         compilerId             = CompilerId JHC version,+        compilerLanguages      = jhcLanguages,         compilerExtensions     = jhcLanguageExtensions       }   return (comp, conf') +jhcLanguages :: [(Language, Flag)]+jhcLanguages = [(Haskell98, "")]+ -- | The flags for the supported extensions jhcLanguageExtensions :: [(Extension, Flag)] jhcLanguageExtensions =@@ -172,8 +177,9 @@                     -> FilePath -> Verbosity -> [String] constructJHCCmdLine lbi bi clbi _odir verbosity =         (if verbosity >= deafening then ["-v"] else [])-     ++ extensionsToFlags (compiler lbi) (extensions bi)      ++ hcOptions JHC bi+     ++ languageToFlags (compiler lbi) (defaultLanguage bi)+     ++ extensionsToFlags (compiler lbi) (usedExtensions bi)      ++ ["--noauto","-i-"]      ++ concat [["-i", l] | l <- nub (hsSourceDirs bi)]      ++ ["-i", autogenModulesDir lbi]

@@ -64,15 +64,14 @@         configure, getInstalledPackages,         buildLib, buildExe,         installLib, installExe,+        registerPackage,         ghcOptions,         ghcVerbosityOptions  ) where -import Distribution.Simple.Setup-         ( CopyFlags(..), fromFlag ) import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..), Executable(..), withExe-         , Library(..), libModules, hcOptions )+         ( PackageDescription(..), BuildInfo(..), Executable(..)+         , Library(..), libModules, hcOptions, usedExtensions, allExtensions ) import Distribution.InstalledPackageInfo                                 ( InstalledPackageInfo                                 , parseInstalledPackageInfo )@@ -87,7 +86,7 @@ import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package-         ( PackageIdentifier, Package(..), PackageName(..) )+         ( PackageIdentifier, Package(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program          ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg@@ -98,10 +97,11 @@          , arProgram, ranlibProgram, ldProgram          , gccProgram, stripProgram          , lhcProgram, lhcPkgProgram )+import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Compiler          ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion          , OptimisationLevel(..), PackageDB(..), PackageDBStack-         , Flag, extensionsToFlags )+         , Flag, languageToFlags, extensionsToFlags ) import Distribution.Version          ( Version(..), orLaterVersion ) import Distribution.System@@ -109,7 +109,8 @@ import Distribution.Verbosity import Distribution.Text          ( display, simpleParse )-import Language.Haskell.Extension (Extension(..))+import Language.Haskell.Extension+         ( Language(Haskell98), Extension(..) )  import Control.Monad            ( unless, when ) import Data.List@@ -145,11 +146,13 @@     ++ programPath lhcProg ++ " is version " ++ display lhcVersion ++ " "     ++ programPath lhcPkgProg ++ " is version " ++ display lhcPkgVersion -  languageExtensions <- getLanguageExtensions verbosity lhcProg+  languages  <- getLanguages  verbosity lhcProg+  extensions <- getExtensions verbosity lhcProg    let comp = Compiler {         compilerId             = CompilerId LHC lhcVersion,-        compilerExtensions     = languageExtensions+        compilerLanguages      = languages,+        compilerExtensions     = extensions       }       conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld   return (comp, conf''')@@ -216,8 +219,12 @@         then return ["-x"]         else return [] -getLanguageExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)]-getLanguageExtensions verbosity lhcProg = do+getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)]+getLanguages _ _ = return [(Haskell98, "")]+--FIXME: does lhc support -XHaskell98 flag? from what version?++getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)]+getExtensions verbosity lhcProg = do     exts <- rawSystemStdout verbosity (programPath lhcProg)               ["--supported-languages"]     -- GHC has the annoying habit of inverting some of the extensions@@ -237,7 +244,7 @@   pkgss <- getInstalledPackages' verbosity packagedbs conf   let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)                 | (_, pkgs) <- pkgss ]-  return $! hackRtsPackage (mconcat indexes)+  return $! (mconcat indexes)    where     -- On Windows, various fields have $topdir/foo rather than full@@ -247,12 +254,6 @@     compilerDir  = takeDirectory (programPath ghcProg)     topDir       = takeDirectory compilerDir -    hackRtsPackage index =-      case PackageIndex.lookupPackageName index (PackageName "rts") of-        [(_,[rts])]-           -> PackageIndex.insert (removeMingwIncludeDir rts) index-        _  -> error "No (or multiple) rts package is registered!!"- checkPackageDbStack :: PackageDBStack -> IO () checkPackageDbStack (GlobalPackageDB:rest)   | GlobalPackageDB `notElem` rest = return ()@@ -260,15 +261,6 @@   die $ "GHC.getInstalledPackages: the global package db must be "      ++ "specified first and cannot be specified multiple times" --- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This--- breaks when you want to use a different gcc, so we need to filter--- it out.-removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo-removeMingwIncludeDir pkg =-    let ids = InstalledPackageInfo.includeDirs pkg-        ids' = filter (not . ("mingw" `isSuffixOf`)) ids-    in pkg { InstalledPackageInfo.includeDirs = ids' }- -- | Get the packages from specific PackageDBs, not cumulative. -- getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration@@ -344,7 +336,7 @@              (compiler lbi) (withProfLib lbi) (libBuildInfo lib)    let libTargetDir = pref-      forceVanillaLib = TemplateHaskell `elem` extensions libBi+      forceVanillaLib = TemplateHaskell `elem` allExtensions libBi       -- TH always needs vanilla libs, even when building for profiling    createDirectoryIfMissingVerbose verbosity True libTargetDir@@ -353,6 +345,7 @@              ["-package-name", display pkgid ]           ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity           ++ map display (libModules lib)+      lhcWrap x = ["--build-library", "--ghc-opts=" ++ unwords x]       ghcArgsProf = ghcArgs           ++ ["-prof",               "-hisuf", "p_hi",@@ -366,9 +359,9 @@              ]           ++ ghcSharedOptions libBi   unless (null (libModules lib)) $-    do ifVanillaLib forceVanillaLib (runGhcProg ghcArgs)-       ifProfLib (runGhcProg ghcArgsProf)-       ifSharedLib (runGhcProg ghcArgsShared)+    do ifVanillaLib forceVanillaLib (runGhcProg $ lhcWrap ghcArgs)+       ifProfLib (runGhcProg $ lhcWrap ghcArgsProf)+       ifSharedLib (runGhcProg $ lhcWrap ghcArgsShared)    -- build any C sources   unless (null (cSources libBi)) $ do@@ -527,6 +520,7 @@   srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath    let cObjs = map (`replaceExtension` objExtension) (cSources exeBi)+  let lhcWrap x = ("--ghc-opts\"":x) ++ ["\""]   let binArgs linkExe profExe =              (if linkExe                  then ["-o", targetDir </> exeNameReal]@@ -550,8 +544,8 @@   -- 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` extensions exeBi)-     (runGhcProg (binArgs False False))+  when (withProfExe lbi && TemplateHaskell `elem` allExtensions exeBi)+     (runGhcProg $ lhcWrap (binArgs False False))    runGhcProg (binArgs True (withProfExe lbi)) @@ -634,7 +628,8 @@            NormalOptimisation  -> ["-O"]            MaximumOptimisation -> ["-O2"])      ++ hcOptions GHC bi-     ++ extensionsToFlags c (extensions bi)+     ++ languageToFlags c (defaultLanguage bi)+     ++ extensionsToFlags c (usedExtensions bi)     where c = compiler lbi  ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String]@@ -657,7 +652,7 @@  where     specific (SpecificPackageDB db) = [ "-package-conf", db ]     specific _ = ierror-    ierror     = error "internal error: unexpected package db stack"+    ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)  constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo                    -> FilePath -> FilePath -> Verbosity -> (FilePath,[String])@@ -692,26 +687,25 @@ -- Installing  -- |Install executables for GHC.-installExe :: CopyFlags -- ^verbosity+installExe :: Verbosity            -> LocalBuildInfo            -> InstallDirs FilePath -- ^Where to copy the files to            -> FilePath  -- ^Build location            -> (FilePath, FilePath)  -- ^Executable (prefix,suffix)            -> PackageDescription+           -> Executable            -> IO ()-installExe flags lbi installDirs buildPref (progprefix, progsuffix) pkg_descr-    = do let verbosity = fromFlag (copyVerbosity flags)-             binDir = bindir installDirs-         createDirectoryIfMissingVerbose verbosity True binDir-         withExe pkg_descr $ \Executable { exeName = e } -> do-             let exeFileName = e <.> exeExtension-                 fixedExeBaseName = progprefix ++ e ++ progsuffix-                 installBinary dest = do-                     installExecutableFile verbosity-                       (buildPref </> e </> exeFileName)-                       (dest <.> exeExtension)-                     stripExe verbosity lbi exeFileName (dest <.> exeExtension)-             installBinary (binDir </> fixedExeBaseName)+installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do+  let binDir = bindir installDirs+  createDirectoryIfMissingVerbose verbosity True binDir+  let exeFileName = exeName exe <.> exeExtension+      fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix+      installBinary dest = do+          installExecutableFile verbosity+            (buildPref </> exeName exe </> exeFileName)+            (dest <.> exeExtension)+          stripExe verbosity lbi exeFileName (dest <.> exeExtension)+  installBinary (binDir </> fixedExeBaseName)  stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () stripExe verbosity lbi name path = when (stripExes lbi) $@@ -731,37 +725,38 @@        _   -> []  -- |Install for ghc, .hi, .a and, if --with-ghci given, .o-installLib    :: CopyFlags -- ^verbosity+installLib    :: Verbosity               -> LocalBuildInfo               -> FilePath  -- ^install location               -> FilePath  -- ^install location for dynamic librarys               -> FilePath  -- ^Build location-              -> PackageDescription -> IO ()-installLib flags lbi targetDir dynlibTargetDir builtDir-              pkg@PackageDescription{library=Just lib} = do-        -- copy .hi files over:-        let copy src dst n = do-              createDirectoryIfMissingVerbose verbosity True dst-              installOrdinaryFile verbosity (src </> n) (dst </> n)-            copyModuleFiles ext =-              findModuleFiles [builtDir] [ext] (libModules lib)-                >>= installOrdinaryFiles verbosity targetDir-        ifVanilla $ copyModuleFiles "hi"-        ifProf    $ copyModuleFiles "p_hi"-        hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (libModules lib)-        flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["install", srcBase </> srcFile]+              -> PackageDescription+              -> Library+              -> IO ()+installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do+  -- copy .hi files over:+  let copy src dst n = do+        createDirectoryIfMissingVerbose verbosity True dst+        installOrdinaryFile verbosity (src </> n) (dst </> n)+      copyModuleFiles ext =+        findModuleFiles [builtDir] [ext] (libModules lib)+          >>= installOrdinaryFiles verbosity targetDir+  ifVanilla $ copyModuleFiles "hi"+  ifProf    $ copyModuleFiles "p_hi"+  hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (libModules lib)+  flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase </> srcFile] -        -- copy the built library files over:-        ifVanilla $ copy builtDir targetDir vanillaLibName-        ifProf    $ copy builtDir targetDir profileLibName-        ifGHCi    $ copy builtDir targetDir ghciLibName-        ifShared  $ copy builtDir dynlibTargetDir sharedLibName+  -- copy the built library files over:+  ifVanilla $ copy builtDir targetDir vanillaLibName+  ifProf    $ copy builtDir targetDir profileLibName+  ifGHCi    $ copy builtDir targetDir ghciLibName+  ifShared  $ copy builtDir dynlibTargetDir sharedLibName -        -- run ranlib if necessary:-        ifVanilla $ updateLibArchive verbosity lbi-                                     (targetDir </> vanillaLibName)-        ifProf    $ updateLibArchive verbosity lbi-                                     (targetDir </> profileLibName)+  -- run ranlib if necessary:+  ifVanilla $ updateLibArchive verbosity lbi+                               (targetDir </> vanillaLibName)+  ifProf    $ updateLibArchive verbosity lbi+                               (targetDir </> profileLibName)    where     vanillaLibName = mkLibName pkgid@@ -778,12 +773,8 @@     ifGHCi    = when (hasLib && withGHCiLib    lbi)     ifShared  = when (hasLib && withSharedLib  lbi) -    verbosity = fromFlag (copyVerbosity flags)     runLhc    = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) -installLib _ _ _ _ _ PackageDescription{library=Nothing}-    = die $ "Internal Error. installLibGHC called with no library."- -- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems -- like MacOS X. If we can't find those, don't worry too much about it. --@@ -797,3 +788,18 @@                         "Unable to generate a symbol index for the static "                      ++ "library '" ++ path                      ++ "' (missing the 'ranlib' and 'ar' programs)"++-- -----------------------------------------------------------------------------+-- Registering++registerPackage+  :: Verbosity+  -> InstalledPackageInfo+  -> PackageDescription+  -> LocalBuildInfo+  -> Bool+  -> PackageDBStack+  -> IO ()+registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do+  let Just lhcPkg = lookupProgram lhcPkgProgram (withPrograms lbi)+  HcPkg.reregister verbosity lhcPkg packageDbs (Right installedPkgInfo)

@@ -47,16 +47,15 @@ module Distribution.Simple.LocalBuildInfo (         LocalBuildInfo(..),         externalPackageDeps,+        inplacePackageId,         withLibLBI,         withExeLBI,+        withTestLBI,         ComponentLocalBuildInfo(..),         -- * Installation directories         module Distribution.Simple.InstallDirs,         absoluteInstallDirs, prefixRelativeInstallDirs,-        substPathTemplate,--        -- * Deprecated-        packageDeps+        substPathTemplate   ) where  @@ -67,7 +66,7 @@ import Distribution.Simple.Program (ProgramConfiguration) import Distribution.PackageDescription          ( PackageDescription(..), withLib, Library, withExe-         , Executable(exeName) )+         , Executable(exeName), withTest, TestSuite(..) ) import Distribution.Package          ( PackageId, Package(..), InstalledPackageId(..) ) import Distribution.Simple.Compiler@@ -76,23 +75,36 @@          ( PackageIndex ) import Distribution.Simple.Utils          ( die )+import Distribution.Simple.Setup+         ( ConfigFlags )+import Distribution.Text+         ( display )  import Data.List (nub) --- |Data cached after configuration step.  See also--- 'Distribution.Setup.ConfigFlags'.+-- | Data cached after configuration step.  See also+-- 'Distribution.Simple.Setup.ConfigFlags'. data LocalBuildInfo = LocalBuildInfo {+        configFlags   :: ConfigFlags,+        -- ^ Options passed to the configuration step.+        -- Needed to re-run configuration when .cabal is out of date+        extraConfigArgs     :: [String],+        -- ^ Extra args on the command line for the configuration step.+        -- Needed to re-run configuration when .cabal is out of date         installDirTemplates :: InstallDirTemplates,                 -- ^ The installation directories for the various differnt                 -- kinds of files+        --TODO: inplaceDirTemplates :: InstallDirs FilePath         compiler      :: Compiler,                 -- ^ The compiler we're building with         buildDir      :: FilePath,                 -- ^ Where to build the package.+        --TODO: eliminate hugs's scratchDir, use builddir         scratchDir    :: FilePath,                 -- ^ Where to put the result of the Hugs build.         libraryConfig       :: Maybe ComponentLocalBuildInfo,         executableConfigs   :: [(String, ComponentLocalBuildInfo)],+        testSuiteConfigs    :: [(String, ComponentLocalBuildInfo)],         installedPkgs :: PackageIndex,                 -- ^ All the info about all installed packages.         pkgDescrFile  :: Maybe FilePath,@@ -123,10 +135,6 @@   }   deriving (Read, Show) -{-# DEPRECATED packageDeps "use externalPackageDeps or componentPackageDeps" #-}-packageDeps :: LocalBuildInfo -> [PackageId]-packageDeps = map snd . externalPackageDeps- -- | External package dependencies for the package as a whole, the union of the -- individual 'targetPackageDeps'. externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)]@@ -135,6 +143,12 @@      maybe [] componentPackageDeps (libraryConfig lbi)   ++ concatMap (componentPackageDeps . snd) (executableConfigs lbi) +-- | The installed package Id we use for local packages registered in the local+-- package db. This is what is used for intra-package deps between components.+--+inplacePackageId :: PackageId -> InstalledPackageId+inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace")+ -- |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,6 +172,15 @@                     ++ exeName exe ++ " but there is no corresponding "                     ++ "configuration data" +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  -- ----------------------------------------------------------------------------- -- Wrappers for a couple functions from InstallDirs

@@ -60,7 +60,7 @@          , emptyInstalledPackageInfo, parseInstalledPackageInfo ) import Distribution.PackageDescription         ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)-        , hcOptions )+        , hcOptions, usedExtensions ) import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.LocalBuildInfo@@ -68,12 +68,13 @@ import Distribution.Simple.BuildPaths         ( mkLibName, objExtension, exeExtension ) import Distribution.Simple.Compiler-        ( CompilerFlavor(..), CompilerId(..), Compiler(..)-        , Flag, extensionsToFlags, PackageDB(..), PackageDBStack )+         ( CompilerFlavor(..), CompilerId(..), Compiler(..)+         , Flag, languageToFlags, extensionsToFlags+         , PackageDB(..), PackageDBStack ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex) import Language.Haskell.Extension-        ( Extension(..) )+         ( Language(Haskell98), Extension(..) ) import Distribution.Simple.Program          ( ProgramConfiguration, userMaybeSpecifyPath, programPath          , requireProgram, requireProgramVersion, lookupProgram@@ -130,14 +131,17 @@    let comp = Compiler {         compilerId         = CompilerId NHC nhcVersion,+        compilerLanguages  = nhcLanguages,         compilerExtensions = nhcLanguageExtensions       }   return (comp, conf'''') +nhcLanguages :: [(Language, Flag)]+nhcLanguages = [(Haskell98, "-98")]+ -- | The flags for the supported extensions nhcLanguageExtensions :: [(Extension, Flag)] nhcLanguageExtensions =-    -- TODO: use -98 when no extensions are specified.     -- NHC doesn't enforce the monomorphism restriction at all.     -- TODO: pattern guards in 1.20     [(NoMonomorphismRestriction, "")@@ -273,7 +277,8 @@   let bi = libBuildInfo lib       modules = exposedModules lib ++ otherModules bi       -- Unsupported extensions have already been checked by configure-      extensionFlags = extensionsToFlags (compiler lbi) (extensions bi)+      languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi)+                   ++ extensionsToFlags (compiler lbi) (usedExtensions bi)   inFiles <- getModulePaths lbi bi modules   let targetDir = buildDir lbi       srcDirs  = nub (map takeDirectory inFiles)@@ -283,9 +288,9 @@        ["-hc=" ++ programPath nhcProg]     ++ nhcVerbosityOptions verbosity     ++ ["-d", targetDir, "-hidir", targetDir]-    ++ extensionFlags     ++ maybe [] (hcOptions NHC . libBuildInfo)                            (library pkg_descr)+    ++ languageFlags     ++ concat [ ["-package", display (packageName pkgid) ]               | (_, pkgid) <- componentPackageDeps clbi ]     ++ inFiles@@ -337,7 +342,8 @@   let bi = buildInfo exe       modules = otherModules bi       -- Unsupported extensions have already been checked by configure-      extensionFlags = extensionsToFlags (compiler lbi) (extensions bi)+      languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi)+                   ++ extensionsToFlags (compiler lbi) (usedExtensions bi)   inFiles <- getModulePaths lbi bi modules   let targetDir = buildDir lbi </> exeName exe       exeDir    = targetDir </> (exeName exe ++ "-tmp")@@ -348,9 +354,9 @@        ["-hc=" ++ programPath nhcProg]     ++ nhcVerbosityOptions verbosity     ++ ["-d", targetDir, "-hidir", targetDir]-    ++ extensionFlags     ++ maybe [] (hcOptions NHC . libBuildInfo)                            (library pkg_descr)+    ++ languageFlags     ++ concat [ ["-package", display (packageName pkgid) ]               | (_, pkgid) <- componentPackageDeps clbi ]     ++ inFiles

@@ -430,9 +430,9 @@   , not (null missing) ]  --- | Tries to take the transative closure of the package dependencies.+-- | Tries to take the transitive closure of the package dependencies. ----- If the transative closure is complete then it returns that subset of the+-- If the transitive closure is complete then it returns that subset of the -- index. Otherwise it returns the broken packages as in 'brokenPackages'. -- -- * Note that if the result is @Right []@ it is because at least one of@@ -455,7 +455,7 @@           where completed' = insert pkg completed                 pkgids'    = IPI.depends pkg ++ pkgids --- | Takes the transative closure of the packages reverse dependencies.+-- | Takes the transitive closure of the packages reverse dependencies. -- -- * The given 'PackageId's must be in the index. --

@@ -62,7 +62,9 @@ import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD          ( PackageDescription(..), BuildInfo(..), Executable(..), withExe-         , Library(..), withLib, libModules )+         , Library(..), withLib, libModules+         , TestSuite(..), withTest, testModules+         , TestSuiteInterface(..) ) import qualified Distribution.InstalledPackageInfo as Installed          ( InstalledPackageInfo_(..) ) import qualified Distribution.Simple.PackageIndex as PackageIndex@@ -75,13 +77,17 @@          , die, setupMessage, intercalate, copyFileVerbose          , findFileWithExtension, findFileWithExtension' ) import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), lookupProgram, programPath+         ( Program(..), ConfiguredProgram(..), programPath+         , lookupProgram, requireProgram, requireProgramVersion          , rawSystemProgramConf, rawSystemProgram          , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram          , happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram )+import Distribution.Simple.Test ( writeSimpleTestStub, stubFilePath, stubName ) import Distribution.System          ( OS(OSX, Windows), buildOS )-import Distribution.Version (Version(..))+import Distribution.Text+import Distribution.Version+         ( Version(..), anyVersion, orLaterVersion ) import Distribution.Verbosity  import Control.Monad (when, unless)@@ -196,12 +202,40 @@         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 +--TODO: try to list all the modules that could not be found+--      not just the first one. It's annoying and slow due to the need+--      to reconfigure after editing the .cabal file each time.+ -- |Find the first extension of the file that exists, and preprocess it -- if required. preprocessFile@@ -219,8 +253,14 @@     psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc baseFile     case psrcFiles of         -- no preprocessor file exists, look for an ordinary source file+        -- just to make sure one actually exists at all for this module.+        -- Note: by looking in the target/output build dir too, we allow+        -- source files to appear magically in the target build dir without+        -- any corresponding "real" source file. This lets custom Setup.hs+        -- files generate source modules directly into the build dir without+        -- the rest of the build system being aware of it (somewhat dodgy)       Nothing -> do-                 bsrcFiles <- findFileWithExtension builtinSuffixes searchLoc baseFile+                 bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : searchLoc) baseFile                  case bsrcFiles of                   Nothing -> die $ "can't find source for " ++ baseFile                                 ++ " in " ++ intercalate ", " searchLoc@@ -253,14 +293,37 @@               when recomp $ do                 let destDir = buildLoc </> dirName srcStem                 createDirectoryIfMissingVerbose verbosity True destDir-                runPreProcessor pp+                runPreProcessorWithHsBootHack pp                    (psrcLoc, psrcRelFile)-                   (buildLoc, srcStem <.> "hs") verbosity+                   (buildLoc, srcStem <.> "hs") -     where dirName = takeDirectory-           tailNotNull [] = []-           tailNotNull x  = tail x+  where+    dirName = takeDirectory+    tailNotNull [] = []+    tailNotNull x  = tail x +    -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files+    -- be in the same place as the hs files, so if we put the hs file in dist/+    -- then we need to copy the hs-boot file there too. This should probably be+    -- done another way. Possibly we should also be looking for .lhs-boot+    -- files, but I think that preprocessors only produce .hs files.+    runPreProcessorWithHsBootHack pp+      (inBaseDir,  inRelativeFile)+      (outBaseDir, outRelativeFile) = do+        runPreProcessor pp+          (inBaseDir, inRelativeFile)+          (outBaseDir, outRelativeFile) verbosity++        exists <- doesFileExist inBoot+        when exists $ copyFileVerbose verbosity inBoot outBoot++      where+        inBoot  = replaceExtension inFile  "hs-boot"+        outBoot = replaceExtension outFile "hs-boot"++        inFile  = normalise (inBaseDir  </> inRelativeFile)+        outFile = normalise (outBaseDir </> outRelativeFile)+ -- ------------------------------------------------------------ -- * known preprocessors -- ------------------------------------------------------------@@ -294,17 +357,15 @@     GHC -> ppGhcCpp (cppArgs ++ extraArgs) bi lbi     _   -> ppCpphs  (cppArgs ++ extraArgs) bi lbi -  where cppArgs = sysDefines ++ cppOptions bi ++ getCppOptions bi lbi-        sysDefines =-                ["-D" ++ os ++ "_" ++ loc ++ "_OS" | loc <- locations] ++-                ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations]-        locations = ["BUILD", "HOST"]+  where cppArgs = getCppOptions bi lbi  ppGhcCpp :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor ppGhcCpp extraArgs _bi lbi =   PreProcessor {     platformIndependent = False,-    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->+    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do+      (ghcProg, ghcVersion, _) <- requireProgramVersion verbosity+                                    ghcProgram anyVersion (withPrograms lbi)       rawSystemProgram verbosity ghcProg $           ["-E", "-cpp"]           -- This is a bit of an ugly hack. We're going to@@ -318,14 +379,14 @@        ++ ["-o", outFile, inFile]        ++ extraArgs   }-  where Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)-        Just ghcVersion = programVersion ghcProg  ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor ppCpphs extraArgs _bi lbi =   PreProcessor {     platformIndependent = False,-    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->+    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do+      (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity+                                        cpphsProgram anyVersion (withPrograms lbi)       rawSystemProgram verbosity cpphsProg $           ("-O" ++ outFile) : inFile         : "--noline" : "--strip"@@ -334,8 +395,6 @@              else [])         ++ extraArgs   }-  where Just cpphsProg = lookupProgram cpphsProgram (withPrograms lbi)-        Just cpphsVersion = programVersion cpphsProg  -- Haddock versions before 0.8 choke on #line and #file pragmas.  Those -- pragmas are necessary for correct links when we preprocess.  So use@@ -348,55 +407,65 @@      _                               -> True  ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor-ppHsc2hs bi lbi = standardPP lbi hsc2hsProgram $-    [ "--cc=" ++ programPath gccProg-    , "--ld=" ++ programPath gccProg ]+ppHsc2hs bi lbi =+  PreProcessor {+    platformIndependent = False,+    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do+      (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)+      rawSystemProgramConf verbosity hsc2hsProgram (withPrograms lbi) $+          [ "--cc=" ++ programPath gccProg+          , "--ld=" ++ programPath gccProg ] -    -- Additional gcc options- ++ [ "--cflag=" ++ opt | opt <- programArgs gccProg ]- ++ [ "--lflag=" ++ opt | opt <- programArgs gccProg ]+          -- Additional gcc options+       ++ [ "--cflag=" ++ opt | opt <- programDefaultArgs  gccProg+                                    ++ programOverrideArgs gccProg ]+       ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs  gccProg+                                    ++ programOverrideArgs gccProg ] -    -- OSX frameworks:- ++ [ what ++ "=-F" ++ opt-    | isOSX-    , opt <- nub (concatMap Installed.frameworkDirs pkgs)-    , what <- ["--cflag", "--lflag"] ]- ++ [ "--lflag=" ++ arg-    | isOSX-    , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs-    , arg <- ["-framework", opt] ]+          -- OSX frameworks:+       ++ [ what ++ "=-F" ++ opt+          | isOSX+          , opt <- nub (concatMap Installed.frameworkDirs pkgs)+          , what <- ["--cflag", "--lflag"] ]+       ++ [ "--lflag=" ++ arg+          | isOSX+          , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs+          , arg <- ["-framework", opt] ] -    -- Note that on ELF systems, wherever we use -L, we must also use -R-    -- because presumably that -L dir is not on the normal path for the-    -- system's dynamic linker. This is needed because hsc2hs works by-    -- compiling a C program and then running it.+          -- Note that on ELF systems, wherever we use -L, we must also use -R+          -- because presumably that -L dir is not on the normal path for the+          -- system's dynamic linker. This is needed because hsc2hs works by+          -- compiling a C program and then running it. -    -- Options from the current package:- ++ [ "--cflag="   ++ opt | opt <- hcDefines (compiler lbi) ]- ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs  bi ]- ++ [ "--cflag="   ++ opt | opt <- PD.ccOptions    bi-                                ++ PD.cppOptions   bi ]- ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ]- ++ [ "--lflag=-Wl,-R," ++ opt | isELF-                          , opt <- PD.extraLibDirs bi ]- ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs    bi ]- ++ [ "--lflag="   ++ opt | opt <- PD.ldOptions    bi ]+       ++ [ "--cflag="   ++ opt | opt <- hcDefines (compiler lbi) ]+       ++ [ "--cflag="   ++ opt | opt <- sysDefines ] -    -- Options from dependent packages- ++ [ "--cflag=" ++ opt-    | pkg <- pkgs-    , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ]-          ++ [         opt | opt <- Installed.ccOptions   pkg ] ]- ++ [ "--lflag=" ++ opt-    | pkg <- pkgs-    , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs    pkg ]-          ++ [ "-Wl,-R," ++ opt | isELF-                           , opt <- Installed.libraryDirs    pkg ]-          ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ]-          ++ [         opt | opt <- Installed.ldOptions      pkg ] ]+          -- Options from the current package:+       ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs  bi ]+       ++ [ "--cflag="   ++ opt | opt <- PD.ccOptions    bi+                                      ++ PD.cppOptions   bi ]+       ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ]+       ++ [ "--lflag=-Wl,-R," ++ opt | isELF+                                , opt <- PD.extraLibDirs bi ]+       ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs    bi ]+       ++ [ "--lflag="   ++ opt | opt <- PD.ldOptions    bi ]++          -- Options from dependent packages+       ++ [ "--cflag=" ++ opt+          | pkg <- pkgs+          , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ]+                ++ [         opt | opt <- Installed.ccOptions   pkg ] ]+       ++ [ "--lflag=" ++ opt+          | pkg <- pkgs+          , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs    pkg ]+                ++ [ "-Wl,-R," ++ opt | isELF+                                 , opt <- Installed.libraryDirs    pkg ]+                ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ]+                ++ [         opt | opt <- Installed.ldOptions      pkg ] ]+       ++ ["-o", outFile, inFile]+  }   where     pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))-    Just gccProg = lookupProgram  gccProgram (withPrograms lbi)     isOSX = case buildOS of OSX -> True; _ -> False     isELF = case buildOS of OSX -> False; Windows -> False; _ -> True;     packageHacks = case compilerFlavor (compiler lbi) of@@ -414,25 +483,55 @@   ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor-ppC2hs bi lbi-    = PreProcessor {-        platformIndependent = False,-        runPreProcessor = \(inBaseDir, inRelativeFile)-                           (outBaseDir, outRelativeFile) verbosity ->-          rawSystemProgramConf verbosity c2hsProgram (withPrograms lbi) $-               ["--include=" ++ outBaseDir]-            ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi]-            ++ ["--output-dir=" ++ outBaseDir,-                "--output=" ++ outRelativeFile,-                inBaseDir </> inRelativeFile]-      }+ppC2hs bi lbi =+  PreProcessor {+    platformIndependent = False,+    runPreProcessor = \(inBaseDir, inRelativeFile)+                       (outBaseDir, outRelativeFile) verbosity -> do+      (c2hsProg, _, _) <- requireProgramVersion verbosity+                            c2hsProgram (orLaterVersion (Version [0,15] []))+                            (withPrograms lbi)+      (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)+      rawSystemProgram verbosity c2hsProg $ +          -- Options from the current package:+           [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ]+        ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ]+        ++ [ "--include=" ++ outBaseDir ]++          -- Options from dependent packages+       ++ [ "--cppopts=" ++ opt+          | pkg <- pkgs+          , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ]+                ++ [         opt | opt@('-':c:_) <- Installed.ccOptions pkg+                                 , c `elem` "DIU" ] ]+          --TODO: install .chi files for packages, so we can --include+          -- those dirs here, for the dependencies++           -- input and output files+        ++ [ "--output-dir=" ++ outBaseDir+           , "--output=" ++ outRelativeFile+           , inBaseDir </> inRelativeFile ]+  }+  where+    pkgs = PackageIndex.topologicalOrder (installedPkgs lbi)++--TODO: perhaps use this with hsc2hs too+--TODO: remove cc-options from cpphs for cabal-version: >= 1.10 getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] getCppOptions bi lbi     = hcDefines (compiler lbi)+   ++ sysDefines+   ++ cppOptions bi    ++ ["-I" ++ dir | dir <- PD.includeDirs bi]    ++ [opt | opt@('-':c:_) <- PD.ccOptions bi, c `elem` "DIU"] +sysDefines :: [String]+sysDefines = ["-D" ++ os   ++ "_" ++ loc ++ "_OS"   | loc <- locations]+          ++ ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations]+  where+    locations = ["BUILD", "HOST"]+ hcDefines :: Compiler -> [String] hcDefines comp =   case compilerFlavor comp of@@ -478,21 +577,8 @@   PreProcessor {     platformIndependent = False,     runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->-      do rawSystemProgramConf verbosity prog (withPrograms lbi)-                              (args ++ ["-o", outFile, inFile])-         -- XXX This is a nasty hack. GHC requires that hs-boot files-         -- be in the same place as the hs files, so if we put the hs-         -- file in dist/... then we need to copy the hs-boot file-         -- there too. This should probably be done another way, e.g.-         -- by preprocessing all files, with and "id" preprocessor if-         -- nothing else, so the hs-boot files automatically get copied-         -- into the right place.-         -- Possibly we should also be looking for .lhs-boot files, but-         -- I think that preprocessors only produce .hs files.-         let inBoot  = replaceExtension inFile  "hs-boot"-             outBoot = replaceExtension outFile "hs-boot"-         exists <- doesFileExist inBoot-         when exists $ copyFileVerbose verbosity inBoot outBoot+      rawSystemProgramConf verbosity prog (withPrograms lbi)+                           (args ++ ["-o", outFile, inFile])   }  -- |Convenience function; get the suffixes of these preprocessors.

@@ -93,6 +93,7 @@     , jhcProgram     , hugsProgram     , ffihugsProgram+    , uhcProgram     , gccProgram     , ranlibProgram     , arProgram

@@ -43,7 +43,9 @@   -- When we need to call ar multiple times we use "ar q" and for the last   -- call on OSX we use "ar qs" so that it'll make the index. -  let simpleArgs  = ["-r"]+  let simpleArgs  = case buildOS of+             OSX -> ["-r", "-s"]+             _   -> ["-r"]        initialArgs = ["-q"]       finalArgs   = case buildOS of

@@ -25,6 +25,7 @@     jhcProgram,     hugsProgram,     ffihugsProgram,+    uhcProgram,     gccProgram,     ranlibProgram,     arProgram,@@ -67,6 +68,7 @@     , jhcProgram     , lhcProgram     , lhcPkgProgram+    , uhcProgram     -- preprocessors     , hscolourProgram     , haddockProgram@@ -146,6 +148,11 @@       case words str of         (_:ver:_) -> ver         _         -> ""+  }++uhcProgram :: Program+uhcProgram = (simpleProgram "uhc") {+    programFindVersion = findProgramVersion "--version-dotted" id   }  

@@ -197,7 +197,8 @@          \(prog, path, args) -> Just (prog, path, args ++ args'))   . updateConfiguredProgs       (flip Map.update name $-         \prog -> Just prog { programArgs = programArgs prog ++ args' })+         \prog -> Just prog { programOverrideArgs = programOverrideArgs prog+                                                 ++ args' })   -- | Like 'userSpecifyPath' but for a list of progs and their paths.@@ -285,15 +286,16 @@     Nothing -> return conf     Just location -> do       version <- programFindVersion prog verbosity (locationPath location)-      let configuredProg    = ConfiguredProgram {-            programId       = name,-            programVersion  = version,-            programArgs     = userSpecifiedArgs prog conf,-            programLocation = location+      let configuredProg        = ConfiguredProgram {+            programId           = name,+            programVersion      = version,+            programDefaultArgs  = [],+            programOverrideArgs = userSpecifiedArgs prog conf,+            programLocation     = location           }       extraArgs <- programPostConf prog verbosity configuredProg-      let configuredProg'   = configuredProg {-            programArgs     = extraArgs ++ programArgs configuredProg+      let configuredProg'       = configuredProg {+            programDefaultArgs  = extraArgs           }       return (updateConfiguredProgs (Map.insert name configuredProg') conf) 

@@ -34,7 +34,7 @@ import Distribution.ParseUtils          ( ParseResult(..) ) import Distribution.Simple.Compiler-         ( PackageDB(..) )+         ( PackageDB(..), PackageDBStack ) import Distribution.Simple.Program.Types          ( ConfiguredProgram(programId, programVersion) ) import Distribution.Simple.Program.Run@@ -58,7 +58,7 @@ -- -- > hc-pkg register {filename | -} [--user | --global | --package-conf] ---register :: Verbosity -> ConfiguredProgram -> PackageDB+register :: Verbosity -> ConfiguredProgram -> PackageDBStack          -> Either FilePath                    InstalledPackageInfo          -> IO ()@@ -71,7 +71,7 @@ -- -- > hc-pkg register {filename | -} [--user | --global | --package-conf] ---reregister :: Verbosity -> ConfiguredProgram -> PackageDB+reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack            -> Either FilePath                      InstalledPackageInfo            -> IO ()@@ -164,7 +164,7 @@ --  registerInvocation, reregisterInvocation-  :: ConfiguredProgram -> Verbosity -> PackageDB+  :: ConfiguredProgram -> Verbosity -> PackageDBStack   -> Either FilePath InstalledPackageInfo   -> ProgramInvocation registerInvocation   = registerInvocation' "register"@@ -172,22 +172,28 @@   registerInvocation' :: String-                    -> ConfiguredProgram -> Verbosity -> PackageDB+                    -> ConfiguredProgram -> Verbosity -> PackageDBStack                     -> Either FilePath InstalledPackageInfo                     -> ProgramInvocation-registerInvocation' cmdname hcPkg verbosity packagedb (Left pkgFile) =+registerInvocation' cmdname hcPkg verbosity packagedbs (Left pkgFile) =     programInvocation hcPkg args   where-    args = [cmdname, pkgFile, packageDbOpts packagedb]+    args = [cmdname, pkgFile]+        ++ (if legacyVersion hcPkg+              then [packageDbOpts (last packagedbs)]+              else packageDbStackOpts packagedbs)         ++ verbosityOpts hcPkg verbosity -registerInvocation' cmdname hcPkg verbosity packagedb (Right pkgInfo) =+registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) =     (programInvocation hcPkg args) {       progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),       progInvokeInputEncoding = IOEncodingUTF8     }   where-    args = [cmdname, "-", packageDbOpts packagedb]+    args = [cmdname, "-"]+        ++ (if legacyVersion hcPkg+              then [packageDbOpts (last packagedbs)]+              else packageDbStackOpts packagedbs)         ++ verbosityOpts hcPkg verbosity  @@ -227,6 +233,21 @@         ++ verbosityOpts hcPkg verbosity  +packageDbStackOpts :: PackageDBStack -> [String]+packageDbStackOpts dbstack = case dbstack of+  (GlobalPackageDB:UserPackageDB:dbs) -> "--global"+                                       : "--user"+                                       : map specific dbs+  (GlobalPackageDB:dbs)               -> "--global"+                                       : "--no-user-package-conf"+                                       : map specific dbs+  _                                   -> ierror+  where+    specific (SpecificPackageDB db) = "--package-conf=" ++ db+    specific _ = ierror+    ierror :: a+    ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)+ packageDbOpts :: PackageDB -> String packageDbOpts GlobalPackageDB        = "--global" packageDbOpts UserPackageDB          = "--user"@@ -243,3 +264,8 @@   | v >= deafening = ["-v2"]   | v == silent    = ["-v0"]   | otherwise      = []++-- Handle quirks in ghc-pkg 6.8 and older+legacyVersion :: ConfiguredProgram -> Bool+legacyVersion hcPkg = programId hcPkg == "ghc-pkg"+                   && programVersion hcPkg < Just (Version [6,9] [])

@@ -77,10 +77,12 @@   }  programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation-programInvocation prog extraArgs =+programInvocation prog args =   emptyProgramInvocation {     progInvokePath = programPath prog,-    progInvokeArgs = programArgs prog ++ extraArgs+    progInvokeArgs = programDefaultArgs prog+                  ++ args+                  ++ programOverrideArgs prog   }  

@@ -50,7 +50,7 @@        ++ [ (case minput of               Nothing    -> ""               Just input -> "echo " ++ quote input ++ " | ")-         ++ quote path ++ concatMap (\arg -> ' ':quote arg) args ]+         ++ unwords (map quote $ path : args) ++ " \"$@\""]    where     quote :: String -> String

@@ -65,7 +65,12 @@        -- | Default command-line args for this program.        -- These flags will appear first on the command line, so they can be        -- overridden by subsequent flags.-       programArgs :: [String],+       programDefaultArgs :: [String],++       -- | Override command-line args for this program.+       -- These flags will appear last on the command line, so they override+       -- all earlier flags.+       programOverrideArgs :: [String],         -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@        programLocation :: ProgramLocation

@@ -68,21 +68,19 @@          ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)          , InstallDirs(..), absoluteInstallDirs ) import Distribution.Simple.BuildPaths (haddockName)-import qualified Distribution.Simple.GHC as GHC+import qualified Distribution.Simple.GHC  as GHC+import qualified Distribution.Simple.LHC  as LHC+import qualified Distribution.Simple.Hugs as Hugs+import qualified Distribution.Simple.UHC  as UHC import Distribution.Simple.Compiler          ( compilerVersion, CompilerFlavor(..), compilerFlavor-         , PackageDB(..), PackageDBStack, registrationPackageDB )+         , PackageDBStack, registrationPackageDB ) import Distribution.Simple.Program-         ( ConfiguredProgram+         ( ConfiguredProgram, runProgramInvocation          , requireProgram, lookupProgram, ghcPkgProgram, lhcPkgProgram ) import Distribution.Simple.Program.Script          ( invocationAsSystemScript ) import qualified Distribution.Simple.Program.HcPkg as HcPkg-import Distribution.Simple.Program.Run-         ( ProgramInvocation(..), IOEncoding(..), programInvocation-         , runProgramInvocation )-import Distribution.Simple.Program.Types-         ( ConfiguredProgram(programId, programVersion) ) import Distribution.Simple.Setup          ( RegisterFlags(..), CopyDest(..)          , fromFlag, fromFlagOrDefault, flagToMaybe )@@ -95,7 +93,7 @@          , showInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, writeUTF8File, writeFileAtomic+         ( writeUTF8File, writeFileAtomic          , die, notice, setupMessage ) import Distribution.System          ( OS(..), buildOS )@@ -103,7 +101,7 @@          ( display ) import Distribution.Version ( Version(..) ) import Distribution.Verbosity as Verbosity-         ( Verbosity, normal, deafening, silent )+         ( Verbosity, normal ) import Distribution.Compat.CopyFile          ( setFileExecutable ) @@ -112,10 +110,10 @@          ( getCurrentDirectory, removeDirectoryRecursive ) import System.IO.Error (try) -import Control.Monad (when) import Data.Maybe          ( isJust, fromMaybe, maybeToList )-import Data.List (partition, nub)+import Data.List+         ( partition, nub )   -- -----------------------------------------------------------------------------@@ -135,7 +133,7 @@     case () of      _ | modeGenerateRegFile   -> writeRegistrationFile installedPkgInfo        | modeGenerateRegScript -> writeRegisterScript   installedPkgInfo-       | otherwise             -> registerPackage' verbosity+       | otherwise             -> registerPackage verbosity                                     installedPkgInfo pkg lbi inplace packageDbs    where@@ -167,6 +165,7 @@         Hugs -> notice verbosity "Registration scripts not needed for hugs"         JHC  -> notice verbosity "Registration scripts not needed for jhc"         NHC  -> notice verbosity "Registration scripts not needed for nhc98"+        UHC  -> notice verbosity "Registration scripts not needed for uhc"         _    -> die "Registration scripts are not implemented for this compiler"  register _ _ regFlags = notice verbosity "No package to register"@@ -211,66 +210,28 @@                 -> PackageDescription                 -> LocalBuildInfo                 -> Bool-                -> PackageDB-                -> IO ()-registerPackage verbosity installedPkgInfo pkg lbi inplace packageDb =-    registerPackage' verbosity installedPkgInfo pkg lbi inplace packageDbs-  where-    packageDbs-      | registrationPackageDB (withPackageDB lbi) == packageDb-                  = withPackageDB lbi-      | otherwise = withPackageDB lbi ++ [packageDb]--registerPackage' :: Verbosity-                -> InstalledPackageInfo-                -> PackageDescription-                -> LocalBuildInfo-                -> Bool                 -> PackageDBStack                 -> IO ()-registerPackage' verbosity installedPkgInfo pkg lbi inplace packageDbs = do+registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do   setupMessage verbosity "Registering" (packageId pkg)   case compilerFlavor (compiler lbi) of-    GHC  -> registerPackageGHC  verbosity installedPkgInfo pkg lbi inplace packageDbs-    LHC  -> registerPackageLHC  verbosity installedPkgInfo pkg lbi inplace packageDbs-    Hugs -> registerPackageHugs verbosity installedPkgInfo pkg lbi inplace packageDbs+    GHC  -> GHC.registerPackage  verbosity installedPkgInfo pkg lbi inplace packageDbs+    LHC  -> LHC.registerPackage  verbosity installedPkgInfo pkg lbi inplace packageDbs+    Hugs -> Hugs.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs+    UHC  -> UHC.registerPackage  verbosity installedPkgInfo pkg lbi inplace packageDbs     JHC  -> notice verbosity "Registering for jhc (nothing to do)"     NHC  -> notice verbosity "Registering for nhc98 (nothing to do)"     _    -> die "Registering is not implemented for this compiler"  -registerPackageGHC, registerPackageLHC, registerPackageHugs-  :: Verbosity-  -> InstalledPackageInfo-  -> PackageDescription-  -> LocalBuildInfo-  -> Bool-  -> PackageDBStack-  -> IO ()-registerPackageGHC verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do-  let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)-  reregister verbosity ghcPkg packageDbs installedPkgInfo--registerPackageLHC verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do-  let Just lhcPkg = lookupProgram lhcPkgProgram (withPrograms lbi)-  reregister verbosity lhcPkg packageDbs installedPkgInfo--registerPackageHugs verbosity installedPkgInfo pkg lbi inplace _packageDbs = do-  when inplace $ die "--inplace is not supported with Hugs"-  let installDirs = absoluteInstallDirs pkg lbi NoCopyDest-  createDirectoryIfMissingVerbose verbosity True (libdir installDirs)-  writeUTF8File (libdir installDirs </> "package.conf")-                (showInstalledPackageInfo installedPkgInfo)-- writeHcPkgRegisterScript :: Verbosity                          -> InstalledPackageInfo                          -> ConfiguredProgram                          -> PackageDBStack                          -> IO () writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDbs = do-  let invocation  = reregisterInvocation hcPkg Verbosity.normal-                      packageDbs installedPkgInfo+  let invocation  = HcPkg.reregisterInvocation hcPkg Verbosity.normal+                      packageDbs (Right installedPkgInfo)       regScript   = invocationAsSystemScript buildOS   invocation    notice verbosity ("Creating package registration script: " ++ regScriptFileName)@@ -426,48 +387,3 @@ unregScriptFileName = case buildOS of                           Windows -> "unregister.bat"                           _       -> "unregister.sh"--reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack-           -> InstalledPackageInfo-           -> IO ()-reregister verbosity hcPkg packagedb pkgFile =-  runProgramInvocation verbosity-    (reregisterInvocation hcPkg verbosity packagedb pkgFile)--reregisterInvocation :: ConfiguredProgram -> Verbosity -> PackageDBStack-                    -> InstalledPackageInfo-                    -> ProgramInvocation-reregisterInvocation hcPkg verbosity packagedbs pkgInfo =-    (programInvocation hcPkg args) {-      progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),-      progInvokeInputEncoding = IOEncodingUTF8-    }-  where-    args = ["update", "-"] ++ packageDbStackOpts packagedbs-        ++ verbosityOpts verbosity--    verbosityOpts :: Verbosity -> [String]-    verbosityOpts v--      -- ghc-pkg < 6.11 does not support -v-      | programId hcPkg == "ghc-pkg"-     && programVersion hcPkg < Just (Version [6,11] [])-                       = []--      | v >= deafening = ["-v2"]-      | v == silent    = ["-v0"]-      | otherwise      = []--    packageDbStackOpts :: PackageDBStack -> [String]-    packageDbStackOpts dbstack = case dbstack of-      (GlobalPackageDB:UserPackageDB:dbs) -> "--global"-                                           : "--user"-                                           : map specific dbs-      (GlobalPackageDB:dbs)               -> "--global"-                                           : "--no-user-package-conf"-                                           : map specific dbs-      _                                   -> ierror-      where-        specific (SpecificPackageDB db) = "--package-conf=" ++ db-        specific _ = ierror-        ierror     = error "internal error: unexpected package db stack"

@@ -71,6 +71,7 @@                                                                unregisterCommand,   SDistFlags(..),    emptySDistFlags,    defaultSDistFlags,    sdistCommand,   TestFlags(..),     emptyTestFlags,     defaultTestFlags,     testCommand,+  TestShowDetails(..),   CopyDest(..),   configureArgs, configureOptions,   installDirsOptions,@@ -87,7 +88,10 @@  import Distribution.Compiler () import Distribution.ReadE-import Distribution.Text (display, Text(parse))+import Distribution.Text+         ( Text(..), display )+import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint as Disp import Distribution.Package ( Dependency(..) ) import Distribution.PackageDescription          ( FlagName(..), FlagAssignment )@@ -97,7 +101,7 @@          ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..)          , OptimisationLevel(..), flagToOptimisationLevel ) import Distribution.Simple.Utils-         ( wrapLine, lowercase )+         ( wrapLine, lowercase, intercalate ) import Distribution.Simple.Program (Program(..), ProgramConfiguration,                              knownPrograms,                              addKnownProgram, emptyProgramConfiguration,@@ -105,12 +109,13 @@ import Distribution.Simple.InstallDirs          ( InstallDirs(..), CopyDest(..),            PathTemplate, toPathTemplate, fromPathTemplate )-import Data.List (sort)-import Data.Char (isSpace)-import Data.Monoid (Monoid(..)) import Distribution.Verbosity --- XXX Not sure where this should live+import Data.List   ( sort )+import Data.Char   ( isSpace, isAlpha )+import Data.Monoid ( Monoid(..) )++-- FIXME Not sure where this should live defaultDistPref :: FilePath defaultDistPref = "dist" @@ -135,7 +140,7 @@ -- Its monoid instance gives us the behaviour where it starts out as -- 'NoFlag' and later flags override earlier ones. ---data Flag a = Flag a | NoFlag deriving (Show, Eq)+data Flag a = Flag a | NoFlag deriving (Show, Read, Eq)  instance Functor Flag where   fmap f (Flag x) = Flag (f x)@@ -282,9 +287,10 @@     configStripExes :: Flag Bool,      -- ^Enable executable stripping     configConstraints :: [Dependency], -- ^Additional constraints for                                        -- dependencies-    configConfigurationsFlags :: FlagAssignment+    configConfigurationsFlags :: FlagAssignment,+    configTests :: Flag Bool     -- ^Enable test suite compilation   }-  deriving Show+  deriving (Read,Show)  defaultConfigFlags :: ProgramConfiguration -> ConfigFlags defaultConfigFlags progConf = emptyConfigFlags {@@ -302,7 +308,8 @@     configUserInstall  = Flag False,           --TODO: reverse this     configGHCiLib      = Flag True,     configSplitObjs    = Flag False, -- takes longer, so turn off by default-    configStripExes    = Flag True+    configStripExes    = Flag True,+    configTests  = Flag False   }  configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags@@ -333,7 +340,8 @@                     , (Flag NHC, ([] , ["nhc98"]), "compile with NHC")                     , (Flag JHC, ([] , ["jhc"]), "compile with JHC")                     , (Flag LHC, ([] , ["lhc"]), "compile with LHC")-                    , (Flag Hugs,([] , ["hugs"]), "compile with Hugs")])+                    , (Flag Hugs,([] , ["hugs"]), "compile with Hugs")+                    , (Flag UHC, ([] , ["uhc"]), "compile with UHC")])        ,option "w" ["with-compiler"]          "give the path to a particular compiler"@@ -350,6 +358,7 @@          "directory to receive the built package (hugs-only)"          configScratchDir (\v flags -> flags { configScratchDir = v })          (reqArgFlag "DIR")+      --TODO: eliminate scratchdir flag        ,option "" ["program-prefix"]           "prefix to be applied to installed executables"@@ -389,14 +398,10 @@                               Flag NormalOptimisation  -> [Nothing]                               Flag MaximumOptimisation -> [Just "2"]                               _                        -> [])-                 "O" ("enable-optimization": case showOrParseArgs of-                      -- Allow British English spelling:-                      ShowArgs -> []; ParseArgs -> ["enable-optimisation"])+                 "O" ["enable-optimization","enable-optimisation"]                  "Build with optimization (n is 0--2, default is 1)",           noArg (Flag NoOptimisation) []-                ("disable-optimization": case showOrParseArgs of-                      -- Allow British English spelling:-                      ShowArgs -> []; ParseArgs -> ["disable-optimisation"])+                ["disable-optimization","disable-optimisation"]                 "Build without optimization"          ] @@ -453,6 +458,10 @@          (reqArg "DEPENDENCY"                  (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))                  (map (\x -> display x)))+      ,option "" ["tests"]+         "dependency checking and compilation for test suites listed in the package description file."+         configTests (\v flags -> flags { configTests = v })+         (boolOpt [] [])       ]   where     readFlagList :: String -> FlagAssignment@@ -559,7 +568,8 @@     configExtraLibDirs  = mempty,     configConstraints   = mempty,     configExtraIncludeDirs    = mempty,-    configConfigurationsFlags = mempty+    configConfigurationsFlags = mempty,+    configTests   = mempty   }   mappend a b =  ConfigFlags {     configPrograms      = configPrograms b,@@ -588,7 +598,8 @@     configExtraLibDirs  = combine configExtraLibDirs,     configConstraints   = combine configConstraints,     configExtraIncludeDirs    = combine configExtraIncludeDirs,-    configConfigurationsFlags = combine configConfigurationsFlags+    configConfigurationsFlags = combine configConfigurationsFlags,+    configTests = combine configTests   }     where combine field = field a `mappend` field b @@ -631,13 +642,6 @@          copyDest (\v flags -> flags { copyDest = v })          (reqArg "DIR" (succeedReadE (Flag . CopyTo))                        (\f -> case f of Flag (CopyTo p) -> [p]; _ -> []))--      ,option "" ["copy-prefix"]-         "[DEPRECATED, directory to copy files to instead of prefix]"-         copyDest (\v flags -> flags { copyDest = v })-         (reqArg' "DIR" (Flag . CopyPrefix)-                       (\f -> case f of Flag (CopyPrefix p) -> [p]; _ -> []))-       ]  emptyCopyFlags :: CopyFlags@@ -1025,7 +1029,7 @@          haddockCss (\v flags -> flags { haddockCss = v })          (reqArgFlag "PATH") -      ,option "" ["hyperlink-source"]+      ,option "" ["hyperlink-source","hyperlink-sources"]          "Hyperlink the documentation to the source code (using HsColour)"          haddockHscolour (\v flags -> flags { haddockHscolour = v })          trueArg@@ -1191,16 +1195,49 @@ -- * Test flags -- ------------------------------------------------------------ +data TestShowDetails = Never | Failures | Always+    deriving (Eq, Ord, Enum, Bounded, Show)++knownTestShowDetails :: [TestShowDetails]+knownTestShowDetails = [minBound..maxBound]++instance Text TestShowDetails where+    disp  = Disp.text . lowercase . show++    parse = maybe Parse.pfail return . classify =<< ident+      where+        ident        = Parse.munch1 (\c -> isAlpha c || c == '_' || c == '-')+        classify str = lookup (lowercase str) enumMap+        enumMap     :: [(String, TestShowDetails)]+        enumMap      = [ (display x, x)+                       | x <- knownTestShowDetails ]++--TODO: do we need this instance?+instance Monoid TestShowDetails where+    mempty = Never+    mappend a b = if a < b then b else a+ data TestFlags = TestFlags {     testDistPref  :: Flag FilePath,-    testVerbosity :: Flag Verbosity+    testVerbosity :: Flag Verbosity,+    testHumanLog :: Flag PathTemplate,+    testMachineLog :: Flag PathTemplate,+    testShowDetails :: Flag TestShowDetails,+    --TODO: eliminate the test list and pass it directly as positional args to the testHook+    testList :: Flag [String],+    -- TODO: think about if/how options are passed to test exes+    testOptions :: Flag [String]   }-  deriving Show  defaultTestFlags :: TestFlags defaultTestFlags  = TestFlags {     testDistPref  = Flag defaultDistPref,-    testVerbosity = Flag normal+    testVerbosity = Flag normal,+    testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log",+    testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log",+    testShowDetails = toFlag Failures,+    testList = Flag [],+    testOptions = Flag []   }  testCommand :: CommandUI TestFlags@@ -1210,10 +1247,44 @@     shortDesc  = "Run the test suite, if any (configure with UserHooks)."     longDesc   = Nothing     options showOrParseArgs =-      [optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v })-      ,optionDistPref-         testDistPref (\d flags -> flags { testDistPref = d })-         showOrParseArgs+      [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v })+      , optionDistPref+            testDistPref (\d flags -> flags { testDistPref = d })+            showOrParseArgs+      , option [] ["log"]+            ("Log all test suite results to file (name template can use "+            ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)")+            testHumanLog (\v flags -> flags { testHumanLog = v })+            (reqArg' "TEMPLATE"+                (toFlag . toPathTemplate)+                (flagToList . fmap fromPathTemplate))+      , option [] ["machine-log"]+            ("Produce a machine-readable log file (name template can use "+            ++ "$pkgid, $compiler, $os, $arch, $result)")+            testMachineLog (\v flags -> flags { testMachineLog = v })+            (reqArg' "TEMPLATE"+                (toFlag . toPathTemplate)+                (flagToList . fmap fromPathTemplate))+      , option [] ["show-details"]+            ("'always': always show results of individual test cases. "+             ++ "'never': never show results of individual test cases. "+             ++ "'failures': show results of failing test cases.")+            testShowDetails (\v flags -> flags { testShowDetails = v })+            (reqArg "FILTER"+                (readP_to_E (\_ -> "--show-details flag expects one of "+                              ++ intercalate ", "+                                   (map display knownTestShowDetails))+                            (fmap toFlag parse))+                (flagToList . fmap display))+      , option [] ["test-options"]+            "give extra options to test executables"+            testOptions (\v flags -> flags { testOptions = v })+            (reqArg' "OPTS" (toFlag . splitArgs) (fromFlagOrDefault []))+      , option [] ["test-option"]+            ("give extra option to test executables "+            ++ "(no need to quote options containing spaces)")+            testOptions (\v flags -> flags { testOptions = v })+            (reqArg' "OPT" (\x -> toFlag [x]) (fromFlagOrDefault []))       ]  emptyTestFlags :: TestFlags@@ -1222,11 +1293,21 @@ instance Monoid TestFlags where   mempty = TestFlags {     testDistPref  = mempty,-    testVerbosity = mempty+    testVerbosity = mempty,+    testHumanLog = mempty,+    testMachineLog = mempty,+    testShowDetails = mempty,+    testList = mempty,+    testOptions = mempty   }   mappend a b = TestFlags {     testDistPref  = combine testDistPref,-    testVerbosity = combine testVerbosity+    testVerbosity = combine testVerbosity,+    testHumanLog = combine testHumanLog,+    testMachineLog = combine testMachineLog,+    testShowDetails = combine testShowDetails,+    testList = combine testList,+    testOptions = combine testOptions   }     where combine field = field a `mappend` field b 

@@ -127,7 +127,7 @@              | otherwise = pkg     setupMessage verbosity "Building source dist for" (packageId pkg') -    -- XXX This looks a bit suspicious. Should createArchive be passed+    -- 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

@@ -0,0 +1,435 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Test+-- Copyright   :  Thomas Tuegel 2010+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This is the entry point into testing a built package. It performs the+-- \"@.\/setup test@\" action. It runs test suites designated in the package+-- description and reports on the results.++{- 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.Test+    ( test+    , runTests+    , writeSimpleTestStub+    , stubFilePath+    , stubName+    , PackageLog(..)+    , TestSuiteLog(..)+    , Case(..)+    , suitePassed, suiteFailed, suiteError+    ) where++import Distribution.Compat.TempFile ( openTempFile )+import Distribution.ModuleName ( ModuleName )+import Distribution.Package+    ( PackageId )+import qualified Distribution.PackageDescription as PD+         ( PackageDescription(..), TestSuite(..)+         , TestSuiteInterface(..), testType )+import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )+import Distribution.Simple.BuildPaths ( exeExtension )+import Distribution.Simple.Compiler ( Compiler(..), CompilerId )+import Distribution.Simple.InstallDirs+    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)+    , substPathTemplate , toPathTemplate, PathTemplate )+import qualified Distribution.Simple.LocalBuildInfo as LBI+    ( LocalBuildInfo(..) )+import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag )+import Distribution.Simple.Utils ( die, notice )+import qualified Distribution.TestSuite as TestSuite+    ( Test, Result(..), ImpureTestable(..), TestOptions(..), Options(..) )+import Distribution.Text+import Distribution.Verbosity ( normal, Verbosity )+import Distribution.System ( buildPlatform, Platform )++import Control.Exception ( bracket )+import Control.Monad ( when, liftM, unless )+import Data.Char ( toUpper )+import Data.Monoid ( mempty )+import System.Directory+    ( createDirectoryIfMissing, doesFileExist, getCurrentDirectory+    , removeFile )+import System.Environment ( getEnvironment )+import System.Exit ( ExitCode(..), exitFailure, exitWith )+import System.FilePath ( (</>), (<.>) )+import System.IO ( hClose, IOMode(..), openFile )+import System.Process ( runProcess, waitForProcess )++-- | Logs all test results for a package, broken down first by test suite and+-- then by test case.+data PackageLog = PackageLog+    { package :: PackageId+    , compiler :: CompilerId+    , platform :: Platform+    , testSuites :: [TestSuiteLog]+    }+    deriving (Read, Show, Eq)++-- | A 'PackageLog' with package and platform information specified.+localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog+localPackageLog pkg_descr lbi = PackageLog+    { package = PD.package pkg_descr+    , compiler = compilerId $ LBI.compiler lbi+    , platform = buildPlatform+    , testSuites = []+    }++-- | Logs test suite results, itemized by test case.+data TestSuiteLog = TestSuiteLog+    { name :: String+    , cases :: [Case]+    , logFile :: FilePath    -- path to human-readable log file+    }+    deriving (Read, Show, Eq)++data Case = Case+    { caseName :: String+    , caseOptions :: TestSuite.Options+    , caseResult :: TestSuite.Result+    }+    deriving (Read, Show, Eq)++getTestOptions :: TestSuite.Test -> TestSuiteLog -> IO TestSuite.Options+getTestOptions t l =+    case filter ((== TestSuite.name t) . caseName) (cases l) of+        (x:_) -> return $ caseOptions x+        _ -> TestSuite.defaultOptions t++-- | From a 'TestSuiteLog', determine if the test suite passed.+suitePassed :: TestSuiteLog -> Bool+suitePassed = all (== TestSuite.Pass) . map caseResult . cases++-- | From a 'TestSuiteLog', determine if the test suite failed.+suiteFailed :: TestSuiteLog -> Bool+suiteFailed = any isFail . map caseResult . cases+    where isFail (TestSuite.Fail _) = True+          isFail _ = False++-- | From a 'TestSuiteLog', determine if the test suite encountered errors.+suiteError :: TestSuiteLog -> Bool+suiteError = any isError . map caseResult . cases+    where isError (TestSuite.Error _) = True+          isError _ = False++-- | Run a test executable, logging the output and generating the appropriate+-- summary messages.+testController :: TestFlags+               -- ^ flags Cabal was invoked with+               -> PD.PackageDescription+               -- ^ description of package the test suite belongs to+               -> PD.TestSuite+               -- ^ TestSuite being tested+               -> (FilePath -> String)+               -- ^ prepare standard input for test executable+               -> FilePath -- ^ executable name+               -> (ExitCode -> String -> TestSuiteLog)+               -- ^ generator for the TestSuiteLog+               -> (TestSuiteLog -> FilePath)+               -- ^ generator for final human-readable log filename+               -> IO TestSuiteLog+testController flags pkg_descr suite preTest cmd postTest logNamer = do+    let distPref = fromFlag $ testDistPref flags+        verbosity = fromFlag $ testVerbosity flags+        testLogDir = distPref </> "test"+        options = fromFlag $ testOptions flags++    pwd <- getCurrentDirectory+    existingEnv <- getEnvironment+    let dataDirPath = pwd </> PD.dataDir pkg_descr+        shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath)+                        : existingEnv++    bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog ->+        bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do++            -- Write summary notices indicating start of test suite+            notice verbosity $ summarizeSuiteStart $ PD.testName suite+            appendFile tempLog $ summarizeSuiteStart $ PD.testName suite++            -- Prepare standard input for test executable+            appendFile tempInput $ preTest tempInput++            -- Run test executable+            exit <- do+              hLog <- openFile tempLog AppendMode+              hIn  <- openFile tempInput ReadMode+              -- these handles get closed by runProcess+              proc <- runProcess cmd options Nothing shellEnv+                        (Just hIn) (Just hLog) (Just hLog)+              waitForProcess proc++            -- Generate TestSuiteLog from executable exit code and a machine-+            -- readable test log+            suiteLog <- readFile tempInput >>= return . postTest exit++            -- Generate final log file name+            let finalLogName = testLogDir </> logNamer suiteLog+                suiteLog' = suiteLog { logFile = finalLogName }++            -- Write summary notice to log file indicating end of test suite+            appendFile tempLog $ summarizeSuiteFinish suiteLog'++            -- Append contents of temporary log file to the final human-+            -- readable log file+            readFile tempLog >>= appendFile (logFile suiteLog')++            -- Show the contents of the human-readable log file on the terminal+            -- if there is a failure and/or detailed output is requested+            let details = fromFlag $ testShowDetails flags+                whenPrinting = when $ (details > Never)+                    && (not (suitePassed suiteLog) || details == Always)+                    && verbosity >= normal+            whenPrinting $ readFile (logFile suiteLog') >>=+                putStr . unlines . map (">>> " ++) . lines++            -- Write summary notice to terminal indicating end of test suite+            notice verbosity $ summarizeSuiteFinish suiteLog'++            return suiteLog'+    where+        deleteIfExists file = do+            exists <- doesFileExist file+            when exists $ removeFile file++        openCabalTemp testLogDir = do+            (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log"+            hClose h >> return f+++-- |Perform the \"@.\/setup test@\" action.+test :: PD.PackageDescription   -- ^information from the .cabal file+     -> LBI.LocalBuildInfo      -- ^information from the configure step+     -> TestFlags               -- ^flags sent to test+     -> IO ()+test pkg_descr lbi flags = do+    let verbosity = fromFlag $ testVerbosity flags+        humanTemplate = fromFlag $ testHumanLog flags+        machineTemplate = fromFlag $ testMachineLog flags+        distPref = fromFlag $ testDistPref flags+        testLogDir = distPref </> "test"+        testNames = fromFlag $ testList flags+        pkgTests = PD.testSuites pkg_descr++        doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog+        doTest (suite, mLog) = do+            let testLogPath = testSuiteLogPath humanTemplate pkg_descr lbi+                go pre cmd post = testController flags pkg_descr suite+                                                 pre cmd post testLogPath+            case PD.testInterface suite of+              PD.TestSuiteExeV10 _ _ -> do+                    let cmd = LBI.buildDir lbi </> PD.testName suite+                            </> PD.testName suite <.> exeExtension+                        preTest _ = ""+                        postTest exit _ =+                            let r = case exit of+                                    ExitSuccess -> TestSuite.Pass+                                    ExitFailure c -> TestSuite.Fail+                                        $ "exit code: " ++ show c+                            in TestSuiteLog+                                { name = PD.testName suite+                                , cases = [Case (PD.testName suite) mempty r]+                                , logFile = ""+                                }+                    go preTest cmd postTest++              PD.TestSuiteLibV09 _ _ -> do+                    let cmd = LBI.buildDir lbi </> stubName suite+                            </> stubName suite <.> exeExtension+                        oldLog = case mLog of+                            Nothing -> TestSuiteLog+                                { name = PD.testName suite+                                , cases = []+                                , logFile = []+                                }+                            Just l -> l+                        preTest f = show $ oldLog { logFile = f }+                        postTest _ = read+                    go preTest cmd postTest++              _ -> return TestSuiteLog+                            { name = PD.testName suite+                            , cases = [Case (PD.testName suite) mempty+                                $ TestSuite.Error $ "No support for running "+                                ++ "test suite type: "+                                ++ show (disp $ PD.testType suite)]+                            , logFile = ""+                            }++    testsToRun <- case testNames of+            [] -> return $ zip pkgTests $ repeat Nothing+            names -> flip mapM names $ \tName ->+                let testMap = map (\x -> (PD.testName x, x)) pkgTests+                in case lookup tName testMap of+                    Just t -> return (t, Nothing)+                    _ -> die $ "no such test: " ++ tName++    createDirectoryIfMissing True testLogDir++    let totalSuites = length testsToRun+    notice verbosity $ "Running " ++ show totalSuites ++ " test suites..."+    suites <- mapM doTest testsToRun+    let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites }+        packageLogFile = (</>) testLogDir+            $ packageLogPath machineTemplate pkg_descr lbi+    allOk <- summarizePackage verbosity packageLog+    writeFile packageLogFile $ show packageLog+    unless allOk exitFailure++-- | Print a summary to the console after all test suites have been run+-- indicating the number of successful test suites and cases.  Returns 'True' if+-- all test suites passed and 'False' otherwise.+summarizePackage :: Verbosity -> PackageLog -> IO Bool+summarizePackage verbosity packageLog = do+    let cases' = map caseResult $ concatMap cases $ testSuites packageLog+        passedCases = length $ filter (== TestSuite.Pass) cases'+        totalCases = length cases'+        passedSuites = length $ filter suitePassed $ testSuites packageLog+        totalSuites = length $ testSuites packageLog+    notice verbosity $ show passedSuites ++ " of " ++ show totalSuites+        ++ " test suites (" ++ show passedCases ++ " of "+        ++ show totalCases ++ " test cases) passed."+    return $! passedSuites == totalSuites++-- | Print a summary of a single test case's result to the console, supressing+-- output for certain verbosity or test filter levels.+summarizeCase :: Verbosity -> TestShowDetails -> Case -> IO ()+summarizeCase verbosity details t =+    when shouldPrint $ notice verbosity $ "Test case " ++ caseName t+        ++ ": " ++ show (caseResult t)+    where shouldPrint = (details > Never) && (notPassed || details == Always)+          notPassed = caseResult t /= TestSuite.Pass++-- | Print a summary of the test suite's results on the console, suppressing+-- output for certain verbosity or test filter levels.+summarizeSuiteFinish :: TestSuiteLog -> String+summarizeSuiteFinish testLog = unlines+    [ "Test suite " ++ name testLog ++ ": " ++ resStr+    , "Test suite logged to: " ++ logFile testLog+    ]+    where resStr = map toUpper (resultString testLog)++summarizeSuiteStart :: String -> String+summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n"++resultString :: TestSuiteLog -> String+resultString l | suiteError l = "error"+               | suiteFailed l = "fail"+               | otherwise = "pass"++testSuiteLogPath :: PathTemplate+                 -> PD.PackageDescription+                 -> LBI.LocalBuildInfo+                 -> TestSuiteLog+                 -> FilePath+testSuiteLogPath template pkg_descr lbi testLog =+    fromPathTemplate $ substPathTemplate env template+    where+        env = initialPathTemplateEnv+                (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)+                ++  [ (TestSuiteNameVar, toPathTemplate $ name testLog)+                    , (TestSuiteResultVar, result)+                    ]+        result = toPathTemplate $ resultString testLog++packageLogPath :: PathTemplate+               -> PD.PackageDescription+               -> LBI.LocalBuildInfo+               -> FilePath+packageLogPath template pkg_descr lbi =+    fromPathTemplate $ substPathTemplate env template+    where+        env = initialPathTemplateEnv+                (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)++-- | The filename of the source file for the stub executable associated with a+-- library 'TestSuite'.+stubFilePath :: PD.TestSuite -> FilePath+stubFilePath t = stubName t <.> "hs"++-- | The name of the stub executable associated with a library 'TestSuite'.+stubName :: PD.TestSuite -> FilePath+stubName t = PD.testName t ++ "Stub"++-- | Write the source file for a library 'TestSuite' stub executable.+writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub+                                    -- is being created+                    -> FilePath     -- ^ path to directory where stub source+                                    -- should be located+                    -> IO ()+writeSimpleTestStub t dir = do+    createDirectoryIfMissing True dir+    let filename = dir </> stubFilePath t+        PD.TestSuiteLibV09 _ m = PD.testInterface t+    writeFile filename $ simpleTestStub m++-- | Source code for library test suite stub executable+simpleTestStub :: ModuleName -> String+simpleTestStub m = unlines+    [ "module Main ( main ) where"+    , "import Control.Monad ( liftM )"+    , "import Distribution.Simple.Test ( runTests )"+    , "import " ++ show (disp m) ++ " ( tests )"+    , "main :: IO ()"+    , "main = runTests tests"+    ]++-- | The test runner used in library "TestSuite" stub executables.  Runs a list+-- of 'Test's.  An executable calling this function is meant to be invoked as+-- the child of a Cabal process during @.\/setup test@.  A 'TestSuiteLog',+-- provided by Cabal, is read from the standard input; it supplies the name of+-- the test suite and the location of the machine-readable test suite log file.+-- Human-readable log information is written to the standard output for capture+-- by the calling Cabal process.+runTests :: [TestSuite.Test] -> IO ()+runTests tests = do+    testLogIn <- liftM read getContents+    let go :: TestSuite.Test -> IO Case+        go t = do+            o <- getTestOptions t testLogIn+            r <- TestSuite.runM t o+            let ret = Case+                    { caseName = TestSuite.name t+                    , caseOptions = o+                    , caseResult = r+                    }+            summarizeCase normal Always ret+            return ret+    cases' <- mapM go tests+    let testLog = testLogIn { cases = cases'}+    writeFile (logFile testLog) $ show testLog+    when (suiteError testLog) $ exitWith $ ExitFailure 2+    when (suiteFailed testLog) $ exitWith $ ExitFailure 1+    exitWith ExitSuccess

@@ -0,0 +1,296 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.UHC+-- Copyright   :  Andres Loeh 2009+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module contains most of the UHC-specific code for configuring, building+-- and installing packages.+--+-- Thanks to the authors of the other implementation-specific files, in+-- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for+-- inspiration on how to design this module.++{-+Copyright (c) 2009, Andres Loeh+Copyright (c) 2003-2005, Isaac Jones+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.UHC (+    configure, getInstalledPackages,+    buildLib, buildExe, installLib, registerPackage+  ) where++import Control.Monad+import Data.List+import Distribution.Compat.ReadP+import Distribution.InstalledPackageInfo+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Simple.BuildPaths+import Distribution.Simple.Compiler as C+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PackageIndex+import Distribution.Simple.Program+import Distribution.Simple.Utils+import Distribution.Text+import Distribution.Verbosity+import Distribution.Version+import Language.Haskell.Extension+import System.Directory+import System.FilePath++-- -----------------------------------------------------------------------------+-- Configuring++configure :: Verbosity -> Maybe FilePath -> Maybe FilePath+          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)+configure verbosity hcPath _hcPkgPath conf = do++  (_uhcProg, uhcVersion, conf') <-+    requireProgramVersion verbosity uhcProgram+    (orLaterVersion (Version [1,0,2] []))+    (userMaybeSpecifyPath "uhc" hcPath conf)++  let comp = Compiler {+               compilerId          =  CompilerId UHC uhcVersion,+               compilerLanguages   =  uhcLanguages,+               compilerExtensions  =  uhcLanguageExtensions+             }+  return (comp, conf')++uhcLanguages :: [(Language, C.Flag)]+uhcLanguages = [(Haskell98, "")]++-- | 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, "")]++getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration+                     -> IO PackageIndex+getInstalledPackages verbosity comp packagedbs conf = do+  let compilerid = compilerId comp+  systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram conf ["--meta-pkgdir-system"]+  userPkgDir   <- getUserPackageDir+  let pkgDirs    = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs)+  -- putStrLn $ "pkgdirs: " ++ show pkgDirs+  -- call to "lines" necessary, because pkgdir contains an extra newline at the end+  pkgs <- liftM (map addBuiltinVersions . concat) .+          mapM (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d)) .+          concatMap lines $ pkgDirs+  -- putStrLn $ "pkgs: " ++ show pkgs+  let iPkgs =+        map mkInstalledPackageInfo $+        concatMap parsePackage $+        pkgs+  -- putStrLn $ "installed pkgs: " ++ show iPkgs+  return (fromList iPkgs)++getUserPackageDir :: IO FilePath+getUserPackageDir =+  do+    homeDir <- getHomeDirectory+    return $ homeDir </> ".cabal" </> "lib"  -- TODO: determine in some other way++packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath]+packageDbPaths user system db =+  case db of+    GlobalPackageDB         ->  [ system ]+    UserPackageDB           ->  [ user ]+    SpecificPackageDB path  ->  [ path ]++-- | Hack to add version numbers to UHC-builtin packages. This should sooner or+-- later be fixed on the UHC side.+addBuiltinVersions :: String -> String+{-+addBuiltinVersions "uhcbase"  = "uhcbase-1.0"+addBuiltinVersions "base"  = "base-3.0"+addBuiltinVersions "array" = "array-0.2"+-}+addBuiltinVersions xs      = xs++-- | Name of the installed package config file.+installedPkgConfig :: String+installedPkgConfig = "installed-pkg-config"++-- | Check if a certain dir contains a valid package. Currently, we are+-- looking only for the presence of an installed package configuration.+-- TODO: Actually make use of the information provided in the file.+isPkgDir :: String -> String -> String -> IO Bool+isPkgDir _ _   ('.' : _)  = return False  -- ignore files starting with a .+isPkgDir c dir xs         = do+                              let candidate = dir </> uhcPackageDir xs c+                              -- putStrLn $ "trying: " ++ candidate+                              doesFileExist (candidate </> installedPkgConfig)++parsePackage :: String -> [PackageId]+parsePackage x = map fst (filter (\ (_,y) -> null y) (readP_to_S parse x))++-- | Create a trivial package info from a directory name.+mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo+mkInstalledPackageInfo p = emptyInstalledPackageInfo+  { installedPackageId = InstalledPackageId (display p),+    sourcePackageId    = p }+++-- -----------------------------------------------------------------------------+-- Building++buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo+                      -> Library            -> ComponentLocalBuildInfo -> IO ()+buildLib verbosity pkg_descr lbi lib clbi = do++  systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"]+  userPkgDir   <- getUserPackageDir+  let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi)+  let uhcArgs =    -- set package name+                   ["--pkg-build=" ++ display (packageId pkg_descr)]+                   -- common flags lib/exe+                ++ constructUHCCmdLine userPkgDir systemPkgDir+                                       lbi (libBuildInfo lib) clbi+                                       (buildDir lbi) verbosity+                   -- source files+                   -- suboptimal: UHC does not understand module names, so+                   -- we replace periods by path separators+                ++ map (map (\ c -> if c == '.' then pathSeparator else c))+                       (map display (libModules lib))++  runUhcProg uhcArgs+  +  return ()++buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo+                      -> Executable         -> ComponentLocalBuildInfo -> IO ()+buildExe verbosity _pkg_descr lbi exe clbi = do+  systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"]+  userPkgDir   <- getUserPackageDir+  let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi)+  let uhcArgs =    -- common flags lib/exe+                   constructUHCCmdLine userPkgDir systemPkgDir+                                       lbi (buildInfo exe) clbi+                                       (buildDir lbi) verbosity+                   -- output file+                ++ ["--output", buildDir lbi </> exeName exe]+                   -- main source module+                ++ [modulePath exe]+  runUhcProg uhcArgs++constructUHCCmdLine :: FilePath -> FilePath+                    -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo+                    -> FilePath -> Verbosity -> [String]+constructUHCCmdLine user system lbi bi clbi odir verbosity =+     -- verbosity+     (if      verbosity >= deafening then ["-v4"]+      else if verbosity >= normal    then []+      else                                ["-v0"])+  ++ hcOptions UHC bi+     -- flags for language extensions+  ++ languageToFlags   (compiler lbi) (defaultLanguage bi)+  ++ extensionsToFlags (compiler lbi) (usedExtensions bi)+     -- packages+  ++ ["--hide-all-packages"]+  ++ uhcPackageDbOptions user system (withPackageDB lbi)+  ++ ["--package=uhcbase"]+  ++ ["--package=" ++ display (pkgName pkgid) | (_, pkgid) <- componentPackageDeps clbi ]+     -- search paths+  ++ ["-i" ++ odir]+  ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]+  ++ ["-i" ++ autogenModulesDir lbi]+     -- output path+  ++ ["--odir=" ++ odir]+     -- optimization+  ++ (case withOptimization lbi of+        NoOptimisation       ->  ["-O0"]+        NormalOptimisation   ->  ["-O1"]+        MaximumOptimisation  ->  ["-O2"])++uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String]+uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x)+                                         (concatMap (packageDbPaths user system) db)++-- -----------------------------------------------------------------------------+-- Installation++installLib :: Verbosity -> LocalBuildInfo+           -> FilePath -> FilePath -> FilePath+           -> PackageDescription -> Library -> IO ()+installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library = do+    -- putStrLn $ "dest:  " ++ targetDir+    -- putStrLn $ "built: " ++ builtDir+    installDirectoryContents verbosity (builtDir </> display (packageId pkg)) targetDir++-- currently hardcoded UHC code generator and variant to use+uhcTarget, uhcTargetVariant :: String+uhcTarget        = "bc"+uhcTargetVariant = "plain"++-- root directory for a package in UHC+uhcPackageDir    :: String -> String -> FilePath+uhcPackageSubDir ::           String -> FilePath+uhcPackageDir    pkgid compilerid = pkgid </> uhcPackageSubDir compilerid+uhcPackageSubDir       compilerid = compilerid </> uhcTarget </> uhcTargetVariant++-- -----------------------------------------------------------------------------+-- Registering++registerPackage+  :: Verbosity+  -> InstalledPackageInfo+  -> PackageDescription+  -> LocalBuildInfo+  -> Bool+  -> PackageDBStack+  -> IO ()+registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do+    let installDirs = absoluteInstallDirs pkg lbi NoCopyDest+        pkgdir  | inplace   = buildDir lbi       </> uhcPackageDir    (display pkgid) (display compilerid)+                | otherwise = libdir installDirs </> uhcPackageSubDir                 (display compilerid)+    createDirectoryIfMissingVerbose verbosity True pkgdir+    writeUTF8File (pkgdir </> installedPkgConfig)+                  (showInstalledPackageInfo installedPkgInfo)+  where+    pkgid      = packageId pkg+    compilerid = compilerId (compiler lbi)

@@ -66,7 +66,7 @@ import Distribution.Simple.Setup          (ConfigFlags, BuildFlags, CleanFlags, CopyFlags,           InstallFlags, SDistFlags, RegisterFlags, HscolourFlags,-          HaddockFlags)+          HaddockFlags, TestFlags) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo)  type Args = [String]@@ -161,9 +161,18 @@     -- |Over-ride this hook to get different behavior during haddock.     haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (),     -- |Hook to run after haddock command.  Second arg indicates verbosity level.-    postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO ()+    postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (),++    -- |Hook to run before test command.+    preTest :: Args -> TestFlags -> IO HookedBuildInfo,+    -- |Over-ride this hook to get different behavior during test.+    testHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (),+    -- |Hook to run after test command.+    postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO ()   } +{-# DEPRECATED runTests "Please use the new testing interface instead!" #-}+ -- |Empty 'UserHooks' which do nothing. emptyUserHooks :: UserHooks emptyUserHooks@@ -201,7 +210,11 @@       postHscolour = ru,       preHaddock   = rn,       haddockHook  = ru,-      postHaddock  = ru+      postHaddock  = ru,+      preTest = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without+                                                     -- noExtraFlags+      testHook = ru,+      postTest = ru     }     where rn args  _ = noExtraFlags args >> return emptyHookedBuildInfo           ru _ _ _ _ = return ()

@@ -48,7 +48,6 @@  module Distribution.Simple.Utils (         cabalVersion,-        cabalBootstrapping,          -- * logging and errors         die,@@ -196,19 +195,16 @@          ( catchIO, catchExit, onException ) import Distribution.Verbosity --- We only get our own version number when we're building with ourselves-cabalVersion :: Version-#ifdef CABAL_VERSION-cabalVersion = Version [CABAL_VERSION] []-#else-cabalVersion = error "Cabal was not bootstrapped correctly"+#ifdef VERSION_base+import qualified Paths_Cabal (version) #endif -cabalBootstrapping :: Bool-#ifdef CABAL_VERSION-cabalBootstrapping = False+-- We only get our own version number when we're building with ourselves+cabalVersion :: Version+#ifdef VERSION_base+cabalVersion = Paths_Cabal.version #else-cabalBootstrapping = True+cabalVersion = Version [1,9999] []  --used when bootstrapping #endif  -- ----------------------------------------------------------------------------

@@ -0,0 +1,310 @@+{-# LANGUAGE CPP, ExistentialQuantification #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.TestSuite+-- Copyright   :  Thomas Tuegel 2010+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module defines the detailed test suite interface which makes it+-- possible to expose individual tests to Cabal or other test agents.++{- 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. -}++#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610))+#define NEW_EXCEPTION+#endif++module Distribution.TestSuite+    ( -- * Example+      -- $example+      -- * Options+      Options(..)+    , lookupOption+    , TestOptions(..)+      -- * Tests+    , Test+    , pure, impure+    , Result(..)+    , ImpureTestable(..)+    , PureTestable(..)+    ) where++#ifdef NEW_EXCEPTION+import Control.Exception ( evaluate, catch, throw, SomeException, fromException )+#else+import Control.Exception ( evaluate, catch, throw, Exception(IOException) )+#endif++--TODO: it is totally unreasonable that we have to import things from GHC.* here.+--      see ghc ticket #3517+#ifdef __GLASGOW_HASKELL__+#if __GLASGOW_HASKELL__ >= 612+import GHC.IO.Exception  ( IOErrorType(Interrupted) )+#else+import GHC.IOBase        ( IOErrorType(Interrupted) )+#endif+import System.IO.Error   ( ioeGetErrorType )+#endif++import Data.List ( unionBy )+import Data.Monoid ( Monoid(..) )+import Data.Typeable ( TypeRep )+import Prelude hiding ( catch )++-- | 'Options' are provided to pass options to test runners, making tests+-- reproducable.  Each option is a @('String', 'String')@ of the form+-- @(Name, Value)@.  Use 'mappend' to combine sets of 'Options'; if the same+-- option is given different values, the value from the left argument of+-- 'mappend' will be used.+newtype Options = Options [(String, String)]+    deriving (Read, Show, Eq)++instance Monoid Options where+    mempty = Options []+    mappend (Options a) (Options b) = Options $ unionBy (equating fst) a b+      where+        equating p x y = p x == p y+++class TestOptions t where+    -- | The name of the test.+    name :: t -> String++    -- | A list of the options a test recognizes.  The name and 'TypeRep' are+    -- provided so that test agents can ensure that user-specified options are+    -- correctly typed.+    options :: t -> [(String, TypeRep)]++    -- | The default options for a test.  Test frameworks should provide a new+    -- random seed, if appropriate.+    defaultOptions :: t -> IO Options++    -- | Try to parse the provided options.  Return the names of unparsable+    -- options.  This allows test agents to detect bad user-specified options.+    check :: t -> Options -> [String]++-- | Read an option from the specified set of 'Options'.  It is an error to+-- lookup an option that has not been specified.  For this reason, test agents+-- should 'mappend' any 'Options' against the 'defaultOptions' for a test, so+-- the default value specified by the test framework will be used for any+-- otherwise-unspecified options.+lookupOption :: Read r => String -> Options -> r+lookupOption n (Options opts) =+    case lookup n opts of+        Just str -> read str+        Nothing -> error $ "test option not specified: " ++ n++data Result+    = Pass          -- ^ indicates a successful test+    | Fail String   -- ^ indicates a test completed unsuccessfully;+                    -- the 'String' value should be a human-readable message+                    -- indicating how the test failed.+    | Error String  -- ^ indicates a test that could not be+                    -- completed due to some error; the test framework+                    -- should provide a message indicating the+                    -- nature of the error.+    deriving (Read, Show, Eq)++-- | Class abstracting impure tests.  Test frameworks should implement this+-- class only as a last resort for test types which actually require 'IO'.+-- In particular, tests that simply require pseudo-random number generation can+-- be implemented as pure tests.+class TestOptions t => ImpureTestable t where+    -- | Runs an impure test and returns the result.  Test frameworks+    -- implementing this class are responsible for converting any exceptions to+    -- the correct 'Result' value.+    runM :: t -> Options -> IO Result++-- | Class abstracting pure tests.  Test frameworks should prefer to implement+-- this class over 'ImpureTestable'.  A default instance exists so that any pure+-- test can be lifted into an impure test; when lifted, any exceptions are+-- automatically caught.  Test agents that lift pure tests themselves must+-- handle exceptions.+class TestOptions t => PureTestable t where+    -- | The result of a pure test.+    run :: t -> Options -> Result++-- | 'Test' is a wrapper for pure and impure tests so that lists containing+-- arbitrary test types can be constructed.+data Test+    = forall p. PureTestable p => PureTest p+    | forall i. ImpureTestable i => ImpureTest i++-- | A convenient function for wrapping pure tests into 'Test's.+pure :: PureTestable p => p -> Test+pure = PureTest++-- | A convenient function for wrapping impure tests into 'Test's.+impure :: ImpureTestable i => i -> Test+impure = ImpureTest++instance TestOptions Test where+    name (PureTest p) = name p+    name (ImpureTest i) = name i++    options (PureTest p) = options p+    options (ImpureTest i) = options i++    defaultOptions (PureTest p) = defaultOptions p+    defaultOptions (ImpureTest p) = defaultOptions p++    check (PureTest p) = check p+    check (ImpureTest p) = check p++instance ImpureTestable Test where+    runM (PureTest p) o = catch (evaluate $ run p o) handler++    -- Because we have to handle old and new style exceptions, GHC and non-GHC+    -- this code is totally horrible and really fragile. Has to be tested with+    -- lots of ghc versions to check it is right, and with non-ghc too. :-(+#ifdef NEW_EXCEPTION+      where+        handler :: SomeException -> IO Result+        handler e = case fromException e of+          Just ioe | isInterruptedError ioe -> throw e+          _                                 -> return (Error (show e))+#else+      where+        handler :: Exception -> IO Result+        handler e = case e of+          IOException ioe | isInterruptedError ioe -> throw e+          _                                        -> return (Error (show e))+#endif++        -- We do not want to catch control-C here, but only GHC+        -- defines the Interrupted exception type! (ticket #3517)+        isInterruptedError ioe =+#ifdef __GLASGOW_HASKELL__+          ioeGetErrorType ioe == Interrupted+#else+          False+#endif++    runM (ImpureTest i) o = runM i o++-- $example+-- The following terms are used carefully throughout this file:+--+--  [test interface]    The interface provided by this module.+--+--  [test agent]    A program used by package users to coordinates the running+--                  of tests and the reporting of their results.+--+--  [test framework]    A package used by software authors to specify tests,+--                      such as QuickCheck or HUnit.+--+-- Test frameworks are obligated to supply, at least, instances of the+-- 'TestOptions' and 'ImpureTestable' classes.  It is preferred that test+-- frameworks implement 'PureTestable' whenever possible, so that test agents+-- have an assurance that tests can be safely run in parallel.+--+-- Test agents that allow the user to specify options should avoid setting+-- options not listed by the 'options' method.  Test agents should use 'check'+-- before running tests with non-default options.  Test frameworks must+-- implement a 'check' function that attempts to parse the given options safely.+--+-- The packages cabal-test-hunit, cabal-test-quickcheck1, and+-- cabal-test-quickcheck2 provide simple interfaces to these popular test+-- frameworks.  An example from cabal-test-quickcheck2 is shown below.  A+-- better implementation would eliminate the console output from QuickCheck\'s+-- built-in runner and provide an instance of 'PureTestable' instead of+-- 'ImpureTestable'.+--+-- > import Control.Monad (liftM)+-- > import Data.Maybe (catMaybes, fromJust, maybe)+-- > import Data.Typeable (Typeable(..))+-- > import qualified Distribution.TestSuite as Cabal+-- > import System.Random (newStdGen, next, StdGen)+-- > import qualified Test.QuickCheck as QC+-- >+-- > data QCTest = forall prop. QC.Testable prop => QCTest String prop+-- >+-- > test :: QC.Testable prop => String -> prop -> Cabal.Test+-- > test n p = Cabal.impure $ QCTest n p+-- >+-- > instance Cabal.TestOptions QCTest where+-- >     name (QCTest n _) = n+-- >+-- >     options _ =+-- >         [ ("std-gen", typeOf (undefined :: String))+-- >         , ("max-success", typeOf (undefined :: Int))+-- >         , ("max-discard", typeOf (undefined :: Int))+-- >         , ("size", typeOf (undefined :: Int))+-- >         ]+-- >+-- >     defaultOptions _ = do+-- >         rng <- newStdGen+-- >         return $ Cabal.Options $+-- >             [ ("std-gen", show rng)+-- >             , ("max-success", show $ QC.maxSuccess QC.stdArgs)+-- >             , ("max-discard", show $ QC.maxDiscard QC.stdArgs)+-- >             , ("size", show $ QC.maxSize QC.stdArgs)+-- >             ]+-- >+-- >     check t (Cabal.Options opts) = catMaybes+-- >         [ maybeNothing "max-success" ([] :: [(Int, String)])+-- >         , maybeNothing "max-discard" ([] :: [(Int, String)])+-- >         , maybeNothing "size" ([] :: [(Int, String)])+-- >         ]+-- >         -- There is no need to check the parsability of "std-gen"+-- >         -- because the Read instance for StdGen always succeeds.+-- >         where+-- >             maybeNothing n x =+-- >                 maybe Nothing (\str ->+-- >                     if reads str == x then Just n else Nothing)+-- >                     $ lookup n opts+-- >+-- > instance Cabal.ImpureTestable QCTest where+-- >     runM (QCTest _ prop) o =+-- >         catch go (return . Cabal.Error . show)+-- >         where+-- >             go = do+-- >                 result <- QC.quickCheckWithResult args prop+-- >                 return $ case result of+-- >                         QC.Success {} -> Cabal.Pass+-- >                         QC.GaveUp {}->+-- >                             Cabal.Fail $ "gave up after "+-- >                                        ++ show (QC.numTests result)+-- >                                        ++ " tests"+-- >                         QC.Failure {} -> Cabal.Fail $ QC.reason result+-- >                         QC.NoExpectedFailure {} ->+-- >                             Cabal.Fail "passed (expected failure)"+-- >             args = QC.Args+-- >                 { QC.replay = Just+-- >                     ( Cabal.lookupOption "std-gen" o+-- >                     , Cabal.lookupOption "size" o+-- >                     )+-- >                 , QC.maxSuccess = Cabal.lookupOption "max-success" o+-- >                 , QC.maxDiscard = Cabal.lookupOption "max-discard" o+-- >                 , QC.maxSize = Cabal.lookupOption "size" o+-- >                 }

@@ -56,7 +56,7 @@ import Distribution.ReadE  data Verbosity = Silent | Normal | Verbose | Deafening-    deriving (Show, Eq, Ord, Enum, Bounded)+    deriving (Show, Read, Eq, Ord, Enum, Bounded)  -- We shouldn't print /anything/ unless an error occurs in silent mode silent :: Verbosity

@@ -113,8 +113,9 @@   | LaterVersion           Version -- > version  (NB. not >=)   | EarlierVersion         Version -- < version   | WildcardVersion        Version -- == ver.*   (same as >= ver && < ver+1)-  | UnionVersionRanges      VersionRange VersionRange-  | IntersectVersionRanges  VersionRange VersionRange+  | UnionVersionRanges     VersionRange VersionRange+  | IntersectVersionRanges VersionRange VersionRange+  | VersionRangeParens     VersionRange -- just '(exp)' parentheses syntax   deriving (Show,Read,Eq)  {-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}@@ -253,7 +254,8 @@     fold (WildcardVersion v)            = fold (wildcard v)     fold (UnionVersionRanges v1 v2)     = union (fold v1) (fold v2)     fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2)-    +    fold (VersionRangeParens v)         = fold v+     wildcard v = intersectVersionRanges                    (orLaterVersion v)                    (earlierVersion (wildcardUpperBound v))@@ -275,9 +277,10 @@                                                -- range defined by the wildcard.                   -> (a -> a -> a)             -- ^ @\"_ || _\"@ union                   -> (a -> a -> a)             -- ^ @\"_ && _\"@ intersection+                  -> (a -> a)                  -- ^ @\"(_)\"@ parentheses                   -> VersionRange -> a foldVersionRange' anyv this later earlier orLater orEarlier-                  wildcard union intersect = fold+                  wildcard union intersect parens = fold   where     fold AnyVersion                     = anyv     fold (ThisVersion v)                = this v@@ -296,6 +299,7 @@     fold (WildcardVersion v)            = wildcard v (wildcardUpperBound v)     fold (UnionVersionRanges v1 v2)     = union (fold v1) (fold v2)     fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2)+    fold (VersionRangeParens v)         = parens (fold v)   -- | Does this version fall within the given range?@@ -676,6 +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      where dispWild (Version b _) =                Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))@@ -720,7 +725,7 @@                                  (Parse.char ')' >> Parse.skipSpaces)                                  (do a <- p                                      Parse.skipSpaces-                                     return a)+                                     return (VersionRangeParens a))          digits = do           first <- Parse.satisfy Char.isDigit

@@ -6,7 +6,7 @@ -- Maintainer  :  libraries@haskell.org -- Portability :  portable ----- Haskell language extensions+-- Haskell language dialects and extensions  {- All rights reserved. @@ -39,6 +39,9 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}  module Language.Haskell.Extension (+        Language(..),+        knownLanguages,+         Extension(..),         knownExtensions,         deprecatedExtensions@@ -51,6 +54,48 @@ import Data.Array (Array, accumArray, bounds, Ix(inRange), (!))  -- ------------------------------------------------------------+-- * Language+-- ------------------------------------------------------------++-- | This represents a Haskell language dialect.+--+-- Language 'Extension's are interpreted relative to one of these base+-- languages.+--+data Language =++  -- | The Haskell 98 language as defined by the Haskell 98 report.+  -- <http://haskell.org/onlinereport/>+     Haskell98++  -- | The Haskell 2010 language as defined by the Haskell 2010 report.+  -- <http://www.haskell.org/onlinereport/haskell2010>+  | Haskell2010++  -- | An unknown language, identified by its name.+  | UnknownLanguage String+  deriving (Show, Read, Eq)++knownLanguages :: [Language]+knownLanguages = [Haskell98, Haskell2010]++instance Text Language where+  disp (UnknownLanguage other) = Disp.text other+  disp other                   = Disp.text (show other)++  parse = do+    lang <- Parse.munch1 Char.isAlphaNum+    return (classifyLanguage lang)++classifyLanguage :: String -> Language+classifyLanguage = \str -> case lookup str langTable of+    Just lang -> lang+    Nothing   -> UnknownLanguage str+  where+    langTable = [ (show lang, lang)+                | lang <- knownLanguages ]++-- ------------------------------------------------------------ -- * Extension -- ------------------------------------------------------------ @@ -61,92 +106,321 @@ -- -- * also to the 'knownExtensions' list below. --- |This represents language extensions beyond Haskell 98 that are--- supported by some implementations, usually in some special mode.+-- | This represents language extensions beyond a base 'Language' definition+-- (such as 'Haskell98') that are supported by some implementations, usually+-- in some special mode.+--+-- Where applicable, references are given to an implementation's+-- official documentation, e.g. \"GHC &#xa7; 7.2.1\" for an extension+-- documented in section 7.2.1 of the GHC User's Guide. -data Extension-  = OverlappingInstances+data Extension =+ +  -- | [GHC &#xa7; 7.6.3.4] Allow overlapping class instances,+  -- provided there is a unique most specific instance for each use.+    OverlappingInstances++  -- | [GHC &#xa7; 7.6.3.3] Ignore structural rules guaranteeing the+  -- termination of class instance resolution.  Termination is+  -- guaranteed by a fixed-depth recursion stack, and compilation+  -- may fail if this depth is exceeded.   | UndecidableInstances++  -- | [GHC &#xa7; 7.6.3.4] Implies 'OverlappingInstances'.  Allow the+  -- implementation to choose an instance even when it is possible+  -- that further instantiation of types will lead to a more specific+  -- instance being applicable.   | IncoherentInstances++  -- | [GHC &#xa7; 7.3.8] Allows recursive bindings in @do@ blocks,+  -- using the @rec@ keyword.+  | DoRec++  -- | [GHC &#xa7; 7.3.8.2] Deprecated in GHC.  Allows recursive bindings+  -- using @mdo@, a variant of @do@.  @DoRec@ provides a different,+  -- preferred syntax.   | RecursiveDo++  -- | [GHC &#xa7; 7.3.9] Provide syntax for writing list+  -- comprehensions which iterate over several lists together, like+  -- the 'zipWith' family of functions.   | ParallelListComp++  -- | [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.6.2] Allow a specification attached to a+  -- multi-parameter type class which indicates that some parameters+  -- are entirely determined by others. The implementation will check+  -- that this property holds for the declared instances, and will use+  -- this property to reduce ambiguity in instance resolution.   | FunctionalDependencies++  -- | [GHC &#xa7; 7.8.5] Like 'RankNTypes' but does not allow a+  -- higher-rank type to itself appear on the left of a function+  -- arrow.   | Rank2Types++  -- | [GHC &#xa7; 7.8.5] Allow a universally-quantified type to occur on+  -- the left of a function arrow.   | RankNTypes++  -- | [GHC &#xa7; 7.8.5] Allow data constructors to have polymorphic+  -- arguments.  Unlike 'RankNTypes', does not allow this for ordinary+  -- functions.   | PolymorphicComponents++  -- | [GHC &#xa7; 7.4.4] Allow existentially-quantified data constructors.   | ExistentialQuantification++  -- | [GHC &#xa7; 7.8.7] Cause a type variable in a signature, which has an+  -- explicit @forall@ quantifier, to scope over the definition of the+  -- accompanying value declaration.   | ScopedTypeVariables-  -- | Deprecated, use ScopedTypeVariables instead.++  -- | Deprecated, use 'ScopedTypeVariables' instead.   | PatternSignatures++  -- | [GHC &#xa7; 7.8.3] Enable implicit function parameters with dynamic+  -- scope.   | ImplicitParams++  -- | [GHC &#xa7; 7.8.2] Relax some restrictions on the form of the context+  -- of a type signature.   | FlexibleContexts++  -- | [GHC &#xa7; 7.6.3.2] Relax some restrictions on the form of the+  -- context of an instance declaration.   | FlexibleInstances++  -- | [GHC &#xa7; 7.4.1] Allow data type declarations with no constructors.   | EmptyDataDecls++  -- | [GHC &#xa7; 4.10.3] Run the C preprocessor on Haskell source code.   | CPP +  -- | [GHC &#xa7; 7.8.4] Allow an explicit kind signature giving the kind of+  -- types over which a type variable ranges.   | KindSignatures++  -- | [GHC &#xa7; 7.11] Enable a form of pattern which forces evaluation+  -- before an attempted match, and a form of strict @let@/@where@+  -- binding.   | BangPatterns++  -- | [GHC &#xa7; 7.6.3.1] Allow type synonyms in instance heads.   | TypeSynonymInstances++  -- | [GHC &#xa7; 7.9] Enable Template Haskell, a system for compile-time+  -- metaprogramming.   | TemplateHaskell++  -- | [GHC &#xa7; 8] Enable the Foreign Function Interface.  In GHC,+  -- implements the standard Haskell 98 Foreign Function Interface+  -- Addendum, plus some GHC-specific extensions.   | ForeignFunctionInterface++  -- | [GHC &#xa7; 7.10] Enable arrow notation.   | Arrows++  -- | [GHC &#xa7; 7.16] Enable generic type classes, with default instances+  -- 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.15] Enable syntax for implicitly binding local names+  -- corresponding to the field names of a record.  Puns bind specific+  -- names, unlike 'RecordWildCards'.   | NamedFieldPuns++  -- | [GHC &#xa7; 7.3.5] Enable a form of guard which matches a pattern and+  -- binds variables.   | PatternGuards++  -- | [GHC &#xa7; 7.5.4] Allow a type declared with @newtype@ to use+  -- @deriving@ for any class with an instance for the underlying type.   | GeneralizedNewtypeDeriving +  -- | [Hugs &#xa7; 7.1] Enable the \"Trex\" extensible records system.   | ExtensibleRecords++  -- | [Hugs &#xa7; 7.2] Enable type synonyms which are transparent in+  -- some definitions and opaque elsewhere, as a way of implementing +  -- abstract datatypes.   | RestrictedTypeSynonyms++  -- | [Hugs &#xa7; 7.3] Enable an alternate syntax for string literals,+  -- with string templating.   | HereDocuments++  -- | [GHC &#xa7; 7.3.2] Allow the character @#@ as a postfix modifier on+  -- identifiers.  Also enables literal syntax for unboxed values.   | MagicHash++  -- | [GHC &#xa7; 7.7] Allow data types and type synonyms which are+  -- indexed by types, i.e. ad-hoc polymorphism for types.   | TypeFamilies++  -- | [GHC &#xa7; 7.5.2] Allow a standalone declaration which invokes the+  -- type class @deriving@ mechanism.   | StandaloneDeriving +  -- | [GHC &#xa7; 7.3.1] Allow certain Unicode characters to stand for+  -- certain ASCII character sequences, e.g. keywords and punctuation.   | UnicodeSyntax++  -- | [GHC &#xa7; 8.1.1] Allow the use of unboxed types as foreign types,+  -- e.g. in @foreign import@ and @foreign export@.   | UnliftedFFITypes++  -- | [GHC &#xa7; 7.4.3] Defer validity checking of types until after+  -- expanding type synonyms, relaxing the constraints on how synonyms+  -- may be used.   | LiberalTypeSynonyms++  -- | [GHC &#xa7; 7.4.2] Allow the name of a type constructor, type class,+  -- or type variable to be an infix operator.   | TypeOperators+ --PArr -- not ready yet, and will probably be renamed to ParallelArrays++  -- | [GHC &#xa7; 7.3.16] Enable syntax for implicitly binding local names+  -- corresponding to the field names of a record.  A wildcard binds+  -- all unmentioned names, unlike 'NamedFieldPuns'.   | RecordWildCards++  -- | Deprecated, use 'NamedFieldPuns' instead.   | RecordPuns++  -- | [GHC &#xa7; 7.3.14] Allow a record field name to be disambiguated+  -- by the type of the record it's in.   | DisambiguateRecordFields++  -- | [GHC &#xa7; 7.6.4] Enable overloading of string literals using a+  -- type class, much like integer literals.   | OverloadedStrings++  -- | [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.   | GADTs++  -- | [GHC &#xa7; 7.17.2] Allow pattern bindings to be polymorphic.   | NoMonoPatBinds++  -- | [GHC &#xa7; 7.8.8] Relax the requirements on mutually-recursive+  -- polymorphic functions.   | RelaxedPolyRec++  -- | [GHC &#xa7; 2.4.5] Allow default instantiation of polymorphic+  -- types in more situations.   | ExtendedDefaultRules++  -- | [GHC &#xa7; 7.2.2] Enable unboxed tuples.   | UnboxedTuples++  -- | [GHC &#xa7; 7.5.3] Enable @deriving@ for classes+  -- @Data.Typeable.Typeable@ and @Data.Generics.Data@.   | DeriveDataTypeable++  -- | [GHC &#xa7; 7.6.1.3] Allow a class method's type to place+  -- additional constraints on a class type variable.   | ConstrainedClassMethods -  -- | Allow imports to be qualified by the package name that the module-  -- is intended to be imported from, e.g.+  -- | [GHC &#xa7; 7.3.18] Allow imports to be qualified by the package+  -- name the module is intended to be imported from, e.g.   --   -- > import "network" Network.Socket   | PackageImports +  -- | [GHC &#xa7; 7.8.6] Deprecated in GHC 6.12 and will be removed in+  -- GHC 7.  Allow a type variable to be instantiated at a+  -- polymorphic type.   | ImpredicativeTypes++  -- | [GHC &#xa7; 7.3.3] Change the syntax for qualified infix+  -- operators.   | NewQualifiedOperators++  -- | [GHC &#xa7; 7.3.12] Relax the interpretation of left operator+  -- sections to allow unary postfix operators.   | PostfixOperators++  -- | [GHC &#xa7; 7.9.5] Enable quasi-quotation, a mechanism for defining+  -- new concrete syntax for expressions and patterns.   | QuasiQuotes++  -- | [GHC &#xa7; 7.3.10] Enable generalized list comprehensions,+  -- supporting operations such as sorting and grouping.   | TransformListComp++  -- | [GHC &#xa7; 7.3.6] Enable view patterns, which match a value by+  -- applying a function and matching on the result.   | ViewPatterns    -- | Allow concrete XML syntax to be used in expressions and patterns,   -- as per the Haskell Server Pages extension language:    -- <http://www.haskell.org/haskellwiki/HSP>. The ideas behind it are -  -- discussed in the paper "Haskell Server Pages through Dynamic Loading"+  -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\"   -- by Niklas Broberg, from Haskell Workshop '05.   | XmlSyntax    -- | Allow regular pattern matching over lists, as discussed in the-  -- paper "Regular Expression Patterns" by Niklas Broberg, Andreas Farre+  -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre   -- and Josef Svenningsson, from ICFP '04.   | RegularPatterns +  -- | Enables the use of tuple sections, e.g. @(, True)@ desugars into+  -- @\x -> (x, True)@.+  | TupleSections++  -- | Allows GHC primops, written in C--, to be imported into a Haskell+  -- file.+  | GHCForeignImportPrim++  -- | Support for patterns of the form @n + k@, where @k@ is an+  -- integer literal.+  | NPlusKPatterns++  -- | Improve the layout rule when @if@ expressions are used in a @do@+  -- block.+  | DoAndIfThenElse++  -- | Makes much of the Haskell sugar be desugared into calls to the+  -- function with a particular name that is in scope.+  | RebindableSyntax++  -- | Make @forall@ a keyword in types, which can be used to give the+  -- generalisation explicitly.+  | ExplicitForAll++  -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in+  -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@.+  | DatatypeContexts++  -- | Local (@let@ and @where@) bindings are monomorphic.+  | MonoLocalBinds++  -- | Enable @deriving@ for the @Data.Functor.Functor@ class.+  | DeriveFunctor++  -- | Enable @deriving@ for the @Data.Traversable.Traversable@ class.+  | DeriveTraversable++  -- | Enable @deriving@ for the @Data.Foldable.Foldable@ class.+  | DeriveFoldable++  -- | An unknown extension, identified by the name of its @LANGUAGE@+  -- pragma.   | UnknownExtension String   deriving (Show, Read, Eq) @@ -164,6 +438,7 @@   [ OverlappingInstances   , UndecidableInstances   , IncoherentInstances+  , DoRec   , RecursiveDo   , ParallelListComp   , MultiParamTypeClasses@@ -225,6 +500,18 @@   , ViewPatterns   , XmlSyntax   , RegularPatterns++  , TupleSections+  , GHCForeignImportPrim+  , NPlusKPatterns+  , DoAndIfThenElse+  , RebindableSyntax+  , ExplicitForAll+  , DatatypeContexts+  , MonoLocalBinds+  , DeriveFunctor+  , DeriveTraversable+  , DeriveFoldable   ]  instance Text Extension where

@@ -1,15 +1,8 @@ -*-change-log-*- -1.8.0.4 Duncan Coutts <duncan@haskell.org> March 2010-	* Fix exe-depends-on-lib feature with ghc-6.12-	* Fix use of --package-db with ghc-6.12-	* By default $datadir now follows the $prefix on Windows-	* Find ar.exe on windows better-	* Fix mixup between $arch and $os path variables-	* Support for for hugs and nhc package databases-	* Set dynlib name for shared libs on OSX+1.9.x (current development version) -1.8.0.2 Duncan Coutts <duncan@haskell.org> December 2009+1.8.0.x (next stable release version) 	* Support for GHC-6.12 	* New unique installed package IDs which use a package hash 	* Allow executables to depend on the lib within the same package