diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,5 +1,5 @@ Name: Cabal -Version: 1.10.2.0 +Version: 1.12.0 Copyright: 2003-2006, Isaac Jones 2005-2011, Duncan Coutts License: BSD3 @@ -18,7 +18,7 @@ The Haskell Cabal is part of a larger infrastructure for distributing, organizing, and cataloging Haskell libraries and tools. Category: Distribution -cabal-version: >=1.6 +cabal-version: >=1.10 Build-Type: Custom -- Even though we do use the default Setup.lhs it's vital to bootstrapping -- that we build Setup.lhs using our own local Cabal source code. @@ -43,14 +43,14 @@ if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 } if flag(base3) Build-Depends: directory >= 1 && < 1.2, - process >= 1 && < 1.1, + process >= 1 && < 1.2, old-time >= 1 && < 1.1, containers >= 0.1 && < 0.5, array >= 0.1 && < 0.4, - pretty >= 1 && < 1.1 + pretty >= 1 && < 1.2 if !os(windows) - Build-Depends: unix >= 2.0 && < 2.5 + Build-Depends: unix >= 2.0 && < 2.6 ghc-options: -Wall -fno-ignore-asserts if impl(ghc >= 6.8) @@ -68,6 +68,7 @@ Distribution.PackageDescription.Configuration, Distribution.PackageDescription.Parse, Distribution.PackageDescription.Check, + Distribution.PackageDescription.PrettyPrint, Distribution.ParseUtils, Distribution.ReadE, Distribution.Simple, @@ -81,6 +82,7 @@ Distribution.Simple.GHC, Distribution.Simple.LHC, Distribution.Simple.Haddock, + Distribution.Simple.Hpc, Distribution.Simple.Hugs, Distribution.Simple.Install, Distribution.Simple.InstallDirs, @@ -123,4 +125,39 @@ Distribution.Simple.GHC.IPI642, Paths_Cabal - Extensions: CPP + Default-Language: Haskell98 + Default-Extensions: CPP + +test-suite unit-tests + type: exitcode-stdio-1.0 + main-is: suite.hs + other-modules: PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check, + PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check, + PackageTests.BuildDeps.InternalLibrary0.Check, + PackageTests.BuildDeps.InternalLibrary1.Check, + PackageTests.BuildDeps.InternalLibrary2.Check, + PackageTests.BuildDeps.InternalLibrary3.Check, + PackageTests.BuildDeps.InternalLibrary4.Check, + PackageTests.BuildDeps.TargetSpecificDeps1.Check, + PackageTests.BuildDeps.TargetSpecificDeps2.Check, + PackageTests.BuildDeps.TargetSpecificDeps3.Check, + PackageTests.BuildDeps.SameDepsAllRound.Check, + PackageTests.TestStanza.Check, + PackageTests.TestSuiteExeV10.Check, + PackageTests.PackageTester + hs-source-dirs: tests + build-depends: + base, + test-framework, + test-framework-quickcheck2, + test-framework-hunit, + HUnit, + QuickCheck >= 2.1.0.1, + Cabal, + process, + directory, + filepath, + extensible-exceptions, + bytestring, + unix + Default-Language: Haskell98 diff --git a/Distribution/Compat/CopyFile.hs b/Distribution/Compat/CopyFile.hs --- a/Distribution/Compat/CopyFile.hs +++ b/Distribution/Compat/CopyFile.hs @@ -41,12 +41,15 @@ #endif /* __GLASGOW_HASKELL__ */ #ifndef mingw32_HOST_OS +#if __GLASGOW_HASKELL__ >= 611 +import System.Posix.Internals (withFilePath) +#else +import Foreign.C (withCString) +#endif import System.Posix.Types ( FileMode ) import System.Posix.Internals ( c_chmod ) -import Foreign.C - ( withCString ) #if __GLASGOW_HASKELL__ >= 608 import Foreign.C ( throwErrnoPathIfMinus1_ ) @@ -67,7 +70,11 @@ setFileMode :: FilePath -> FileMode -> IO () setFileMode name m = +#if __GLASGOW_HASKELL__ >= 611 + withFilePath name $ \s -> do +#else withCString name $ \s -> do +#endif #if __GLASGOW_HASKELL__ >= 608 throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) #else diff --git a/Distribution/Compat/Exception.hs b/Distribution/Compat/Exception.hs --- a/Distribution/Compat/Exception.hs +++ b/Distribution/Compat/Exception.hs @@ -9,9 +9,14 @@ #define NEW_EXCEPTION #endif -module Distribution.Compat.Exception - (Exception.IOException, onException, catchIO, catchExit, throwIOIO) - where +module Distribution.Compat.Exception ( + Exception.IOException, + onException, + catchIO, + catchExit, + throwIOIO, + tryIO, + ) where import System.Exit import qualified Control.Exception as Exception @@ -29,6 +34,13 @@ throwIOIO = Exception.throwIO #else throwIOIO = Exception.throwIO . Exception.IOException +#endif + +tryIO :: IO a -> IO (Either Exception.IOException a) +#ifdef NEW_EXCEPTION +tryIO = Exception.try +#else +tryIO = Exception.tryJust Exception.ioErrors #endif catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a diff --git a/Distribution/Compat/TempFile.hs b/Distribution/Compat/TempFile.hs --- a/Distribution/Compat/TempFile.hs +++ b/Distribution/Compat/TempFile.hs @@ -27,7 +27,7 @@ import Data.Bits ((.|.)) import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR, o_BINARY, o_NONBLOCK, o_NOCTTY) -import System.IO.Error (try, isAlreadyExistsError) +import System.IO.Error (isAlreadyExistsError) #if __GLASGOW_HASKELL__ >= 611 import System.Posix.Internals (withFilePath) #else @@ -39,7 +39,7 @@ #else import GHC.Handle (fdToHandle) #endif -import Distribution.Compat.Exception (onException) +import Distribution.Compat.Exception (onException, tryIO) #endif import Foreign.C (getErrno, errnoToIOError) @@ -89,7 +89,7 @@ (templateBase, templateExt) = splitExtension template findTempName :: Int -> IO (FilePath, Handle) findTempName x - = do let path = tmp_dir (templateBase ++ show x) <.> templateExt + = do let path = tmp_dir (templateBase ++ "-" ++ show x) <.> templateExt b <- doesFileExist path if b then findTempName (x+1) else do hnd <- openBinaryFile path ReadWriteMode @@ -189,8 +189,8 @@ findTempName pid where findTempName x = do - let dirpath = dir template ++ show x - r <- try $ mkPrivateDir dirpath + let dirpath = dir template ++ "-" ++ show x + r <- tryIO $ mkPrivateDir dirpath case r of Right _ -> return dirpath Left e | isAlreadyExistsError e -> findTempName (x+1) diff --git a/Distribution/InstalledPackageInfo.hs b/Distribution/InstalledPackageInfo.hs --- a/Distribution/InstalledPackageInfo.hs +++ b/Distribution/InstalledPackageInfo.hs @@ -61,12 +61,13 @@ parseInstalledPackageInfo, showInstalledPackageInfo, showInstalledPackageInfoField, + fieldsInstalledPackageInfo, ) where import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..), PError(..), PWarning , simpleField, listField, parseLicenseQ - , showFields, showSingleNamedField, parseFields + , showFields, showSingleNamedField, parseFieldsFlat , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ , showFilePath, showToken, boolField, parseOptVersion , parseFreeText, showFreeText ) @@ -98,12 +99,14 @@ stability :: String, homepage :: String, pkgUrl :: String, + synopsis :: String, description :: String, category :: String, -- these parts are required by an installed package only: exposed :: Bool, exposedModules :: [m], hiddenModules :: [m], + trusted :: Bool, importDirs :: [FilePath], -- contain sources in case of Hugs libraryDirs :: [FilePath], hsLibraries :: [String], @@ -139,11 +142,13 @@ stability = "", homepage = "", pkgUrl = "", + synopsis = "", description = "", category = "", exposed = False, exposedModules = [], hiddenModules = [], + trusted = False, importDirs = [], libraryDirs = [], hsLibraries = [], @@ -168,22 +173,23 @@ -- Parsing parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo -parseInstalledPackageInfo = parseFields all_fields emptyInstalledPackageInfo +parseInstalledPackageInfo = + parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo -- ----------------------------------------------------------------------------- -- Pretty-printing showInstalledPackageInfo :: InstalledPackageInfo -> String -showInstalledPackageInfo = showFields all_fields +showInstalledPackageInfo = showFields fieldsInstalledPackageInfo showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) -showInstalledPackageInfoField = showSingleNamedField all_fields +showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing -all_fields :: [FieldDescr InstalledPackageInfo] -all_fields = basicFieldDescrs ++ installedFieldDescrs +fieldsInstalledPackageInfo :: [FieldDescr InstalledPackageInfo] +fieldsInstalledPackageInfo = basicFieldDescrs ++ installedFieldDescrs basicFieldDescrs :: [FieldDescr InstalledPackageInfo] basicFieldDescrs = @@ -214,6 +220,9 @@ , simpleField "package-url" showFreeText parseFreeText pkgUrl (\val pkg -> pkg{pkgUrl=val}) + , simpleField "synopsis" + showFreeText parseFreeText + synopsis (\val pkg -> pkg{synopsis=val}) , simpleField "description" showFreeText parseFreeText description (\val pkg -> pkg{description=val}) @@ -235,6 +244,8 @@ , listField "hidden-modules" disp parseModuleNameQ hiddenModules (\xs pkg -> pkg{hiddenModules=xs}) + , boolField "trusted" + trusted (\val pkg -> pkg{trusted=val}) , listField "import-dirs" showFilePath parseFilePathQ importDirs (\xs pkg -> pkg{importDirs=xs}) diff --git a/Distribution/Make.hs b/Distribution/Make.hs --- a/Distribution/Make.hs +++ b/Distribution/Make.hs @@ -90,6 +90,7 @@ ) where -- local +import Distribution.Compat.Exception import Distribution.Package --must not specify imports, since we're exporting moule. import Distribution.Simple.Program(defaultProgramConfiguration) import Distribution.PackageDescription @@ -183,7 +184,7 @@ haddockAction flags args = do noExtraFlags args rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"] - `catch` \_ -> + `catchIO` \_ -> rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] buildAction :: BuildFlags -> [String] -> IO () diff --git a/Distribution/PackageDescription.hs b/Distribution/PackageDescription.hs --- a/Distribution/PackageDescription.hs +++ b/Distribution/PackageDescription.hs @@ -602,8 +602,8 @@ emptyBuildInfo :: BuildInfo emptyBuildInfo = mempty --- | The 'BuildInfo' for the library (if there is one and it's buildable) and --- all the buildable executables. Useful for gathering dependencies. +-- | The 'BuildInfo' for the library (if there is one and it's buildable), and +-- all buildable executables and test suites. Useful for gathering dependencies. allBuildInfo :: PackageDescription -> [BuildInfo] allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr] , let bi = libBuildInfo lib @@ -613,7 +613,8 @@ , buildable bi ] ++ [ bi | tst <- testSuites pkg_descr , let bi = testBuildInfo tst - , buildable bi ] + , buildable bi + , testEnabled tst ] --FIXME: many of the places where this is used, we actually want to look at -- unbuildable bits too, probably need separate functions @@ -788,11 +789,7 @@ updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib}) updateLibrary Nothing mb_lib = mb_lib - - --the lib only exists in the buildinfo file. FIX: Is this - --wrong? If there aren't any exposedModules, then the library - --won't build anyway. add to sanity checker? - updateLibrary (Just bi) Nothing = Just emptyLibrary{libBuildInfo=bi} + updateLibrary (Just _) Nothing = Nothing updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)] -> [Executable] -- ^list of executables to update diff --git a/Distribution/PackageDescription/Check.hs b/Distribution/PackageDescription/Check.hs --- a/Distribution/PackageDescription/Check.hs +++ b/Distribution/PackageDescription/Check.hs @@ -101,7 +101,7 @@ import qualified Language.Haskell.Extension as Extension (deprecatedExtensions) import Language.Haskell.Extension - ( Language(UnknownLanguage), knownLanguages, Extension(..) ) + ( Language(UnknownLanguage), knownLanguages, Extension(..), KnownExtension(..) ) import System.FilePath ( (), takeExtension, isRelative, isAbsolute , splitDirectories, splitPath ) @@ -395,6 +395,10 @@ , check (null (synopsis pkg) && not (null (description pkg))) $ PackageDistSuspicious "No 'synopsis' field." + --TODO: recommend the bug reports url, author and homepage fields + --TODO: recommend not using the stability field + --TODO: recommend specifying a source repo + , check (length (synopsis pkg) >= 80) $ PackageDistSuspicious "The 'synopsis' field is rather long (max 80 chars is recommended)." @@ -643,23 +647,38 @@ checkFlags flags = check (any (`elem` flags) all_ghc_options) ghcExtension ('-':'f':name) = case name of - "allow-overlapping-instances" -> Just OverlappingInstances - "th" -> Just TemplateHaskell - "ffi" -> Just ForeignFunctionInterface - "fi" -> Just ForeignFunctionInterface - "no-monomorphism-restriction" -> Just NoMonomorphismRestriction - "no-mono-pat-binds" -> Just NoMonoPatBinds - "allow-undecidable-instances" -> Just UndecidableInstances - "allow-incoherent-instances" -> Just IncoherentInstances - "arrows" -> Just Arrows - "generics" -> Just Generics - "no-implicit-prelude" -> Just NoImplicitPrelude - "implicit-params" -> Just ImplicitParams - "bang-patterns" -> Just BangPatterns - "scoped-type-variables" -> Just ScopedTypeVariables - "extended-default-rules" -> Just ExtendedDefaultRules - _ -> Nothing - ghcExtension ('-':'c':"pp") = Just CPP + "allow-overlapping-instances" -> Just (EnableExtension OverlappingInstances) + "no-allow-overlapping-instances" -> Just (DisableExtension OverlappingInstances) + "th" -> Just (EnableExtension TemplateHaskell) + "no-th" -> Just (DisableExtension TemplateHaskell) + "ffi" -> Just (EnableExtension ForeignFunctionInterface) + "no-ffi" -> Just (DisableExtension ForeignFunctionInterface) + "fi" -> Just (EnableExtension ForeignFunctionInterface) + "no-fi" -> Just (DisableExtension ForeignFunctionInterface) + "monomorphism-restriction" -> Just (EnableExtension MonomorphismRestriction) + "no-monomorphism-restriction" -> Just (DisableExtension MonomorphismRestriction) + "mono-pat-binds" -> Just (EnableExtension MonoPatBinds) + "no-mono-pat-binds" -> Just (DisableExtension MonoPatBinds) + "allow-undecidable-instances" -> Just (EnableExtension UndecidableInstances) + "no-allow-undecidable-instances" -> Just (DisableExtension UndecidableInstances) + "allow-incoherent-instances" -> Just (EnableExtension IncoherentInstances) + "no-allow-incoherent-instances" -> Just (DisableExtension IncoherentInstances) + "arrows" -> Just (EnableExtension Arrows) + "no-arrows" -> Just (DisableExtension Arrows) + "generics" -> Just (EnableExtension Generics) + "no-generics" -> Just (DisableExtension Generics) + "implicit-prelude" -> Just (EnableExtension ImplicitPrelude) + "no-implicit-prelude" -> Just (DisableExtension ImplicitPrelude) + "implicit-params" -> Just (EnableExtension ImplicitParams) + "no-implicit-params" -> Just (DisableExtension ImplicitParams) + "bang-patterns" -> Just (EnableExtension BangPatterns) + "no-bang-patterns" -> Just (DisableExtension BangPatterns) + "scoped-type-variables" -> Just (EnableExtension ScopedTypeVariables) + "no-scoped-type-variables" -> Just (DisableExtension ScopedTypeVariables) + "extended-default-rules" -> Just (EnableExtension ExtendedDefaultRules) + "no-extended-default-rules" -> Just (DisableExtension ExtendedDefaultRules) + _ -> Nothing + ghcExtension "-cpp" = Just (EnableExtension CPP) ghcExtension _ = Nothing checkCCOptions :: PackageDescription -> [PackageCheck] @@ -1034,28 +1053,34 @@ -- The known extensions in Cabal-1.2.3 compatExtensions = + map EnableExtension [ OverlappingInstances, UndecidableInstances, IncoherentInstances , RecursiveDo, ParallelListComp, MultiParamTypeClasses - , NoMonomorphismRestriction, FunctionalDependencies, Rank2Types + , FunctionalDependencies, Rank2Types , RankNTypes, PolymorphicComponents, ExistentialQuantification , ScopedTypeVariables, ImplicitParams, FlexibleContexts , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface - , Arrows, Generics, NoImplicitPrelude, NamedFieldPuns, PatternGuards + , Arrows, Generics, NamedFieldPuns, PatternGuards , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms - , HereDocuments - ] ++ compatExtensionsExtra + , HereDocuments] ++ + map DisableExtension + [MonomorphismRestriction, ImplicitPrelude] ++ + compatExtensionsExtra -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6 -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8) compatExtensionsExtra = + map EnableExtension [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields - , OverloadedStrings, GADTs, NoMonoPatBinds, RelaxedPolyRec + , OverloadedStrings, GADTs, RelaxedPolyRec , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable , ConstrainedClassMethods - ] + ] ++ + map DisableExtension + [MonoPatBinds] -- | A variation on the normal 'Text' instance, shows any ()'s in the original -- textual syntax. We need to show these otherwise it's confusing to users when diff --git a/Distribution/PackageDescription/Parse.hs b/Distribution/PackageDescription/Parse.hs --- a/Distribution/PackageDescription/Parse.hs +++ b/Distribution/PackageDescription/Parse.hs @@ -58,6 +58,14 @@ parseHookedBuildInfo, writeHookedBuildInfo, showHookedBuildInfo, + + pkgDescrFieldDescrs, + libFieldDescrs, + executableFieldDescrs, + binfoFieldDescrs, + sourceRepoFieldDescrs, + testSuiteFieldDescrs, + flagFieldDescrs ) where import Data.Char (isSpace) @@ -166,7 +174,8 @@ -- | Store any fields beginning with "x-" in the customFields field of -- a PackageDescription. All other fields will generate a warning. storeXFieldsPD :: UnrecFieldParser PackageDescription -storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD = (f,val):(customFieldsPD pkg) } +storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD = + (customFieldsPD pkg) ++ [(f,val)]} storeXFieldsPD _ _ = Nothing -- --------------------------------------------------------------------------- @@ -184,7 +193,7 @@ storeXFieldsLib :: UnrecFieldParser Library storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) = - Just $ l {libBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi) }} + Just $ l {libBuildInfo = bi{ customFieldsBI = (customFieldsBI bi) ++ [(f,val)]}} storeXFieldsLib _ _ = Nothing -- --------------------------------------------------------------------------- @@ -546,6 +555,9 @@ skipField :: PM () skipField = modify tail +--FIXME: this should take a ByteString, not a String. We have to be able to +-- decode UTF8 and handle the BOM. + -- | Parses the given file into a 'GenericPackageDescription'. -- -- In Cabal 1.2 the syntax for package descriptions was changed to a format @@ -738,7 +750,7 @@ flds <- collectFields parseExeFields sec_fields skipField (repos, flags, lib, exes, tests) <- getBody - return (repos, flags, lib, exes ++ [(exename, flds)], tests) + return (repos, flags, lib, (exename, flds): exes, tests) | sec_type == "test-suite" -> do when (null sec_label) $ lift $ syntaxError line_no @@ -772,7 +784,7 @@ -- then we are done. If not, then one of the conditional -- branches below the current node must specify a type. -- Each node may have multiple immediate children; we - -- only need one to specify a type because the + -- only one need one to specify a type because the -- configure step uses 'mappend' to join together the -- results of flag resolution. in hasTestType || (any checkComponent components) @@ -782,11 +794,11 @@ (repos, flags, lib, exes, tests) <- getBody return (repos, flags, lib, exes, (testname, flds) : tests) else lift $ syntaxError line_no $ - "Test suite \"" ++ testname - ++ "\" is missing required field \"type\" or the field " - ++ "is not present in all conditional branches. The " - ++ "available test types are: " - ++ intercalate ", " (map display knownTestTypes) + "Test suite \"" ++ testname + ++ "\" is missing required field \"type\" or the field " + ++ "is not present in all conditional branches. The " + ++ "available test types are: " + ++ intercalate ", " (map display knownTestTypes) | sec_type == "library" -> do when (not (null sec_label)) $ lift $ diff --git a/Distribution/PackageDescription/PrettyPrint.hs b/Distribution/PackageDescription/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/Distribution/PackageDescription/PrettyPrint.hs @@ -0,0 +1,238 @@ +----------------------------------------------------------------------------- +-- +-- Module : Distribution.PackageDescription.PrettyPrint +-- Copyright : Jürgen Nicklisch-Franken 2010 +-- License : AllRightsReserved +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- | Pretty printing for cabal files +-- +----------------------------------------------------------------------------- +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.PackageDescription.PrettyPrint ( + writeGenericPackageDescription, + showGenericPackageDescription, +) where + +import Distribution.PackageDescription + ( TestSuite(..), TestSuiteInterface(..), testType + , SourceRepo(..), + customFieldsBI, CondTree(..), Condition(..), + FlagName(..), ConfVar(..), Executable(..), Library(..), + Flag(..), PackageDescription(..), + GenericPackageDescription(..)) +import Text.PrettyPrint + (hsep, comma, punctuate, fsep, parens, char, nest, empty, + isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render) +import Distribution.Simple.Utils (writeUTF8File) +import Distribution.ParseUtils (showFreeText, FieldDescr(..)) +import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs, + sourceRepoFieldDescrs) +import Distribution.Package (Dependency(..)) +import Distribution.Text (Text(..)) +import Data.Maybe (isJust, fromJust, isNothing) + +indentWith :: Int +indentWith = 4 + +-- | Recompile with false for regression testing +simplifiedPrinting :: Bool +simplifiedPrinting = False + +-- | Writes a .cabal file from a generic package description +writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO () +writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg) + +-- | Writes a generic package description to a string +showGenericPackageDescription :: GenericPackageDescription -> String +showGenericPackageDescription = render . ppGenericPackageDescription + +ppGenericPackageDescription :: GenericPackageDescription -> Doc +ppGenericPackageDescription gpd = + ppPackageDescription (packageDescription gpd) + $+$ ppGenPackageFlags (genPackageFlags gpd) + $+$ ppLibrary (condLibrary gpd) + $+$ ppExecutables (condExecutables gpd) + $+$ ppTestSuites (condTestSuites gpd) + +ppPackageDescription :: PackageDescription -> Doc +ppPackageDescription pd = ppFields pkgDescrFieldDescrs pd + $+$ ppCustomFields (customFieldsPD pd) + $+$ ppSourceRepos (sourceRepos pd) + +ppSourceRepos :: [SourceRepo] -> Doc +ppSourceRepos [] = empty +ppSourceRepos (hd:tl) = ppSourceRepo hd $+$ ppSourceRepos tl + +ppSourceRepo :: SourceRepo -> Doc +ppSourceRepo repo = + emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$ + (nest indentWith (ppFields sourceRepoFieldDescrs' repo)) + where + sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"] + +ppFields :: [FieldDescr a] -> a -> Doc +ppFields fields x = + vcat [ ppField name (getter x) + | FieldDescr name getter _ <- fields] + +ppField :: String -> Doc -> Doc +ppField name fielddoc | isEmpty fielddoc = empty + | otherwise = text name <> colon <+> fielddoc + +ppDiffFields :: [FieldDescr a] -> a -> a -> Doc +ppDiffFields fields x y = + vcat [ ppField name (getter x) + | FieldDescr name getter _ <- fields, + render (getter x) /= render (getter y)] + +ppCustomFields :: [(String,String)] -> Doc +ppCustomFields flds = vcat [ppCustomField f | f <- flds] + +ppCustomField :: (String,String) -> Doc +ppCustomField (name,val) = text name <> colon <+> showFreeText val + +ppGenPackageFlags :: [Flag] -> Doc +ppGenPackageFlags flds = vcat [ppFlag f | f <- flds] + +ppFlag :: Flag -> Doc +ppFlag (MkFlag name desc dflt manual) = + emptyLine $ text "flag" <+> ppFlagName name $+$ + (nest indentWith ((if null desc + then empty + else text "Description: " <+> showFreeText desc) $+$ + (if dflt then empty else text "Default: False") $+$ + (if manual then text "Manual: True" else empty))) + +ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc +ppLibrary Nothing = empty +ppLibrary (Just condTree) = + emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib) + where + ppLib lib Nothing = ppFields libFieldDescrs lib + $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) + ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib + $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) + +ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc +ppExecutables exes = + vcat [emptyLine $ text ("executable " ++ n) + $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes] + where + ppExe (Executable _ modulePath' buildInfo') Nothing = + (if modulePath' == "" then empty else text "main-is:" <+> text modulePath') + $+$ ppFields binfoFieldDescrs buildInfo' + $+$ ppCustomFields (customFieldsBI buildInfo') + ppExe (Executable _ modulePath' buildInfo') + (Just (Executable _ modulePath2 buildInfo2)) = + (if modulePath' == "" || modulePath' == modulePath2 + then empty else text "main-is:" <+> text modulePath') + $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 + $+$ ppCustomFields (customFieldsBI buildInfo') + +ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc +ppTestSuites suites = + emptyLine $ vcat [ text ("test-suite " ++ n) + $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite) + | (n,condTree) <- suites] + where + ppTestSuite testsuite Nothing = + text "type:" <+> disp (testType testsuite) + $+$ maybe empty (\f -> text "main-is:" <+> text f) + (testSuiteMainIs testsuite) + $+$ maybe empty (\m -> text "test-module:" <+> disp m) + (testSuiteModule testsuite) + $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite) + $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite)) + + ppTestSuite (TestSuite _ _ buildInfo' _) + (Just (TestSuite _ _ buildInfo2 _)) = + ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 + $+$ ppCustomFields (customFieldsBI buildInfo') + + testSuiteMainIs test = case testInterface test of + TestSuiteExeV10 _ f -> Just f + _ -> Nothing + + testSuiteModule test = case testInterface test of + TestSuiteLibV09 _ m -> Just m + _ -> Nothing + +ppCondition :: Condition ConfVar -> Doc +ppCondition (Var x) = ppConfVar x +ppCondition (Lit b) = text (show b) +ppCondition (CNot c) = char '!' <> (ppCondition c) +ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||" + <+> ppCondition c2]) +ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&" + <+> ppCondition c2]) +ppConfVar :: ConfVar -> Doc +ppConfVar (OS os) = text "os" <> parens (disp os) +ppConfVar (Arch arch) = text "arch" <> parens (disp arch) +ppConfVar (Flag name) = text "flag" <> parens (ppFlagName name) +ppConfVar (Impl c v) = text "impl" <> parens (disp c <+> disp v) + +ppFlagName :: FlagName -> Doc +ppFlagName (FlagName name) = text name + +ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) -> Doc +ppCondTree ct@(CondNode it deps ifs) mbIt ppIt = + let res = ppDeps deps + $+$ (vcat $ map ppIf ifs) + $+$ ppIt it mbIt + in if isJust mbIt && isEmpty res + then ppCondTree ct Nothing ppIt + else res + where + ppIf (c,thenTree,mElseTree) = + ((emptyLine $ text "if" <+> ppCondition c) $$ + nest indentWith (ppCondTree thenTree + (if simplifiedPrinting then (Just it) else Nothing) ppIt)) + $+$ (if isNothing mElseTree + then empty + else text "else" + $$ nest indentWith (ppCondTree (fromJust mElseTree) + (if simplifiedPrinting then (Just it) else Nothing) ppIt)) + +ppDeps :: [Dependency] -> Doc +ppDeps [] = empty +ppDeps deps = + text "build-depends:" <+> fsep (punctuate comma (map disp deps)) + +emptyLine :: Doc -> Doc +emptyLine d = text " " $+$ d + + + diff --git a/Distribution/ParseUtils.hs b/Distribution/ParseUtils.hs --- a/Distribution/ParseUtils.hs +++ b/Distribution/ParseUtils.hs @@ -52,8 +52,8 @@ LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning, Field(..), fName, lineNo, - FieldDescr(..), ppField, ppFields, readFields, - showFields, showSingleNamedField, parseFields, + FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat, + showFields, showSingleNamedField, parseFields, parseFieldsFlat, parseFilePathQ, parseTokenQ, parseTokenQ', parseModuleNameQ, parseBuildTool, parsePkgconfigDependency, parseOptVersion, parsePackageNameQ, parseVersionRangeQ, @@ -77,7 +77,7 @@ import Distribution.Text ( Text(..) ) import Distribution.Simple.Utils - ( intercalate, lowercase, normaliseLineEndings ) + ( comparing, intercalate, lowercase, normaliseLineEndings ) import Language.Haskell.Extension ( Language, Extension ) @@ -88,6 +88,7 @@ import qualified Data.Map as Map import Control.Monad (foldM) import System.FilePath (normalise) +import Data.List (sortBy) -- ----------------------------------------------------------------------------- @@ -230,14 +231,16 @@ optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b optsField name flavor get set = liftField (fromMaybe [] . lookup flavor . get) - (\opts b -> set (update flavor opts (get b)) b) $ + (\opts b -> set (reorder (update flavor opts (get b))) b) $ field name (hsep . map text) (sepBy parseTokenQ' (munch1 isSpace)) where + update _ opts l | all null opts = l --empty opts as if no opts update f opts [] = [(f,opts)] update f opts ((f',opts'):rest) | f == f' = (f, opts' ++ opts) : rest | otherwise = (f',opts') : update f opts rest + reorder = sortBy (comparing fst) -- TODO: this is a bit smelly hack. It's because we want to parse bool fields -- liberally but not accept new parses. We cannot do that with ReadP @@ -275,7 +278,14 @@ parseFields :: [FieldDescr a] -> a -> String -> ParseResult a parseFields fields initial = \str -> - readFields str >>= foldM setField initial + readFields str >>= accumFields fields initial + +parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a +parseFieldsFlat fields initial = \str -> + readFieldsFlat str >>= accumFields fields initial + +accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a +accumFields fields = foldM setField where fieldMap = Map.fromList [ (name, f) | f@(FieldDescr name _ _) <- fields ] @@ -352,6 +362,12 @@ where ls = (lines . normaliseLineEndings) input tokens = (concatMap tokeniseLine . trimLines) ls +readFieldsFlat :: String -> ParseResult [Field] +readFieldsFlat input = mapM (mkField 0) + =<< mkTree tokens + where ls = (lines . normaliseLineEndings) input + tokens = (concatMap tokeniseLineFlat . trimLines) ls + -- attach line number and determine indentation trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)] trimLines ls = [ (lineno, indent, hastabs, (trimTrailing l')) @@ -425,6 +441,13 @@ | otherwise = Span n s' : ss where s' = trimTrailing (trimLeading s) +tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token] +tokeniseLineFlat (n0, i, t, l) + | null l' = [] + | otherwise = [Line n0 i t l'] + where + l' = trimTrailing (trimLeading l) + trimLeading, trimTrailing :: String -> String trimLeading = dropWhile isSpace trimTrailing = reverse . dropWhile isSpace . reverse @@ -604,7 +627,7 @@ parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) parseTestedWithQ = parseQuoted tw <++ tw - where + where tw :: ReadP r (CompilerFlavor,VersionRange) tw = do compiler <- parseCompilerFlavorCompat skipSpaces @@ -678,4 +701,15 @@ -- | Pretty-print free-format text, ensuring that it is vertically aligned, -- and with blank lines replaced by dots for correct re-parsing. showFreeText :: String -> Doc -showFreeText s = vcat [text (if null l then "." else l) | l <- lines s] +showFreeText "" = empty +showFreeText ('\n' :r) = text " " $+$ text "." $+$ showFreeText r +showFreeText s = vcat [text (if null l then "." else l) | l <- lines_ s] + +-- | 'lines_' breaks a string up into a list of strings at newline +-- characters. The resulting strings do not contain newlines. +lines_ :: String -> [String] +lines_ [] = [""] +lines_ s = let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines_ s'' diff --git a/Distribution/Simple.hs b/Distribution/Simple.hs --- a/Distribution/Simple.hs +++ b/Distribution/Simple.hs @@ -87,7 +87,7 @@ import Distribution.Simple.UserHooks import Distribution.Package --must not specify imports, since we're exporting moule. import Distribution.PackageDescription - ( PackageDescription(..), GenericPackageDescription + ( PackageDescription(..), GenericPackageDescription, Executable(..) , updatePackageDescription, hasLibs , HookedBuildInfo, emptyHookedBuildInfo ) import Distribution.PackageDescription.Parse @@ -138,7 +138,7 @@ import Distribution.Compat.Exception (catchIO, throwIOIO) import Control.Monad (when) -import Data.List (intersperse, unionBy) +import Data.List (intersperse, unionBy, nub, (\\)) -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the @@ -302,6 +302,9 @@ pdfile <- defaultPackageDesc verbosity ppd <- readPackageDescription verbosity pdfile let pkg_descr0 = flattenPackageDescription ppd + -- We don't sanity check for clean as an error + -- here would prevent cleaning: + --sanityCheckHookedBuildInfo pkg_descr0 pbi let pkg_descr = updatePackageDescription pbi pkg_descr0 cleanHook hooks pkg_descr () hooks flags @@ -333,6 +336,7 @@ pdfile <- defaultPackageDesc verbosity ppd <- readPackageDescription verbosity pdfile let pkg_descr0 = flattenPackageDescription ppd + sanityCheckHookedBuildInfo pkg_descr0 pbi let pkg_descr = updatePackageDescription pbi pkg_descr0 sDistHook hooks pkg_descr mlbi hooks flags @@ -384,12 +388,31 @@ localbuildinfo <- get_build_config let pkg_descr0 = localPkgDescr localbuildinfo --pkg_descr0 <- get_pkg_descr (get_verbose flags) + sanityCheckHookedBuildInfo pkg_descr0 pbi let pkg_descr = updatePackageDescription pbi pkg_descr0 -- TODO: should we write the modified package descr back to the -- localbuildinfo? cmd_hook hooks pkg_descr localbuildinfo hooks flags post_hook hooks args flags pkg_descr localbuildinfo +sanityCheckHookedBuildInfo :: PackageDescription -> HookedBuildInfo -> IO () +sanityCheckHookedBuildInfo PackageDescription { library = Nothing } (Just _,_) + = die $ "The buildinfo contains info for a library, " + ++ "but the package does not have a library." + +sanityCheckHookedBuildInfo pkg_descr (_, hookExes) + | not (null nonExistant) + = die $ "The buildinfo contains info for an executable called '" + ++ head nonExistant ++ "' but the package does not have a " + ++ "executable with that name." + where + pkgExeNames = nub (map exeName (executables pkg_descr)) + hookExeNames = nub (map fst hookExes) + nonExistant = hookExeNames \\ pkgExeNames + +sanityCheckHookedBuildInfo _ _ = return () + + getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo getBuildConfig hooks verbosity distPref = do lbi_wo_programs <- getPersistBuildConfig distPref @@ -524,6 +547,7 @@ backwardsCompatHack flags lbi pbi <- getHookedBuildInfo verbosity + sanityCheckHookedBuildInfo pkg_descr pbi let pkg_descr' = updatePackageDescription pbi pkg_descr postConf simpleUserHooks args flags pkg_descr' lbi @@ -554,6 +578,7 @@ else die "configure script not found." pbi <- getHookedBuildInfo verbosity + sanityCheckHookedBuildInfo pkg_descr pbi let pkg_descr' = updatePackageDescription pbi pkg_descr postConf simpleUserHooks args flags pkg_descr' lbi diff --git a/Distribution/Simple/Build.hs b/Distribution/Simple/Build.hs --- a/Distribution/Simple/Build.hs +++ b/Distribution/Simple/Build.hs @@ -76,11 +76,11 @@ import Distribution.Simple.Setup ( BuildFlags(..), fromFlag ) import Distribution.Simple.PreProcess - ( preprocessSources, PPSuffixHandler ) + ( preprocessComponent, PPSuffixHandler ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(compiler, buildDir, withPackageDB) - , ComponentLocalBuildInfo(..), withLibLBI, withExeLBI - , inplacePackageId, withTestLBI ) + , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI + , inplacePackageId ) import Distribution.Simple.BuildPaths ( autogenModulesDir, autogenModuleName, cppHeaderName ) import Distribution.Simple.Register @@ -107,100 +107,102 @@ -- ----------------------------------------------------------------------------- -- |Build the libraries and executables in this package. -build :: PackageDescription -- ^mostly information from the .cabal file - -> LocalBuildInfo -- ^Configuration information - -> BuildFlags -- ^Flags that the user passed to build - -> [ PPSuffixHandler ] -- ^preprocessors to run before compiling +build :: PackageDescription -- ^ Mostly information from the .cabal file + -> LocalBuildInfo -- ^ Configuration information + -> BuildFlags -- ^ Flags that the user passed to build + -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling -> IO () build pkg_descr lbi flags suffixes = do let distPref = fromFlag (buildDistPref flags) verbosity = fromFlag (buildVerbosity flags) - initialBuildSteps distPref pkg_descr lbi verbosity suffixes + initialBuildSteps distPref pkg_descr lbi verbosity setupMessage verbosity "Building" (packageId pkg_descr) internalPackageDB <- createInternalPackageDB distPref - withLibLBI pkg_descr lbi $ \lib clbi -> do - info verbosity "Building library..." - buildLib verbosity pkg_descr lbi lib clbi - - -- Register the library in-place, so exes can depend - -- on internally defined libraries. - pwd <- getCurrentDirectory - let installedPkgInfo = - (inplaceInstalledPackageInfo pwd distPref pkg_descr lib lbi clbi) { - -- The inplace registration uses the "-inplace" suffix, - -- not an ABI hash. - IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo) - } - registerPackage verbosity - installedPkgInfo pkg_descr lbi True -- True meaning inplace - (withPackageDB lbi ++ [internalPackageDB]) + let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes + lbi' = lbi {withPackageDB = withPackageDB lbi ++ [internalPackageDB]} + -- Use the internal package DB for the exes. + withComponentsLBI pkg_descr lbi $ \comp clbi -> do + pre comp + case comp of + CLib lib -> do + info verbosity "Building library..." + buildLib verbosity pkg_descr lbi lib clbi - -- Use the internal package db for the exes. - let lbi' = lbi { withPackageDB = withPackageDB lbi ++ [internalPackageDB] } + -- Register the library in-place, so exes can depend + -- on internally defined libraries. + pwd <- getCurrentDirectory + let installedPkgInfo = + (inplaceInstalledPackageInfo pwd distPref pkg_descr lib lbi clbi) { + -- The inplace registration uses the "-inplace" suffix, + -- not an ABI hash. + IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo) + } + registerPackage verbosity + installedPkgInfo pkg_descr lbi True -- True meaning inplace + (withPackageDB lbi ++ [internalPackageDB]) - withExeLBI pkg_descr lbi' $ \exe clbi -> do - info verbosity $ "Building executable " ++ exeName exe ++ "..." - buildExe verbosity pkg_descr lbi' exe clbi + CExe exe -> do + info verbosity $ "Building executable " ++ exeName exe ++ "..." + buildExe verbosity pkg_descr lbi' exe clbi - withTestLBI pkg_descr lbi' $ \test clbi -> - case testInterface test of - TestSuiteExeV10 _ f -> do - let exe = Executable - { exeName = testName test - , modulePath = f - , buildInfo = testBuildInfo test - } - info verbosity $ "Building test suite " ++ testName test ++ "..." - buildExe verbosity pkg_descr lbi' exe clbi - TestSuiteLibV09 _ m -> do - pwd <- getCurrentDirectory - let lib = Library - { exposedModules = [ m ] - , libExposed = True - , libBuildInfo = testBuildInfo test - } - pkg = pkg_descr - { package = (package pkg_descr) - { pkgName = PackageName $ testName test + CTest test -> do + case testInterface test of + TestSuiteExeV10 _ f -> do + let exe = Executable + { exeName = testName test + , modulePath = f + , buildInfo = testBuildInfo test } - , buildDepends = targetBuildDepends $ testBuildInfo test - , executables = [] - , testSuites = [] - , library = Just lib - } - ipi = (inplaceInstalledPackageInfo - pwd distPref pkg lib lbi clbi) - { IPI.installedPackageId = inplacePackageId $ packageId ipi - } - testDir = buildDir lbi' stubName test - stubName test ++ "-tmp" - testLibDep = thisPackageVersion $ package pkg - exe = Executable - { exeName = stubName test - , modulePath = stubFilePath test - , buildInfo = (testBuildInfo test) - { hsSourceDirs = [ testDir ] - , targetBuildDepends = testLibDep - : (targetBuildDepends $ testBuildInfo test) + info verbosity $ "Building test suite " ++ testName test ++ "..." + buildExe verbosity pkg_descr lbi' exe clbi + TestSuiteLibV09 _ m -> do + pwd <- getCurrentDirectory + let lib = Library + { exposedModules = [ m ] + , libExposed = True + , libBuildInfo = testBuildInfo test } - } - -- | The stub executable needs a new 'ComponentLocalBuildInfo' - -- that exposes the relevant test suite library. - exeClbi = clbi - { componentPackageDeps = - (IPI.installedPackageId ipi, packageId ipi) - : (filter (\(_, x) -> let PackageName name = pkgName x in name == "Cabal" || name == "base") - $ componentPackageDeps clbi) - } - info verbosity $ "Building test suite " ++ testName test ++ "..." - buildLib verbosity pkg lbi' lib clbi - registerPackage verbosity ipi pkg lbi' True $ withPackageDB lbi' - buildExe verbosity pkg_descr lbi' exe exeClbi - TestSuiteUnsupported tt -> die $ "No support for building test suite " - ++ "type " ++ display tt - + pkg = pkg_descr + { package = (package pkg_descr) + { pkgName = PackageName $ testName test + } + , buildDepends = targetBuildDepends $ testBuildInfo test + , executables = [] + , testSuites = [] + , library = Just lib + } + ipi = (inplaceInstalledPackageInfo + pwd distPref pkg lib lbi clbi) + { IPI.installedPackageId = inplacePackageId $ packageId ipi + } + testDir = buildDir lbi' stubName test + stubName test ++ "-tmp" + testLibDep = thisPackageVersion $ package pkg + exe = Executable + { exeName = stubName test + , modulePath = stubFilePath test + , buildInfo = (testBuildInfo test) + { hsSourceDirs = [ testDir ] + , targetBuildDepends = testLibDep + : (targetBuildDepends $ testBuildInfo test) + } + } + -- | The stub executable needs a new 'ComponentLocalBuildInfo' + -- that exposes the relevant test suite library. + exeClbi = clbi + { componentPackageDeps = + (IPI.installedPackageId ipi, packageId ipi) + : (filter (\(_, x) -> let PackageName name = pkgName x in name == "Cabal" || name == "base") + $ componentPackageDeps clbi) + } + info verbosity $ "Building test suite " ++ testName test ++ "..." + buildLib verbosity pkg lbi' lib clbi + registerPackage verbosity ipi pkg lbi' True $ withPackageDB lbi' + buildExe verbosity pkg_descr lbi' exe exeClbi + TestSuiteUnsupported tt -> die $ "No support for building test suite " + ++ "type " ++ display tt -- | Initialize a new package db file for libraries defined -- internally to the package. @@ -241,9 +243,8 @@ -> PackageDescription -- ^mostly information from the .cabal file -> LocalBuildInfo -- ^Configuration information -> Verbosity -- ^The verbosity to use - -> [ PPSuffixHandler ] -- ^preprocessors to run before compiling -> IO () -initialBuildSteps _distPref pkg_descr lbi verbosity suffixes = do +initialBuildSteps _distPref pkg_descr lbi verbosity = do -- check that there's something to build let buildInfos = map libBuildInfo (maybeToList (library pkg_descr)) ++ @@ -255,8 +256,6 @@ createDirectoryIfMissingVerbose verbosity True (buildDir lbi) writeAutogenFiles verbosity pkg_descr lbi - - preprocessSources pkg_descr lbi False verbosity suffixes -- | Generate and write out the Paths_.hs and cabal_macros.h files -- diff --git a/Distribution/Simple/Build/PathsModule.hs b/Distribution/Simple/Build/PathsModule.hs --- a/Distribution/Simple/Build/PathsModule.hs +++ b/Distribution/Simple/Build/PathsModule.hs @@ -72,12 +72,15 @@ " ) where\n"++ "\n"++ foreign_imports++ + "import qualified Control.Exception as Exception\n"++ "import Data.Version (Version(..))\n"++ "import System.Environment (getEnv)"++ "\n"++ + "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++ + "catchIO = Exception.catch\n" ++ + "\n"++ "\nversion :: Version"++ - "\nversion = " ++ show (packageVersion pkg_descr)++ - "\n" + "\nversion = " ++ show (packageVersion pkg_descr) body | absolute = @@ -140,7 +143,7 @@ mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel mkGetDir dir Nothing = "return " ++ show dir - mkGetEnvOr var expr = "catch (getEnv \""++var'++"\")"++ + mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++ " (\\_ -> "++expr++")" where var' = pkgPathEnvVar pkg_descr var @@ -189,20 +192,21 @@ get_prefix_win32 :: String get_prefix_win32 = "getPrefixDirRel :: FilePath -> IO FilePath\n"++ - "getPrefixDirRel dirRel = do \n"++ - " let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.\n"++ - " buf <- mallocArray len\n"++ - " ret <- getModuleFileName nullPtr buf len\n"++ - " if ret == 0 \n"++ - " then do free buf;\n"++ - " return (prefix `joinFileName` dirRel)\n"++ - " else do exePath <- peekCString buf\n"++ - " free buf\n"++ - " let (bindir,_) = splitFileName exePath\n"++ - " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ + "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n"++ + " where\n"++ + " try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n"++ + " ret <- c_GetModuleFileName nullPtr buf size\n"++ + " case ret of\n"++ + " 0 -> return (prefix `joinFileName` dirRel)\n"++ + " _ | ret < size -> do\n"++ + " exePath <- peekCWString buf\n"++ + " let (bindir,_) = splitFileName exePath\n"++ + " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ + " | otherwise -> try_size (size * 2)\n"++ "\n"++ - "foreign import stdcall unsafe \"windows.h GetModuleFileNameA\"\n"++ - " getModuleFileName :: Ptr () -> CString -> Int -> IO Int32\n" + "foreign import stdcall unsafe \"windows.h GetModuleFileNameW\"\n"++ + " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + get_prefix_hugs :: String get_prefix_hugs = diff --git a/Distribution/Simple/Compiler.hs b/Distribution/Simple/Compiler.hs --- a/Distribution/Simple/Compiler.hs +++ b/Distribution/Simple/Compiler.hs @@ -80,8 +80,8 @@ data Compiler = Compiler { compilerId :: CompilerId, - compilerLanguages :: [(Language, String)], - compilerExtensions :: [(Extension, String)] + compilerLanguages :: [(Language, Flag)], + compilerExtensions :: [(Extension, Flag)] } deriving (Show, Read) diff --git a/Distribution/Simple/Configure.hs b/Distribution/Simple/Configure.hs --- a/Distribution/Simple/Configure.hs +++ b/Distribution/Simple/Configure.hs @@ -14,7 +14,7 @@ -- tools are available (including version checks if appropriate); checks for -- any required @pkg-config@ packages (updating the 'BuildInfo' with the -- results) --- +-- -- Then based on all this it saves the info in the 'LocalBuildInfo' and writes -- it out to the @dist\/setup-config@ file. It also displays various details to -- the user, the amount of information displayed depending on the verbosity @@ -69,7 +69,7 @@ , showCompilerId, unsupportedLanguages, unsupportedExtensions , PackageDB(..), PackageDBStack ) import Distribution.Package - ( PackageName(PackageName), PackageIdentifier(PackageIdentifier), PackageId + ( PackageName(PackageName), PackageIdentifier(..), PackageId , packageName, packageVersion, Package(..) , Dependency(Dependency), simplifyDependency , InstalledPackageId(..) ) @@ -87,10 +87,11 @@ ( finalizePackageDescription, mapTreeData ) import Distribution.PackageDescription.Check ( PackageCheck(..), checkPackage, checkPackageFiles ) +import Distribution.Simple.Hpc ( enableCoverage ) import Distribution.Simple.Program ( Program(..), ProgramLocation(..), ConfiguredProgram(..) , ProgramConfiguration, defaultProgramConfiguration - , configureAllKnownPrograms, knownPrograms, lookupKnownProgram + , configureAllKnownPrograms, knownPrograms, lookupKnownProgram, addKnownProgram , userSpecifyArgss, userSpecifyPaths , requireProgram, requireProgramVersion , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf ) @@ -100,13 +101,14 @@ ( InstallDirs(..), defaultInstallDirs, combineInstallDirs ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) - , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId ) + , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId + , allComponentsBy, Component(..), foldComponent, ComponentName(..) ) import Distribution.Simple.BuildPaths ( autogenModulesDir ) import Distribution.Simple.Utils ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose , intercalate, cabalVersion - , withFileContents, writeFileAtomic + , withFileContents, writeFileAtomic , withTempFile ) import Distribution.System ( OS(..), buildOS, buildPlatform ) @@ -123,13 +125,15 @@ import qualified Distribution.Simple.UHC as UHC import Control.Monad - ( when, unless, foldM, filterM ) + ( when, unless, foldM, filterM, forM ) import Data.List - ( nub, partition, isPrefixOf, inits ) + ( nub, partition, isPrefixOf, inits, find ) import Data.Maybe - ( isNothing, catMaybes ) + ( isNothing, catMaybes, mapMaybe ) import Data.Monoid ( Monoid(..) ) +import Data.Graph + ( SCC(..), graphFromEdges, transposeG, vertices, stronglyConnCompR ) import System.Directory ( doesFileExist, getModificationTime, createDirectoryIfMissing, getTemporaryDirectory ) import System.Exit @@ -264,6 +268,7 @@ -> ConfigFlags -> IO LocalBuildInfo configure (pkg_descr0, pbi) cfg = do let distPref = fromFlag (configDistPref cfg) + buildDir' = distPref "build" verbosity = fromFlag (configVerbosity cfg) setupMessage verbosity "Configuring" (packageId pkg_descr0) @@ -340,7 +345,9 @@ -- add extra include/lib dirs as specified in cfg -- we do it here so that those get checked too - let pkg_descr = addExtraIncludeLibDirs pkg_descr0' + let pkg_descr = + enableCoverage (fromFlag (configLibCoverage cfg)) distPref + $ addExtraIncludeLibDirs pkg_descr0' when (not (null flags)) $ info verbosity $ "Flags chosen: " @@ -422,13 +429,21 @@ ++ "supported by " ++ display (compilerId comp) ++ ": " ++ intercalate ", " (map display exts) + -- configured known/required programs & build tools let requiredBuildTools = concatMap buildTools (allBuildInfo pkg_descr) - programsConfig'' <- - configureAllKnownPrograms (lessVerbose verbosity) programsConfig' + + -- add all exes built by this package ("internal exes") to the program + -- conf; this makes the namespace of build-tools include intrapackage + -- references to executables + let programsConfig'' = foldr (addInternalExe buildDir') programsConfig' + (executables pkg_descr) + + programsConfig''' <- + configureAllKnownPrograms (lessVerbose verbosity) programsConfig'' >>= configureRequiredPrograms verbosity requiredBuildTools - (pkg_descr', programsConfig''') <- configurePkgconfigPackages verbosity - pkg_descr programsConfig'' + (pkg_descr', programsConfig'''') <- + configurePkgconfigPackages verbosity pkg_descr programsConfig''' split_objs <- if not (fromFlag $ configSplitObjs cfg) @@ -446,7 +461,7 @@ -- needs. Note, this only works because we cannot yet depend on two -- versions of the same package. let configLib lib = configComponent (libBuildInfo lib) - configExe exe = (exeName exe, configComponent(buildInfo exe)) + configExe exe = (exeName exe, configComponent (buildInfo exe)) configTest test = (testName test, configComponent(testBuildInfo test)) configComponent bi = ComponentLocalBuildInfo { @@ -465,27 +480,60 @@ where names = [ name | Dependency name _ <- targetBuildDepends bi ] - let lbi = LocalBuildInfo{ + -- Obtains the intrapackage dependencies for the given component + let ipDeps component = + mapMaybe exeDepToComp (buildTools bi) + ++ mapMaybe libDepToComp (targetBuildDepends bi) + where + bi = foldComponent libBuildInfo buildInfo testBuildInfo component + exeDepToComp (Dependency (PackageName name) _) = + CExe `fmap` find ((==) name . exeName) + (executables pkg_descr') + libDepToComp (Dependency pn _) + | pn `elem` map packageName internalPkgDeps = + CLib `fmap` library pkg_descr' + libDepToComp _ = Nothing + + let sccs = (stronglyConnCompR . map lkup . vertices . transposeG) g + where (g, lkup, _) = graphFromEdges + $ allComponentsBy pkg_descr' + $ \c -> (c, key c, map key (ipDeps c)) + key = foldComponent (const "library") exeName testName + + -- check for cycles in the dependency graph + buildOrder <- forM sccs $ \scc -> case scc of + AcyclicSCC (c,_,_) -> return (foldComponent (const CLibName) + (CExeName . exeName) + (CTestName . testName) + c) + CyclicSCC vs -> + die $ "Found cycle in intrapackage dependency graph:\n " + ++ intercalate " depends on " + (map (\(_,k,_) -> "'" ++ k ++ "'") (vs ++ [head vs])) + + let lbi = LocalBuildInfo { configFlags = cfg, extraConfigArgs = [], -- Currently configure does not -- take extra args, but if it -- did they would go here. installDirTemplates = installDirs, compiler = comp, - buildDir = distPref "build", + buildDir = buildDir', scratchDir = fromFlagOrDefault (distPref "scratch") (configScratchDir cfg), libraryConfig = configLib `fmap` library pkg_descr', executableConfigs = configExe `fmap` executables pkg_descr', - testSuiteConfigs = configTest `fmap` filter testEnabled (testSuites pkg_descr'), + testSuiteConfigs = configTest `fmap` testSuites pkg_descr', + compBuildOrder = buildOrder, installedPkgs = packageDependsIndex, pkgDescrFile = Nothing, localPkgDescr = pkg_descr', - withPrograms = programsConfig''', + withPrograms = programsConfig'''', withVanillaLib = fromFlag $ configVanillaLib cfg, withProfLib = fromFlag $ configProfLib cfg, withSharedLib = fromFlag $ configSharedLib cfg, + withDynExe = fromFlag $ configDynExe cfg, withProfExe = fromFlag $ configProfExe cfg, withOptimization = fromFlag $ configOptimization cfg, withGHCiLib = fromFlag $ configGHCiLib cfg, @@ -522,11 +570,20 @@ dirinfo "Documentation" (docdir dirs) (docdir relative) sequence_ [ reportProgram verbosity prog configuredProg - | (prog, configuredProg) <- knownPrograms programsConfig''' ] + | (prog, configuredProg) <- knownPrograms programsConfig'''' ] return lbi where + addInternalExe bd exe = + let nm = exeName exe in + addKnownProgram Program { + programName = nm, + programFindLocation = \_ -> return $ Just $ bd nm nm, + programFindVersion = \_ _ -> return Nothing, + programPostConf = \_ _ -> return [] + } + addExtraIncludeLibDirs pkg_descr = let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg , PD.includeDirs = configExtraIncludeDirs cfg} diff --git a/Distribution/Simple/GHC.hs b/Distribution/Simple/GHC.hs --- a/Distribution/Simple/GHC.hs +++ b/Distribution/Simple/GHC.hs @@ -115,7 +115,7 @@ import Distribution.Verbosity import Distribution.Text ( display, simpleParse ) -import Language.Haskell.Extension (Language(..), Extension(..)) +import Language.Haskell.Extension (Language(..), Extension(..), KnownExtension(..)) import Control.Monad ( unless, when, liftM ) import Data.Char ( isSpace ) @@ -358,49 +358,73 @@ getExtensions verbosity ghcProg | ghcVersion >= Version [6,7] [] = do - exts <- rawSystemStdout verbosity (programPath ghcProg) + str <- rawSystemStdout verbosity (programPath ghcProg) ["--supported-languages"] - -- GHC has the annoying habit of inverting some of the extensions - -- so we have to try parsing ("No" ++ ghcExtensionName) first - let readExtension str = do - ext <- simpleParse ("No" ++ str) - case ext of - UnknownExtension _ -> simpleParse str - _ -> return ext - return $ extensionHacks - ++ [ (ext, "-X" ++ display ext) - | Just ext <- map readExtension (lines exts) ] + let extStrs = if ghcVersion >= Version [7] [] + then lines str + else -- Older GHCs only gave us either Foo or NoFoo, + -- so we have to work out the other one ourselves + [ extStr'' + | extStr <- lines str + , let extStr' = case extStr of + 'N' : 'o' : xs -> xs + _ -> "No" ++ extStr + , extStr'' <- [extStr, extStr'] + ] + let extensions0 = [ (ext, "-X" ++ display ext) + | Just ext <- map simpleParse extStrs ] + extensions1 = if ghcVersion >= Version [6,8] [] && + ghcVersion < Version [6,10] [] + then -- ghc-6.8 introduced RecordPuns however it + -- should have been NamedFieldPuns. We now + -- encourage packages to use NamedFieldPuns + -- so for compatability we fake support for + -- it in ghc-6.8 by making it an alias for + -- the old RecordPuns extension. + (EnableExtension NamedFieldPuns, "-XRecordPuns") : + (DisableExtension NamedFieldPuns, "-XNoRecordPuns") : + extensions0 + else extensions0 + extensions2 = if ghcVersion < Version [7,1] [] + then -- ghc-7.2 split NondecreasingIndentation off + -- into a proper extension. Before that it + -- was always on. + (EnableExtension NondecreasingIndentation, "") : + (DisableExtension NondecreasingIndentation, "") : + extensions1 + else extensions1 + return extensions2 | otherwise = return oldLanguageExtensions where Just ghcVersion = programVersion ghcProg - -- ghc-6.8 intorduced RecordPuns however it should have been - -- NamedFieldPuns. We now encourage packages to use NamedFieldPuns so for - -- compatability we fake support for it in ghc-6.8 by making it an alias - -- for the old RecordPuns extension. - extensionHacks = [ (NamedFieldPuns, "-XRecordPuns") - | ghcVersion >= Version [6,8] [] - && ghcVersion < Version [6,10] [] ] - -- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags oldLanguageExtensions :: [(Extension, Flag)] oldLanguageExtensions = - [(OverlappingInstances , "-fallow-overlapping-instances") - ,(TypeSynonymInstances , "-fglasgow-exts") - ,(TemplateHaskell , "-fth") - ,(ForeignFunctionInterface , "-fffi") - ,(NoMonomorphismRestriction , "-fno-monomorphism-restriction") - ,(NoMonoPatBinds , "-fno-mono-pat-binds") - ,(UndecidableInstances , "-fallow-undecidable-instances") - ,(IncoherentInstances , "-fallow-incoherent-instances") - ,(Arrows , "-farrows") - ,(Generics , "-fgenerics") - ,(NoImplicitPrelude , "-fno-implicit-prelude") - ,(ImplicitParams , "-fimplicit-params") - ,(CPP , "-cpp") - ,(BangPatterns , "-fbang-patterns") + let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), + (DisableExtension f, disable)] + fglasgowExts = ("-fglasgow-exts", + "") -- This is wrong, but we don't want to turn + -- all the extensions off when asked to just + -- turn one off + fFlag flag = ("-f" ++ flag, "-fno-" ++ flag) + in concatMap doFlag + [(OverlappingInstances , fFlag "allow-overlapping-instances") + ,(TypeSynonymInstances , fglasgowExts) + ,(TemplateHaskell , fFlag "th") + ,(ForeignFunctionInterface , fFlag "ffi") + ,(MonomorphismRestriction , fFlag "monomorphism-restriction") + ,(MonoPatBinds , fFlag "mono-pat-binds") + ,(UndecidableInstances , fFlag "allow-undecidable-instances") + ,(IncoherentInstances , fFlag "allow-incoherent-instances") + ,(Arrows , fFlag "arrows") + ,(Generics , fFlag "generics") + ,(ImplicitPrelude , fFlag "implicit-prelude") + ,(ImplicitParams , fFlag "implicit-params") + ,(CPP , ("-cpp", ""{- Wrong -})) + ,(BangPatterns , fFlag "bang-patterns") ,(KindSignatures , fglasgowExts) ,(RecursiveDo , fglasgowExts) ,(ParallelListComp , fglasgowExts) @@ -410,7 +434,7 @@ ,(RankNTypes , fglasgowExts) ,(PolymorphicComponents , fglasgowExts) ,(ExistentialQuantification , fglasgowExts) - ,(ScopedTypeVariables , "-fscoped-type-variables") + ,(ScopedTypeVariables , fFlag "scoped-type-variables") ,(FlexibleContexts , fglasgowExts) ,(FlexibleInstances , fglasgowExts) ,(EmptyDataDecls , fglasgowExts) @@ -424,13 +448,11 @@ ,(TypeOperators , fglasgowExts) ,(GADTs , fglasgowExts) ,(RelaxedPolyRec , fglasgowExts) - ,(ExtendedDefaultRules , "-fextended-default-rules") + ,(ExtendedDefaultRules , fFlag "extended-default-rules") ,(UnboxedTuples , fglasgowExts) ,(DeriveDataTypeable , fglasgowExts) ,(ConstrainedClassMethods , fglasgowExts) ] - where - fglasgowExts = "-fglasgow-exts" getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration -> IO PackageIndex @@ -568,7 +590,7 @@ comp (withProfLib lbi) (libBuildInfo lib) let libTargetDir = pref - forceVanillaLib = TemplateHaskell `elem` allExtensions libBi + forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi -- TH always needs vanilla libs, even when building for profiling createDirectoryIfMissingVerbose verbosity True libTargetDir @@ -600,6 +622,7 @@ info verbosity "Building C Sources..." sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref filename verbosity + False (withProfLib lbi) createDirectoryIfMissingVerbose verbosity True odir runGhcProg args @@ -734,7 +757,7 @@ info verbosity "Building C Sources." sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi exeDir filename verbosity - (withProfExe lbi) + (withDynExe lbi) (withProfExe lbi) createDirectoryIfMissingVerbose verbosity True odir runGhcProg args | filename <- cSources exeBi] @@ -742,7 +765,7 @@ srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) - let binArgs linkExe profExe = + let binArgs linkExe dynExe profExe = "--make" : (if linkExe then ["-o", targetDir exeNameReal] @@ -754,6 +777,9 @@ ++ ["-l"++lib | lib <- extraLibs exeBi] ++ ["-L"++libDir | libDir <- extraLibDirs exeBi] ++ concat [["-framework", f] | f <- PD.frameworks exeBi] + ++ if dynExe + then ["-dynamic"] + else [] ++ if profExe then ["-prof", "-hisuf", "p_hi", @@ -766,10 +792,10 @@ -- with profiling. This is because the code that TH needs to -- run at compile time needs to be the vanilla ABI so it can -- be loaded up and run by the compiler. - when (withProfExe lbi && TemplateHaskell `elem` allExtensions exeBi) - (runGhcProg (binArgs False False)) + when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi) + (runGhcProg (binArgs False (withDynExe lbi) False)) - runGhcProg (binArgs True (withProfExe lbi)) + runGhcProg (binArgs True (withDynExe lbi) (withProfExe lbi)) -- | Filter the "-threaded" flag when profiling as it does not -- work with ghc-6.8 and older. @@ -899,9 +925,9 @@ ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath -> Verbosity -> Bool + -> FilePath -> FilePath -> Verbosity -> Bool -> Bool ->(FilePath,[String]) -constructCcCmdLine lbi bi clbi pref filename verbosity profiling +constructCcCmdLine lbi bi clbi pref filename verbosity dynamic profiling = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref | otherwise = pref takeDirectory filename -- ghc 6.4.1 fixed a bug in -odir handling @@ -915,6 +941,7 @@ -- option to ghc here when compiling C code, so that the PROFILING -- macro gets defined. The macro is used in ghc's Rts.h in the -- definitions of closure layouts (Closures.h). + ++ ["-dynamic" | dynamic] ++ ["-prof" | profiling]) ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo diff --git a/Distribution/Simple/GHC/IPI641.hs b/Distribution/Simple/GHC/IPI641.hs --- a/Distribution/Simple/GHC/IPI641.hs +++ b/Distribution/Simple/GHC/IPI641.hs @@ -104,11 +104,13 @@ Current.stability = stability ipi, Current.homepage = homepage ipi, Current.pkgUrl = pkgUrl ipi, + Current.synopsis = "", Current.description = description ipi, Current.category = category ipi, Current.exposed = exposed ipi, Current.exposedModules = map convertModuleName (exposedModules ipi), Current.hiddenModules = map convertModuleName (hiddenModules ipi), + Current.trusted = False, Current.importDirs = importDirs ipi, Current.libraryDirs = libraryDirs ipi, Current.hsLibraries = hsLibraries ipi, diff --git a/Distribution/Simple/GHC/IPI642.hs b/Distribution/Simple/GHC/IPI642.hs --- a/Distribution/Simple/GHC/IPI642.hs +++ b/Distribution/Simple/GHC/IPI642.hs @@ -139,11 +139,13 @@ Current.stability = stability ipi, Current.homepage = homepage ipi, Current.pkgUrl = pkgUrl ipi, + Current.synopsis = "", Current.description = description ipi, Current.category = category ipi, Current.exposed = exposed ipi, Current.exposedModules = map convertModuleName (exposedModules ipi), Current.hiddenModules = map convertModuleName (hiddenModules ipi), + Current.trusted = False, Current.importDirs = importDirs ipi, Current.libraryDirs = libraryDirs ipi, Current.hsLibraries = hsLibraries ipi, diff --git a/Distribution/Simple/Haddock.hs b/Distribution/Simple/Haddock.hs --- a/Distribution/Simple/Haddock.hs +++ b/Distribution/Simple/Haddock.hs @@ -56,8 +56,7 @@ import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD ( PackageDescription(..), BuildInfo(..), allExtensions - , Library(..), hasLibs, withLib - , Executable(..), withExe ) + , Library(..), hasLibs, Executable(..) ) import Distribution.Simple.Compiler ( Compiler(..), compilerVersion ) import Distribution.Simple.GHC ( ghcLibDir ) @@ -65,8 +64,9 @@ ( ConfiguredProgram(..), requireProgramVersion , rawSystemProgram, rawSystemProgramStdout , hscolourProgram, haddockProgram ) -import Distribution.Simple.PreProcess (ppCpp', ppUnlit, - PPSuffixHandler, runSimplePreProcessor) +import Distribution.Simple.PreProcess (ppCpp', ppUnlit + , PPSuffixHandler, runSimplePreProcessor + , preprocessComponent) import Distribution.Simple.Setup ( defaultHscolourFlags, Flag(..), flagToMaybe, fromFlag , HaddockFlags(..), HscolourFlags(..) ) @@ -78,7 +78,7 @@ initialPathTemplateEnv) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), externalPackageDeps - , ComponentLocalBuildInfo(..), withLibLBI, withExeLBI ) + , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI ) import Distribution.Simple.BuildPaths ( haddockName, hscolourPref, autogenModulesDir, ) @@ -112,7 +112,7 @@ import System.IO (hClose, hPutStrLn) import Distribution.Version --- Types +-- Types -- | record that represents the arguments to the haddock executable, a product monoid. data HaddockArgs = HaddockArgs { @@ -122,7 +122,7 @@ argIgnoreExports :: Any, -- ^ ingore export lists in modules? argLinkSource :: Flag (Template,Template), -- ^ (template for modules, template for symbols) argCssFile :: Flag FilePath, -- ^ optinal custom css file. - argVerbose :: Any, + argVerbose :: Any, argOutput :: Flag [Output], -- ^ Html or Hoogle doc or both? required. argInterfaces :: [(FilePath, Maybe FilePath)], -- ^ [(interface file, path to the html docs for links)] argOutputDir :: Directory, -- ^ where to generate the documentation. @@ -164,7 +164,7 @@ -- various sanity checks let isVersion2 = version >= Version [2,0] [] - when ( flag haddockHoogle + when ( flag haddockHoogle && version > Version [2] [] && version < Version [2,2] []) $ die "haddock 2.0 and 2.1 do not support the --hoogle flag." @@ -188,35 +188,37 @@ -- the tools match the requests, we can proceed - initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity suffixes - - when (flag haddockHscolour) $ hscolour' pkg_descr lbi $ + initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity + + when (flag haddockHscolour) $ hscolour' pkg_descr lbi suffixes $ defaultHscolourFlags `mappend` haddockToHscolour flags - - args <- fmap mconcat . sequence $ - [ getInterfaces verbosity lbi (flagToMaybe (haddockHtmlLocation flags)) - , getGhcLibDir verbosity lbi isVersion2 ] - ++ map return + + args <- fmap mconcat . sequence $ + [ getInterfaces verbosity lbi (flagToMaybe (haddockHtmlLocation flags)) + , getGhcLibDir verbosity lbi isVersion2 ] + ++ map return [ fromFlags flags , fromPackageDescription pkg_descr ] - withLibLBI pkg_descr lbi $ \lib clbi -> - withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do - let bi = libBuildInfo lib - libArgs <- fromLibrary tmp lbi lib clbi - libArgs' <- prepareSources verbosity tmp - lbi isVersion2 bi (args `mappend` libArgs) - runHaddock verbosity confHaddock libArgs' - - when (flag haddockExecutables) $ - withExeLBI pkg_descr lbi $ \exe clbi -> - withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do - let bi = buildInfo exe - exeArgs <- fromExecutable tmp lbi exe clbi - exeArgs' <- prepareSources verbosity tmp - lbi isVersion2 bi (args `mappend` exeArgs) - runHaddock verbosity confHaddock exeArgs' - + let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes + withComponentsLBI pkg_descr lbi $ \comp clbi -> do + pre comp + case comp of + CLib lib -> do + withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do + let bi = libBuildInfo lib + libArgs <- fromLibrary tmp lbi lib clbi + libArgs' <- prepareSources verbosity tmp + lbi isVersion2 bi (args `mappend` libArgs) + runHaddock verbosity confHaddock libArgs' + CExe exe -> when (flag haddockExecutables) $ do + withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do + let bi = buildInfo exe + exeArgs <- fromExecutable tmp lbi exe clbi + exeArgs' <- prepareSources verbosity tmp + lbi isVersion2 bi (args `mappend` exeArgs) + runHaddock verbosity confHaddock exeArgs' + _ -> return () where verbosity = flag haddockVerbosity flag f = fromFlag $ f flags @@ -233,13 +235,13 @@ prepareSources verbosity tmp lbi isVersion2 bi args@HaddockArgs{argTargets=files} = mapM (mockPP tmp) files >>= \targets -> return args {argTargets=targets} where - mockPP pref file = do + mockPP pref file = do let (filePref, fileName) = splitFileName file targetDir = pref filePref targetFile = targetDir fileName (targetFileNoext, targetFileExt) = splitExtension $ targetFile hsFile = targetFileNoext <.> "hs" - + assert (targetFileExt `elem` [".lhs",".hs"]) $ return () createDirectoryIfMissing True targetDir @@ -256,7 +258,7 @@ removeFile targetFile return hsFile - needsCpp = CPP `elem` allExtensions bi + needsCpp = EnableExtension CPP `elem` allExtensions bi defines | isVersion2 = [] | otherwise = ["-D__HADDOCK__"] @@ -264,7 +266,7 @@ -- constributions to HaddockArgs fromFlags :: HaddockFlags -> HaddockArgs -fromFlags flags = +fromFlags flags = mempty { argHideModules = (maybe mempty (All . not) $ flagToMaybe (haddockInternal flags), mempty), argLinkSource = if fromFlag (haddockHscolour flags) @@ -282,15 +284,15 @@ } fromPackageDescription :: PackageDescription -> HaddockArgs -fromPackageDescription pkg_descr = +fromPackageDescription pkg_descr = mempty { - argInterfaceFile = Flag $ haddockName pkg_descr, - argPackageName = Flag $ packageId $ pkg_descr, + argInterfaceFile = Flag $ haddockName pkg_descr, + argPackageName = Flag $ packageId $ pkg_descr, argOutputDir = Dir $ "doc" "html" display (packageName pkg_descr), argPrologue = Flag $ if null desc then synopsis pkg_descr else desc, argTitle = Flag $ showPkg ++ subtitle } - where + where desc = PD.description pkg_descr showPkg = display (packageId pkg_descr) subtitle | null (synopsis pkg_descr) = "" @@ -310,11 +312,11 @@ -- haddock to write them elsewhere. ++ [ "-odir", tmp, "-hidir", tmp , "-stubdir", tmp ], - argTargets = inFiles + argTargets = inFiles } - where + where bi = libBuildInfo lib - + fromExecutable :: FilePath -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO HaddockArgs @@ -330,9 +332,9 @@ , "-stubdir", tmp ], argOutputDir = Dir (exeName exe), argTitle = Flag (exeName exe), - argTargets = inFiles + argTargets = inFiles } - where + where bi = buildInfo exe getInterfaces :: Verbosity @@ -343,17 +345,17 @@ let htmlTemplate = fmap toPathTemplate $ location (packageFlags, warnings) <- haddockPackageFlags lbi htmlTemplate maybe (return ()) (warn verbosity) warnings - return $ mempty { + return $ mempty { argInterfaces = packageFlags } -getGhcLibDir :: Verbosity -> LocalBuildInfo +getGhcLibDir :: Verbosity -> LocalBuildInfo -> Bool -- ^ are we using haddock-2.x ? -> IO HaddockArgs -getGhcLibDir verbosity lbi isVersion2 - | isVersion2 = - do l <- ghcLibDir verbosity lbi - return $ mempty { argGhcLibDir = Flag l } +getGhcLibDir verbosity lbi isVersion2 + | isVersion2 = + do l <- ghcLibDir verbosity lbi + return $ mempty { argGhcLibDir = Flag l } | otherwise = return mempty @@ -364,7 +366,7 @@ runHaddock verbosity confHaddock args = do let haddockVersion = fromMaybe (error "unable to determine haddock version") (programVersion confHaddock) - renderArgs verbosity haddockVersion args $ \(flags,result)-> do + renderArgs verbosity haddockVersion args $ \(flags,result)-> do rawSystemProgram verbosity confHaddock flags @@ -376,15 +378,15 @@ -> HaddockArgs -> (([[Char]], FilePath) -> IO a) -> IO a -renderArgs verbosity version args k = do +renderArgs verbosity version args k = do createDirectoryIfMissingVerbose verbosity True outputDir withTempFile outputDir "haddock-prolog.txt" $ \prologFileName h -> do do hPutStrLn h $ fromFlag $ argPrologue args - hClose h + hClose h let pflag = (:[]).("--prologue="++) $ prologFileName k $ (pflag ++ renderPureArgs version args, result) - where + where isVersion2 = version >= Version [2,0] [] outputDir = (unDir $ argOutputDir args) result = intercalate ", " @@ -398,15 +400,15 @@ | otherwise = display pkgid pkgid = arg argPackageName arg f = fromFlag $ f args - + renderPureArgs :: Version -> HaddockArgs -> [[Char]] -renderPureArgs version args = concat - [ +renderPureArgs version args = concat + [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) f) - . fromFlag . argInterfaceFile $ args, - (\pkgName -> if isVersion2 + . fromFlag . argInterfaceFile $ args, + (\pkgName -> if isVersion2 then ["--optghc=-package-name", "--optghc=" ++ pkgName] - else ["--package=" ++ pkgName]) . display . fromFlag . argPackageName $ args, + else ["--package=" ++ pkgName]) . display . fromFlag . argPackageName $ args, (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) . argHideModules $ args, bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args, maybe [] (\(m,e) -> ["--source-module=" ++ m @@ -416,14 +418,14 @@ map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") . fromFlag . argOutput $ args, renderInterfaces . argInterfaces $ args, (:[]).("--odir="++) . unDir . argOutputDir $ args, - (:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args)) + (:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args)) . fromFlag . argTitle $ args, bool id (const []) isVersion2 . map ("--optghc=" ++) . argGhcFlags $ args, maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and Nothing? argTargets $ args - ] - where - renderInterfaces = map (\(i,mh) -> "--read-interface=" ++ maybe "" (++",") mh ++ i) + ] + where + renderInterfaces = map (\(i,mh) -> "--read-interface=" ++ maybe "" (++",") mh ++ i) bool a b c = if c then a else b isVersion2 = version >= Version [2,0] [] isVersion2_5 = version >= Version [2,5] [] @@ -481,17 +483,18 @@ hscolour pkg_descr lbi suffixes flags = do -- we preprocess even if hscolour won't be found on the machine -- will this upset someone? - initialBuildSteps distPref pkg_descr lbi verbosity suffixes - hscolour' pkg_descr lbi flags + initialBuildSteps distPref pkg_descr lbi verbosity + hscolour' pkg_descr lbi suffixes flags where verbosity = fromFlag (hscolourVerbosity flags) distPref = fromFlag $ hscolourDistPref flags hscolour' :: PackageDescription - -> LocalBuildInfo - -> HscolourFlags - -> IO () -hscolour' pkg_descr lbi flags = do + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour' pkg_descr lbi suffixes flags = do let distPref = fromFlag $ hscolourDistPref flags (hscolourProg, _, _) <- requireProgramVersion @@ -501,25 +504,26 @@ setupMessage verbosity "Running hscolour for" (packageId pkg_descr) createDirectoryIfMissingVerbose verbosity True $ hscolourPref distPref pkg_descr - withLib pkg_descr $ \lib -> do - - let outputDir = hscolourPref distPref pkg_descr "src" - runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib - - when (fromFlag (hscolourExecutables flags)) $ - withExe pkg_descr $ \exe -> do - let outputDir = hscolourPref distPref pkg_descr exeName exe "src" - runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe - - where + let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes + withComponentsLBI pkg_descr lbi $ \comp _ -> do + pre comp + case comp of + CLib lib -> do + let outputDir = hscolourPref distPref pkg_descr "src" + runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib + CExe exe | fromFlag (hscolourExecutables flags) -> do + let outputDir = hscolourPref distPref pkg_descr exeName exe "src" + runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe + _ -> return () + where stylesheet = flagToMaybe (hscolourCSS flags) - + verbosity = fromFlag (hscolourVerbosity flags) - runHsColour prog outputDir moduleFiles = do + runHsColour prog outputDir moduleFiles = do createDirectoryIfMissingVerbose verbosity True outputDir - case stylesheet of -- copy the CSS file + case stylesheet of -- copy the CSS file Nothing | programVersion prog >= Just (Version [1,9] []) -> rawSystemProgram verbosity prog ["-print-css", "-o" ++ outputDir "hscolour.css"] @@ -533,12 +537,12 @@ outFile m = outputDir intercalate "-" (ModuleName.components m) <.> "html" haddockToHscolour :: HaddockFlags -> HscolourFlags -haddockToHscolour flags = - HscolourFlags { +haddockToHscolour flags = + HscolourFlags { hscolourCSS = haddockHscolourCss flags, hscolourExecutables = haddockExecutables flags, hscolourVerbosity = haddockVerbosity flags, - hscolourDistPref = haddockDistPref flags + hscolourDistPref = haddockDistPref flags } ---------------------------------------------------------------------------------------------- -- TODO these should be moved elsewhere. @@ -567,9 +571,9 @@ getSourceFiles :: [FilePath] -> [ModuleName.ModuleName] -> IO [(ModuleName.ModuleName, FilePath)] -getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $ +getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $ findFileWithExtension ["hs", "lhs"] dirs (ModuleName.toFilePath m) - >>= maybe (notFound m) (return . normalise) + >>= maybe (notFound m) (return . normalise) where notFound module_ = die $ "can't find source for module " ++ display module_ @@ -585,8 +589,8 @@ -- boilerplate monoid instance. instance Monoid HaddockArgs where mempty = HaddockArgs { - argInterfaceFile = mempty, - argPackageName = mempty, + argInterfaceFile = mempty, + argPackageName = mempty, argHideModules = mempty, argIgnoreExports = mempty, argLinkSource = mempty, @@ -602,8 +606,8 @@ argTargets = mempty } mappend a b = HaddockArgs { - argInterfaceFile = mult argInterfaceFile, - argPackageName = mult argPackageName, + argInterfaceFile = mult argInterfaceFile, + argPackageName = mult argPackageName, argHideModules = mult argHideModules, argIgnoreExports = mult argIgnoreExports, argLinkSource = mult argLinkSource, diff --git a/Distribution/Simple/Hpc.hs b/Distribution/Simple/Hpc.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Hpc.hs @@ -0,0 +1,185 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Hpc +-- Copyright : Thomas Tuegel 2011 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides functions for locating various HPC-related paths and +-- a function for adding the necessary options to a PackageDescription to +-- build test suites with HPC enabled. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Hpc + ( hpcDir + , enableCoverage + , tixDir + , tixFilePath + , doHpcMarkup + , findTixFiles + ) where + +import Control.Exception ( bracket ) +import Control.Monad ( unless, when ) +import Distribution.Compiler ( CompilerFlavor(..) ) +import Distribution.ModuleName ( main ) +import Distribution.PackageDescription + ( BuildInfo(..) + , Library(..) + , PackageDescription(..) + , TestSuite(..) + , testModules + ) +import Distribution.Simple.Utils ( die, notice ) +import Distribution.Text +import Distribution.Verbosity ( Verbosity() ) +import System.Directory ( doesFileExist, getDirectoryContents, removeFile ) +import System.Exit ( ExitCode(..) ) +import System.FilePath +import System.IO ( hClose, IOMode(..), openFile, openTempFile ) +import System.Process ( runProcess, waitForProcess ) + +-- ------------------------------------------------------------------------- +-- Haskell Program Coverage + +-- | Conditionally enable Haskell Program Coverage by adding the necessary +-- GHC options to a PackageDescription. +-- +-- TODO: do this differently in the build stage by constructing local build +-- info, not by modifying the original PackageDescription. +-- +enableCoverage :: Bool -- ^ Enable coverage? + -> String -- ^ \"dist/\" prefix + -> PackageDescription + -> PackageDescription +enableCoverage False _ x = x +enableCoverage True distPref p = + p { library = fmap enableLibCoverage (library p) + , testSuites = map enableTestCoverage (testSuites p) + } + where + enableBICoverage name oldBI = + let oldOptions = options oldBI + oldGHCOpts = lookup GHC oldOptions + newGHCOpts = case oldGHCOpts of + Just xs -> (GHC, hpcOpts ++ xs) + _ -> (GHC, hpcOpts) + newOptions = (:) newGHCOpts $ filter ((== GHC) . fst) oldOptions + hpcOpts = ["-fhpc", "-hpcdir", hpcDir distPref name] + in oldBI { options = newOptions } + enableLibCoverage l = + l { libBuildInfo = enableBICoverage (display $ package p) + (libBuildInfo l) + } + enableTestCoverage t = + t { testBuildInfo = enableBICoverage (testName t) (testBuildInfo t) } + +hpcDir :: FilePath -- ^ \"dist/\" prefix + -> FilePath -- ^ Component subdirectory name + -> FilePath -- ^ Directory containing component's HPC .mix files +hpcDir distPref name = distPref "hpc" name + +tixDir :: FilePath -- ^ \"dist/\" prefix + -> TestSuite -- ^ Test suite + -> FilePath -- ^ Directory containing test suite's .tix files +tixDir distPref suite = distPref "test" testName suite + +-- | Path to the .tix file containing a test suite's sum statistics. +tixFilePath :: FilePath -- ^ \"dist/\" prefix + -> TestSuite -- ^ Test suite + -> FilePath -- Path to test suite's .tix file +tixFilePath distPref suite = tixDir distPref suite testName suite <.> "tix" + +-- | Returns a list of all the .tix files in a test suite's .tix file +-- directory. Returned paths are the complete relative path to each file. +findTixFiles :: FilePath -- ^ \"dist/\" prefix + -> TestSuite -- ^ Test suite + -> IO [FilePath] -- ^ All .tix files belonging to test suite +findTixFiles distPref suite = do + files <- getDirectoryContents $ tixDir distPref suite + let tixFiles = flip filter files $ \x -> takeExtension x == ".tix" + return $ map (tixDir distPref suite ) tixFiles + +-- | Generate the HTML markup for a test suite. +doHpcMarkup :: Verbosity + -> FilePath -- ^ \"dist/\" prefix + -> String -- ^ Library name + -> TestSuite + -> IO () +doHpcMarkup verbosity distPref libName suite = do + tixFiles <- findTixFiles distPref suite + when (not $ null tixFiles) $ do + let hpcOptions = map (\x -> "--exclude=" ++ display x) excluded + unionOptions = [ "sum" + , "--union" + , "--output=" ++ tixFilePath distPref suite + ] + ++ hpcOptions ++ tixFiles + markupOptions = [ "markup" + , tixFilePath distPref suite + , "--hpcdir=" ++ hpcDir distPref libName + , "--destdir=" ++ tixDir distPref suite + ] + ++ hpcOptions + excluded = testModules suite ++ [ main ] + --TODO: use standard process utilities from D.S.Utils + runHpc opts h = runProcess "hpc" opts Nothing Nothing Nothing + (Just h) (Just h) + bracket (openHpcTemp $ tixDir distPref suite) deleteIfExists + $ \hpcOut -> do + hUnion <- openFile hpcOut AppendMode + procUnion <- runHpc unionOptions hUnion + exitUnion <- waitForProcess procUnion + success <- case exitUnion of + ExitSuccess -> do + hMarkup <- openFile hpcOut AppendMode + procMarkup <- runHpc markupOptions hMarkup + exitMarkup <- waitForProcess procMarkup + case exitMarkup of + ExitSuccess -> return True + _ -> return False + _ -> return False + unless success $ do + errs <- readFile hpcOut + die $ "HPC failed:\n" ++ errs + when success $ notice verbosity + $ "Test coverage report written to " + ++ tixDir distPref suite "hpc_index" + <.> "html" + return () + where openHpcTemp dir = do + (f, h) <- openTempFile dir $ "cabal-test-hpc-" <.> "log" + hClose h >> return f + deleteIfExists path = do + exists <- doesFileExist path + when exists $ removeFile path diff --git a/Distribution/Simple/Hugs.hs b/Distribution/Simple/Hugs.hs --- a/Distribution/Simple/Hugs.hs +++ b/Distribution/Simple/Hugs.hs @@ -89,13 +89,14 @@ import Distribution.Simple.Setup ( CopyDest(..) ) import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, installOrdinaryFiles + ( createDirectoryIfMissingVerbose + , installOrdinaryFiles, setFileExecutable , withUTF8FileContents, writeFileAtomic, writeUTF8File , copyFileVerbose, findFile, findFileWithExtension, findModuleFiles , rawSystemStdInOut , die, info, notice ) import Language.Haskell.Extension - ( Language(Haskell98), Extension(..) ) + ( Language(Haskell98), Extension(..), KnownExtension(..) ) import System.FilePath ( (), takeExtension, (<.>), searchPathSeparator, normalise, takeDirectory ) import Distribution.System @@ -116,8 +117,6 @@ , removeDirectoryRecursive, getHomeDirectory ) import System.Exit ( ExitCode(ExitSuccess) ) -import Distribution.Compat.CopyFile - ( setFileExecutable ) import Distribution.Compat.Exception -- ----------------------------------------------------------------------------- @@ -176,26 +175,31 @@ -- | The flags for the supported extensions hugsLanguageExtensions :: [(Extension, Flag)] hugsLanguageExtensions = - [(OverlappingInstances , "+o") - ,(IncoherentInstances , "+oO") - ,(HereDocuments , "+H") - ,(TypeSynonymInstances , "-98") - ,(RecursiveDo , "-98") - ,(ParallelListComp , "-98") - ,(MultiParamTypeClasses , "-98") - ,(FunctionalDependencies , "-98") - ,(Rank2Types , "-98") - ,(PolymorphicComponents , "-98") - ,(ExistentialQuantification , "-98") - ,(ScopedTypeVariables , "-98") - ,(ImplicitParams , "-98") - ,(ExtensibleRecords , "-98") - ,(RestrictedTypeSynonyms , "-98") - ,(FlexibleContexts , "-98") - ,(FlexibleInstances , "-98") - ,(ForeignFunctionInterface , "") - ,(EmptyDataDecls , "") - ,(CPP , "") + let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), + (DisableExtension f, disable)] + alwaysOn = ("", ""{- wrong -}) + ext98 = ("-98", ""{- wrong -}) + in concatMap doFlag + [(OverlappingInstances , ("+o", "-o")) + ,(IncoherentInstances , ("+oO", "-O")) + ,(HereDocuments , ("+H", "-H")) + ,(TypeSynonymInstances , ext98) + ,(RecursiveDo , ext98) + ,(ParallelListComp , ext98) + ,(MultiParamTypeClasses , ext98) + ,(FunctionalDependencies , ext98) + ,(Rank2Types , ext98) + ,(PolymorphicComponents , ext98) + ,(ExistentialQuantification , ext98) + ,(ScopedTypeVariables , ext98) + ,(ImplicitParams , ext98) + ,(ExtensibleRecords , ext98) + ,(RestrictedTypeSynonyms , ext98) + ,(FlexibleContexts , ext98) + ,(FlexibleInstances , ext98) + ,(ForeignFunctionInterface , alwaysOn) + ,(EmptyDataDecls , alwaysOn) + ,(CPP , alwaysOn) ] getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration @@ -337,7 +341,7 @@ srcMainFile <- findFile (hsSourceDirs bi) mainPath let exeDir = destDir exeName exe let destMainFile = exeDir hugsMainFilename exe - copyModule verbosity (CPP `elem` allExtensions bi) bi lbi srcMainFile destMainFile + copyModule verbosity (EnableExtension CPP `elem` allExtensions bi) bi lbi srcMainFile destMainFile let destPathsFile = exeDir paths_modulename copyFileVerbose verbosity (autogenModulesDir lbi paths_modulename) destPathsFile @@ -359,7 +363,7 @@ --TODO: should not be using mLibSrcDirs at all compileBuildInfo verbosity destDir mLibSrcDirs mods bi lbi = do -- Pass 1: copy or cpp files from build directory to scratch directory - let useCpp = CPP `elem` allExtensions bi + let useCpp = EnableExtension CPP `elem` allExtensions bi let srcDir = buildDir lbi srcDirs = nub $ srcDir : hsSourceDirs bi ++ mLibSrcDirs info verbosity $ "Source directories: " ++ show srcDirs @@ -387,7 +391,7 @@ createDirectoryIfMissingVerbose verbosity True (takeDirectory destFile) (exts, opts, _) <- getOptionsFromSource srcFile let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ] - if cppAll || CPP `elem` exts || "-cpp" `elem` ghcOpts then do + if cppAll || EnableExtension CPP `elem` exts || "-cpp" `elem` ghcOpts then do runSimplePreProcessor (ppCpp bi lbi) srcFile destFile verbosity return () else @@ -578,6 +582,8 @@ let hugsOptions = hcOptions Hugs (buildInfo exe) ++ languageToFlags (compiler lbi) (defaultLanguage bi) ++ extensionsToFlags (compiler lbi) (allExtensions bi) + --TODO: also need to consider options, extensions etc of deps + -- see ticket #43 let baseExeFile = progprefix ++ (exeName exe) ++ progsuffix let exeFile = case buildOS of Windows -> binDir baseExeFile <.> ".bat" diff --git a/Distribution/Simple/InstallDirs.hs b/Distribution/Simple/InstallDirs.hs --- a/Distribution/Simple/InstallDirs.hs +++ b/Distribution/Simple/InstallDirs.hs @@ -560,13 +560,13 @@ # if __HUGS__ return Nothing # else - allocaBytes long_path_size $ \pPath -> do + allocaArray long_path_size $ \pPath -> do r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath if (r /= 0) then return Nothing - else do s <- peekCString pPath; return (Just s) + else do s <- peekCWString pPath; return (Just s) where - long_path_size = 1024 + long_path_size = 1024 -- MAX_PATH is 260, this should be plenty # endif csidl_PROGRAM_FILES :: CInt @@ -574,12 +574,12 @@ -- csidl_PROGRAM_FILES_COMMON :: CInt -- csidl_PROGRAM_FILES_COMMON = 0x002b -foreign import stdcall unsafe "shlobj.h SHGetFolderPathA" +foreign import stdcall unsafe "shlobj.h SHGetFolderPathW" c_SHGetFolderPath :: Ptr () -> CInt -> Ptr () -> CInt - -> CString + -> CWString -> IO CInt #endif diff --git a/Distribution/Simple/JHC.hs b/Distribution/Simple/JHC.hs --- a/Distribution/Simple/JHC.hs +++ b/Distribution/Simple/JHC.hs @@ -64,7 +64,7 @@ ( CompilerFlavor(..), CompilerId(..), Compiler(..) , PackageDBStack, Flag, languageToFlags, extensionsToFlags ) import Language.Haskell.Extension - ( Language(Haskell98), Extension(..)) + ( Language(Haskell98), Extension(..), KnownExtension(..)) import Distribution.Simple.Program ( ConfiguredProgram(..), jhcProgram, ProgramConfiguration , userMaybeSpecifyPath, requireProgramVersion, lookupProgram @@ -115,10 +115,14 @@ -- | The flags for the supported extensions jhcLanguageExtensions :: [(Extension, Flag)] jhcLanguageExtensions = - [(TypeSynonymInstances , "") - ,(ForeignFunctionInterface , "") - ,(NoImplicitPrelude , "--noprelude") - ,(CPP , "-fcpp") + [(EnableExtension TypeSynonymInstances , "") + ,(DisableExtension TypeSynonymInstances , "") + ,(EnableExtension ForeignFunctionInterface , "") + ,(DisableExtension ForeignFunctionInterface , "") + ,(EnableExtension ImplicitPrelude , "") -- Wrong + ,(DisableExtension ImplicitPrelude , "--noprelude") + ,(EnableExtension CPP , "-fcpp") + ,(DisableExtension CPP , "-fno-cpp") ] getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration diff --git a/Distribution/Simple/LHC.hs b/Distribution/Simple/LHC.hs --- a/Distribution/Simple/LHC.hs +++ b/Distribution/Simple/LHC.hs @@ -110,7 +110,7 @@ import Distribution.Text ( display, simpleParse ) import Language.Haskell.Extension - ( Language(Haskell98), Extension(..) ) + ( Language(Haskell98), Extension(..), KnownExtension(..) ) import Control.Monad ( unless, when ) import Data.List @@ -336,7 +336,7 @@ (compiler lbi) (withProfLib lbi) (libBuildInfo lib) let libTargetDir = pref - forceVanillaLib = TemplateHaskell `elem` allExtensions libBi + forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi -- TH always needs vanilla libs, even when building for profiling createDirectoryIfMissingVerbose verbosity True libTargetDir @@ -544,7 +544,7 @@ -- with profiling. This is because the code that TH needs to -- run at compile time needs to be the vanilla ABI so it can -- be loaded up and run by the compiler. - when (withProfExe lbi && TemplateHaskell `elem` allExtensions exeBi) + when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi) (runGhcProg $ lhcWrap (binArgs False False)) runGhcProg (binArgs True (withProfExe lbi)) diff --git a/Distribution/Simple/LocalBuildInfo.hs b/Distribution/Simple/LocalBuildInfo.hs --- a/Distribution/Simple/LocalBuildInfo.hs +++ b/Distribution/Simple/LocalBuildInfo.hs @@ -48,10 +48,18 @@ LocalBuildInfo(..), externalPackageDeps, inplacePackageId, + + -- * Buildable package components + Component(..), + foldComponent, + allComponentsBy, + ComponentName(..), + ComponentLocalBuildInfo(..), + withComponentsLBI, withLibLBI, withExeLBI, withTestLBI, - ComponentLocalBuildInfo(..), + -- * Installation directories module Distribution.Simple.InstallDirs, absoluteInstallDirs, prefixRelativeInstallDirs, @@ -65,8 +73,9 @@ import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.Program (ProgramConfiguration) import Distribution.PackageDescription - ( PackageDescription(..), withLib, Library, withExe - , Executable(exeName), withTest, TestSuite(..) ) + ( PackageDescription(..), withLib, Library(libBuildInfo), withExe + , Executable(exeName, buildInfo), withTest, TestSuite(..) + , BuildInfo(buildable) ) import Distribution.Package ( PackageId, Package(..), InstalledPackageId(..) ) import Distribution.Simple.Compiler @@ -80,7 +89,7 @@ import Distribution.Text ( display ) -import Data.List (nub) +import Data.List (nub, find) -- | Data cached after configuration step. See also -- 'Distribution.Simple.Setup.ConfigFlags'. @@ -104,6 +113,9 @@ -- ^ Where to put the result of the Hugs build. libraryConfig :: Maybe ComponentLocalBuildInfo, executableConfigs :: [(String, ComponentLocalBuildInfo)], + compBuildOrder :: [ComponentName], + -- ^ All the components to build, ordered by topological sort + -- over the intrapackage dependency graph testSuiteConfigs :: [(String, ComponentLocalBuildInfo)], installedPkgs :: PackageIndex, -- ^ All the info about the installed packages that the @@ -118,6 +130,7 @@ withVanillaLib:: Bool, -- ^Whether to build normal libs. withProfLib :: Bool, -- ^Whether to build profiling versions of libs. withSharedLib :: Bool, -- ^Whether to build shared versions of libs. + withDynExe :: Bool, -- ^Whether to link executables dynamically withProfExe :: Bool, -- ^Whether to build executables for profiling. withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. @@ -127,15 +140,6 @@ progSuffix :: PathTemplate -- ^Suffix to be appended to installed executables } deriving (Read, Show) -data ComponentLocalBuildInfo = ComponentLocalBuildInfo { - -- | Resolved internal and external package dependencies for this component. - -- The 'BuildInfo' specifies a set of build dependencies that must be - -- satisfied in terms of version ranges. This field fixes those dependencies - -- to the specific versions available on this machine for this compiler. - componentPackageDeps :: [(InstalledPackageId, PackageId)] - } - deriving (Read, Show) - -- | External package dependencies for the package as a whole, the union of the -- individual 'targetPackageDeps'. externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)] @@ -150,6 +154,51 @@ inplacePackageId :: PackageId -> InstalledPackageId inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace") +-- ----------------------------------------------------------------------------- +-- Buildable components + +data Component = CLib Library + | CExe Executable + | CTest TestSuite + deriving (Show, Eq, Read) + +data ComponentName = CLibName -- currently only a single lib + | CExeName String + | CTestName String + deriving (Show, Eq, Read) + +data ComponentLocalBuildInfo = ComponentLocalBuildInfo { + -- | Resolved internal and external package dependencies for this component. + -- The 'BuildInfo' specifies a set of build dependencies that must be + -- satisfied in terms of version ranges. This field fixes those dependencies + -- to the specific versions available on this machine for this compiler. + componentPackageDeps :: [(InstalledPackageId, PackageId)] + } + deriving (Read, Show) + +foldComponent :: (Library -> a) + -> (Executable -> a) + -> (TestSuite -> a) + -> Component + -> a +foldComponent f _ _ (CLib lib) = f lib +foldComponent _ f _ (CExe exe) = f exe +foldComponent _ _ f (CTest tst) = f tst + +-- | Obtains all components (libs, exes, or test suites), transformed by the +-- given function. Useful for gathering dependencies with component context. +allComponentsBy :: PackageDescription + -> (Component -> a) + -> [a] +allComponentsBy pkg_descr f = + [ f (CLib lib) | Just lib <- [library pkg_descr] + , buildable (libBuildInfo lib) ] + ++ [ f (CExe exe) | exe <- executables pkg_descr + , buildable (buildInfo exe) ] + ++ [ f (CTest tst) | tst <- testSuites pkg_descr + , buildable (testBuildInfo tst) + , testEnabled tst ] + -- |If the package description has a library section, call the given -- function with the library build info as argument. Extended version of -- 'withLib' that also gives corresponding build info. @@ -158,8 +207,7 @@ withLibLBI pkg_descr lbi f = withLib pkg_descr $ \lib -> case libraryConfig lbi of Just clbi -> f lib clbi - Nothing -> die $ "internal error: the package contains a library " - ++ "but there is no corresponding configuration data" + Nothing -> die missingLibConf -- | Perform the action on each buildable 'Executable' in the package -- description. Extended version of 'withExe' that also gives corresponding @@ -169,19 +217,63 @@ withExeLBI pkg_descr lbi f = withExe pkg_descr $ \exe -> case lookup (exeName exe) (executableConfigs lbi) of Just clbi -> f exe clbi - Nothing -> die $ "internal error: the package contains an executable " - ++ exeName exe ++ " but there is no corresponding " - ++ "configuration data" + Nothing -> die (missingExeConf (exeName exe)) withTestLBI :: PackageDescription -> LocalBuildInfo -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO () -withTestLBI pkg_descr lbi f = - let wrapper test = case lookup (testName test) (testSuiteConfigs lbi) of - Just clbi -> f test clbi - Nothing -> die $ "internal error: the package contains a test suite " - ++ testName test ++ " but there is no corresponding " - ++ "configuration data" - in withTest pkg_descr wrapper +withTestLBI pkg_descr lbi f = withTest pkg_descr $ \test -> + case lookup (testName test) (testSuiteConfigs lbi) of + Just clbi -> f test clbi + Nothing -> die (missingTestConf (testName test)) + +-- | Perform the action on each buildable 'Library' or 'Executable' (Component) +-- in the PackageDescription, subject to the build order specified by the +-- 'compBuildOrder' field of the given 'LocalBuildInfo' +withComponentsLBI :: PackageDescription -> LocalBuildInfo + -> (Component -> ComponentLocalBuildInfo -> IO ()) + -> IO () +withComponentsLBI pkg_descr lbi f = mapM_ compF (compBuildOrder lbi) + where + compF CLibName = + case library pkg_descr of + Nothing -> die missinglib + Just lib -> case libraryConfig lbi of + Nothing -> die missingLibConf + Just clbi -> f (CLib lib) clbi + where + missinglib = "internal error: component list includes a library " + ++ "but the package description contains no library" + + compF (CExeName name) = + case find (\exe -> exeName exe == name) (executables pkg_descr) of + Nothing -> die missingexe + Just exe -> case lookup name (executableConfigs lbi) of + Nothing -> die (missingExeConf name) + Just clbi -> f (CExe exe) clbi + where + missingexe = "internal error: component list includes an executable " + ++ name ++ " but the package contains no such executable." + + compF (CTestName name) = + case find (\tst -> testName tst == name) (testSuites pkg_descr) of + Nothing -> die missingtest + Just tst -> case lookup name (testSuiteConfigs lbi) of + Nothing -> die (missingTestConf name) + Just clbi -> f (CTest tst) clbi + where + missingtest = "internal error: component list includes a test suite " + ++ name ++ " but the package contains no such test suite." + +missingLibConf :: String +missingExeConf, missingTestConf :: String -> String + +missingLibConf = "internal error: the package contains a library " + ++ "but there is no corresponding configuration data" +missingExeConf name = "internal error: the package contains an executable " + ++ name ++ " but there is no corresponding configuration data" +missingTestConf name = "internal error: the package contains a test suite " + ++ name ++ " but there is no corresponding configuration data" + -- ----------------------------------------------------------------------------- -- Wrappers for a couple functions from InstallDirs diff --git a/Distribution/Simple/NHC.hs b/Distribution/Simple/NHC.hs --- a/Distribution/Simple/NHC.hs +++ b/Distribution/Simple/NHC.hs @@ -74,7 +74,7 @@ import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex) import Language.Haskell.Extension - ( Language(Haskell98), Extension(..) ) + ( Language(Haskell98), Extension(..), KnownExtension(..) ) import Distribution.Simple.Program ( ProgramConfiguration, userMaybeSpecifyPath, programPath , requireProgram, requireProgramVersion, lookupProgram @@ -132,7 +132,7 @@ let comp = Compiler { compilerId = CompilerId NHC nhcVersion, compilerLanguages = nhcLanguages, - compilerExtensions = nhcLanguageExtensions + compilerExtensions = nhcLanguageExtensions } return (comp, conf'''') @@ -142,14 +142,27 @@ -- | The flags for the supported extensions nhcLanguageExtensions :: [(Extension, Flag)] nhcLanguageExtensions = - -- NHC doesn't enforce the monomorphism restriction at all. -- TODO: pattern guards in 1.20 - [(NoMonomorphismRestriction, "") - ,(ForeignFunctionInterface, "") - ,(ExistentialQuantification, "") - ,(EmptyDataDecls, "") - ,(NamedFieldPuns, "-puns") - ,(CPP, "-cpp") + -- NHC doesn't enforce the monomorphism restriction at all. + -- Technically it therefore doesn't support MonomorphismRestriction, + -- but that would mean it doesn't support Haskell98, so we pretend + -- that it does. + [(EnableExtension MonomorphismRestriction, "") + ,(DisableExtension MonomorphismRestriction, "") + -- Similarly, I assume the FFI is always on + ,(EnableExtension ForeignFunctionInterface, "") + ,(DisableExtension ForeignFunctionInterface, "") + -- Similarly, I assume existential quantification is always on + ,(EnableExtension ExistentialQuantification, "") + ,(DisableExtension ExistentialQuantification, "") + -- Similarly, I assume empty data decls is always on + ,(EnableExtension EmptyDataDecls, "") + ,(DisableExtension EmptyDataDecls, "") + ,(EnableExtension NamedFieldPuns, "-puns") + ,(DisableExtension NamedFieldPuns, "-nopuns") + -- CPP can't actually be turned off, but we pretend that it can + ,(EnableExtension CPP, "-cpp") + ,(DisableExtension CPP, "") ] getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration diff --git a/Distribution/Simple/PreProcess.hs b/Distribution/Simple/PreProcess.hs --- a/Distribution/Simple/PreProcess.hs +++ b/Distribution/Simple/PreProcess.hs @@ -47,7 +47,7 @@ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -module Distribution.Simple.PreProcess (preprocessSources, knownSuffixHandlers, +module Distribution.Simple.PreProcess (preprocessComponent, knownSuffixHandlers, ppSuffixes, PPSuffixHandler, PreProcessor(..), mkSimplePreProcessor, runSimplePreProcessor, ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, @@ -56,21 +56,24 @@ where +import Control.Monad import Distribution.Simple.PreProcess.Unlit (unlit) import Distribution.Package ( Package(..), PackageName(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), Executable(..), withExe - , Library(..), withLib, libModules - , TestSuite(..), withTest, testModules + ( PackageDescription(..), BuildInfo(..) + , Executable(..) + , Library(..), libModules + , TestSuite(..), testModules , TestSuiteInterface(..) ) import qualified Distribution.InstalledPackageInfo as Installed ( InstalledPackageInfo_(..) ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.Compiler ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion ) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), Component(..) ) import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File @@ -90,7 +93,6 @@ ( Version(..), anyVersion, orLaterVersion ) import Distribution.Verbosity -import Control.Monad (when, unless) import Data.Maybe (fromMaybe) import Data.List (nub) import System.Directory (getModificationTime, doesFileExist) @@ -171,66 +173,60 @@ type PPSuffixHandler = (String, BuildInfo -> LocalBuildInfo -> PreProcessor) --- |Apply preprocessors to the sources from 'hsSourceDirs', to obtain --- a Haskell source file for each module. -preprocessSources :: PackageDescription - -> LocalBuildInfo - -> Bool -- ^ Build for SDist - -> Verbosity -- ^ verbosity - -> [PPSuffixHandler] -- ^ preprocessors to try - -> IO () - -preprocessSources pkg_descr lbi forSDist verbosity handlers = do - withLib pkg_descr $ \ lib -> do - setupMessage verbosity "Preprocessing library" (packageId pkg_descr) - let bi = libBuildInfo lib - let biHandlers = localHandlers bi - sequence_ [ preprocessFile (hsSourceDirs bi ++ [autogenModulesDir lbi]) (buildDir lbi) forSDist - (ModuleName.toFilePath modu) verbosity - builtinSuffixes biHandlers - | modu <- libModules lib ] - unless (null (executables pkg_descr)) $ - setupMessage verbosity "Preprocessing executables for" (packageId pkg_descr) - withExe pkg_descr $ \ theExe -> do - let bi = buildInfo theExe - let biHandlers = localHandlers bi - let exeDir = buildDir lbi exeName theExe exeName theExe ++ "-tmp" - sequence_ [ preprocessFile (hsSourceDirs bi ++ [autogenModulesDir lbi]) exeDir forSDist - (ModuleName.toFilePath modu) verbosity - builtinSuffixes biHandlers - | modu <- otherModules bi] - preprocessFile (hsSourceDirs bi) exeDir forSDist - (dropExtensions (modulePath theExe)) - verbosity builtinSuffixes biHandlers - unless (null (testSuites pkg_descr)) $ - setupMessage verbosity "Preprocessing test suites for" (packageId pkg_descr) - withTest pkg_descr $ \test -> case testInterface test of - TestSuiteExeV10 _ f -> - preProcessTest test f $ buildDir lbi testName test - testName test ++ "-tmp" - TestSuiteLibV09 _ _ -> do - let testDir = buildDir lbi stubName test - stubName test ++ "-tmp" - writeSimpleTestStub test testDir - preProcessTest test (stubFilePath test) testDir - TestSuiteUnsupported tt -> die $ "No support for preprocessing test " - ++ "suite type " ++ display tt - where hc = compilerFlavor (compiler lbi) - builtinSuffixes - | hc == NHC = ["hs", "lhs", "gc"] - | otherwise = ["hs", "lhs"] - localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] - preProcessTest test exePath testDir = do - let bi = testBuildInfo test - biHandlers = localHandlers bi - sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ] - sequence_ [ preprocessFile sourceDirs (buildDir lbi) forSDist - (ModuleName.toFilePath modu) verbosity builtinSuffixes - biHandlers - | modu <- testModules test ] - preprocessFile (testDir : (hsSourceDirs bi)) testDir forSDist - (dropExtensions $ exePath) verbosity - builtinSuffixes biHandlers +-- | Apply preprocessors to the sources from 'hsSourceDirs' for a given +-- component (lib, exe, or test suite). +preprocessComponent :: PackageDescription + -> Component + -> LocalBuildInfo + -> Bool + -> Verbosity + -> [PPSuffixHandler] + -> IO () +preprocessComponent pd comp lbi isSrcDist verbosity handlers = case comp of + (CLib lib@Library{ libBuildInfo = bi }) -> do + let dirs = hsSourceDirs bi ++ [autogenModulesDir lbi] + setupMessage verbosity "Preprocessing library" (packageId pd) + forM_ (map ModuleName.toFilePath $ libModules lib) $ + pre dirs (buildDir lbi) (localHandlers bi) + (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do + let exeDir = buildDir lbi nm nm ++ "-tmp" + dirs = hsSourceDirs bi ++ [autogenModulesDir lbi] + setupMessage verbosity ("Preprocessing executable '" ++ nm ++ "' for") (packageId pd) + forM_ (map ModuleName.toFilePath $ otherModules bi) $ + pre dirs exeDir (localHandlers bi) + pre (hsSourceDirs bi) exeDir (localHandlers bi) $ + dropExtensions (modulePath exe) + CTest test@TestSuite{ testName = nm } -> do + setupMessage verbosity ("Preprocessing test suite '" ++ nm ++ "' for") (packageId pd) + case testInterface test of + TestSuiteExeV10 _ f -> + preProcessTest test f $ buildDir lbi testName test + testName test ++ "-tmp" + TestSuiteLibV09 _ _ -> do + let testDir = buildDir lbi stubName test + stubName test ++ "-tmp" + writeSimpleTestStub test testDir + preProcessTest test (stubFilePath test) testDir + TestSuiteUnsupported tt -> die $ "No support for preprocessing test " + ++ "suite type " ++ display tt + where + builtinSuffixes + | NHC == compilerFlavor (compiler lbi) = ["hs", "lhs", "gc"] + | otherwise = ["hs", "lhs"] + localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] + pre dirs dir lhndlrs fp = + preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs + preProcessTest test exePath testDir = do + let bi = testBuildInfo test + biHandlers = localHandlers bi + sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ] + sequence_ [ preprocessFile sourceDirs (buildDir lbi) isSrcDist + (ModuleName.toFilePath modu) verbosity builtinSuffixes + biHandlers + | modu <- testModules test ] + preprocessFile (testDir : (hsSourceDirs bi)) testDir isSrcDist + (dropExtensions $ exePath) verbosity + builtinSuffixes biHandlers --TODO: try to list all the modules that could not be found -- not just the first one. It's annoying and slow due to the need @@ -454,7 +450,9 @@ ++ [ "--cflag=" ++ opt | pkg <- pkgs , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] - ++ [ opt | opt <- Installed.ccOptions pkg ] ] + ++ [ opt | opt <- Installed.ccOptions pkg ] + ++ [ "-I" ++ autogenModulesDir lbi, + "-include", autogenModulesDir lbi cppHeaderName ] ] ++ [ "--lflag=" ++ opt | pkg <- pkgs , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] diff --git a/Distribution/Simple/Program/HcPkg.hs b/Distribution/Simple/Program/HcPkg.hs --- a/Distribution/Simple/Program/HcPkg.hs +++ b/Distribution/Simple/Program/HcPkg.hs @@ -30,9 +30,9 @@ ( PackageId, InstalledPackageId(..) ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo, InstalledPackageInfo_(..) - , showInstalledPackageInfo, parseInstalledPackageInfo ) + , showInstalledPackageInfo + , emptyInstalledPackageInfo, fieldsInstalledPackageInfo ) import Distribution.ParseUtils - ( ParseResult(..) ) import Distribution.Simple.Compiler ( PackageDB(..), PackageDBStack ) import Distribution.Simple.Program.Types @@ -53,9 +53,15 @@ import Data.Char ( isSpace ) -import Control.Monad - ( liftM ) +import Data.Maybe + ( fromMaybe ) +import Data.List + ( stripPrefix ) +import System.FilePath as FilePath + ( (), splitPath, splitDirectories, joinPath, isPathSeparator ) +import qualified System.FilePath.Posix as FilePath.Posix + -- | Call @hc-pkg@ to register a package. -- -- > hc-pkg register {filename | -} [--user | --global | --package-conf] @@ -128,12 +134,28 @@ where parsePackages str = - let parse = liftM setInstalledPackageId . parseInstalledPackageInfo - parsed = map parse (splitPkgs str) + let parsed = map parseInstalledPackageInfo' (splitPkgs str) in case [ msg | ParseFailed msg <- parsed ] of - [] -> Left [ pkg | ParseOk _ pkg <- parsed ] + [] -> Left [ setInstalledPackageId + . maybe id mungePackagePaths pkgroot + $ pkg + | ParseOk _ (pkgroot, pkg) <- parsed ] msgs -> Right msgs + parseInstalledPackageInfo' = + parseFieldsFlat fields (Nothing, emptyInstalledPackageInfo) + where + fields = liftFieldFst pkgrootField + : map liftFieldSnd fieldsInstalledPackageInfo + + pkgrootField = + simpleField "pkgroot" + showFilePath parseFilePathQ + (fromMaybe "") (\x _ -> Just x) + + liftFieldFst = liftField fst (\x (_x,y) -> (x,y)) + liftFieldSnd = liftField snd (\y (x,_y) -> (x,y)) + --TODO: this could be a lot faster. We're doing normaliseLineEndings twice -- and converting back and forth with lines/unlines. splitPkgs :: String -> [String] @@ -149,7 +171,44 @@ _:ws -> splitWith p ws where (ys,zs) = break p xs +mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +mungePackagePaths pkgroot pkginfo = + pkginfo { + importDirs = mungePaths (importDirs pkginfo), + includeDirs = mungePaths (includeDirs pkginfo), + libraryDirs = mungePaths (libraryDirs pkginfo), + frameworkDirs = mungePaths (frameworkDirs pkginfo), + haddockInterfaces = mungePaths (haddockInterfaces pkginfo), + haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) + } + where + mungePaths = map mungePath + mungeUrls = map mungeUrl + mungePath p = case stripVarPrefix "${pkgroot}" p of + Just p' -> pkgroot p' + Nothing -> p + + mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of + Just p' -> toUrlPath pkgroot p' + Nothing -> p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) + + stripVarPrefix var p = + case splitPath p of + (root:path') -> case stripPrefix var root of + Just [sep] | isPathSeparator sep -> Just (joinPath path') + _ -> Nothing + _ -> Nothing + + -- Older installed package info files did not have the installedPackageId -- field, so if it is missing then we fill it as the source package ID. setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo @@ -230,13 +289,15 @@ dumpInvocation :: ConfiguredProgram -> Verbosity -> PackageDB -> ProgramInvocation -dumpInvocation hcPkg verbosity packagedb = +dumpInvocation hcPkg _verbosity packagedb = (programInvocation hcPkg args) { progInvokeOutputEncoding = IOEncodingUTF8 } where args = ["dump", packageDbOpts packagedb] - ++ verbosityOpts hcPkg verbosity + ++ verbosityOpts hcPkg silent + -- We use verbosity level 'silent' because it is important that we + -- do not contaminate the output with info/debug messages. packageDbStackOpts :: PackageDBStack -> [String] diff --git a/Distribution/Simple/Program/Types.hs b/Distribution/Simple/Program/Types.hs --- a/Distribution/Simple/Program/Types.hs +++ b/Distribution/Simple/Program/Types.hs @@ -17,6 +17,7 @@ module Distribution.Simple.Program.Types ( -- * Program and functions for constructing them Program(..), + internalProgram, simpleProgram, -- * Configured program and related functions @@ -26,8 +27,11 @@ ProgramLocation(..), ) where +import Data.List (nub) +import System.FilePath (()) + import Distribution.Simple.Utils - ( findProgramLocation ) + ( findProgramLocation, findFirstFile ) import Distribution.Version ( Version ) import Distribution.Verbosity @@ -104,3 +108,15 @@ programFindVersion = \_ _ -> return Nothing, programPostConf = \_ _ -> return [] } + +-- | Make a simple 'internal' program; that is, one that was built as an +-- executable already and is expected to be found in the build directory +internalProgram :: [FilePath] -> String -> Program +internalProgram paths name = Program { + programName = name, + programFindLocation = \_v -> + findFirstFile id [ path name | path <- nub paths ], + programFindVersion = \_ _ -> return Nothing, + programPostConf = \_ _ -> return [] + } + diff --git a/Distribution/Simple/Register.hs b/Distribution/Simple/Register.hs --- a/Distribution/Simple/Register.hs +++ b/Distribution/Simple/Register.hs @@ -93,7 +93,7 @@ , showInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Simple.Utils - ( writeUTF8File, writeFileAtomic + ( writeUTF8File, writeFileAtomic, setFileExecutable , die, notice, setupMessage ) import Distribution.System ( OS(..), buildOS ) @@ -102,13 +102,12 @@ import Distribution.Version ( Version(..) ) import Distribution.Verbosity as Verbosity ( Verbosity, normal ) -import Distribution.Compat.CopyFile - ( setFileExecutable ) +import Distribution.Compat.Exception + ( tryIO ) import System.FilePath ((), (<.>), isAbsolute) import System.Directory ( getCurrentDirectory, removeDirectoryRecursive ) -import System.IO.Error (try) import Data.Maybe ( isJust, fromMaybe, maybeToList ) @@ -270,11 +269,13 @@ IPI.stability = stability pkg, IPI.homepage = homepage pkg, IPI.pkgUrl = pkgUrl pkg, + IPI.synopsis = synopsis pkg, IPI.description = description pkg, IPI.category = category pkg, IPI.exposed = libExposed lib, IPI.exposedModules = exposedModules lib, IPI.hiddenModules = otherModules bi, + IPI.trusted = False, IPI.importDirs = [ libdir installDirs | hasModules ], IPI.libraryDirs = if hasLibrary then libdir installDirs : extraLibDirs bi @@ -375,10 +376,10 @@ (invocationAsSystemScript buildOS invocation) else runProgramInvocation verbosity invocation Hugs -> do - _ <- try $ removeDirectoryRecursive (libdir installDirs) + _ <- tryIO $ removeDirectoryRecursive (libdir installDirs) return () NHC -> do - _ <- try $ removeDirectoryRecursive (libdir installDirs) + _ <- tryIO $ removeDirectoryRecursive (libdir installDirs) return () _ -> die ("only unregistering with GHC and Hugs is implemented") diff --git a/Distribution/Simple/Setup.hs b/Distribution/Simple/Setup.hs --- a/Distribution/Simple/Setup.hs +++ b/Distribution/Simple/Setup.hs @@ -270,6 +270,7 @@ configVanillaLib :: Flag Bool, -- ^Enable vanilla library configProfLib :: Flag Bool, -- ^Enable profiling in the library configSharedLib :: Flag Bool, -- ^Build shared library + configDynExe :: Flag Bool, -- ^Enable dynamic linking of the executables. configProfExe :: Flag Bool, -- ^Enable profiling in the executables. configConfigureArgs :: [String], -- ^Extra arguments to @configure@ configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. @@ -290,7 +291,8 @@ configConstraints :: [Dependency], -- ^Additional constraints for -- dependencies configConfigurationsFlags :: FlagAssignment, - configTests :: Flag Bool -- ^Enable test suite compilation + configTests :: Flag Bool, -- ^Enable test suite compilation + configLibCoverage :: Flag Bool -- ^ Enable test suite program coverage } deriving (Read,Show) @@ -301,6 +303,7 @@ configVanillaLib = Flag True, configProfLib = Flag False, configSharedLib = Flag False, + configDynExe = Flag False, configProfExe = Flag False, configOptimization = Flag NormalOptimisation, configProgPrefix = Flag (toPathTemplate ""), @@ -311,7 +314,8 @@ configGHCiLib = Flag True, configSplitObjs = Flag False, -- takes longer, so turn off by default configStripExes = Flag True, - configTests = Flag False + configTests = Flag False, + configLibCoverage = Flag False } configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags @@ -388,10 +392,16 @@ configSharedLib (\v flags -> flags { configSharedLib = v }) (boolOpt [] []) + ,option "" ["executable-dynamic"] + "Executable dynamic linking" + configDynExe (\v flags -> flags { configDynExe = v }) + (boolOpt [] []) + ,option "" ["executable-profiling"] "Executable profiling" configProfExe (\v flags -> flags { configProfExe = v }) (boolOpt [] []) + ,multiOption "optimization" configOptimization (\v flags -> flags { configOptimization = v }) [optArg' "n" (Flag . flagToOptimisationLevel) @@ -464,6 +474,10 @@ "dependency checking and compilation for test suites listed in the package description file." configTests (\v flags -> flags { configTests = v }) (boolOpt [] []) + ,option "" ["library-coverage"] + "build library and test suites with Haskell Program Coverage enabled. (GHC only)" + configLibCoverage (\v flags -> flags { configLibCoverage = v }) + (boolOpt [] []) ] where readFlagList :: String -> FlagAssignment @@ -553,6 +567,7 @@ configVanillaLib = mempty, configProfLib = mempty, configSharedLib = mempty, + configDynExe = mempty, configProfExe = mempty, configConfigureArgs = mempty, configOptimization = mempty, @@ -571,7 +586,8 @@ configConstraints = mempty, configExtraIncludeDirs = mempty, configConfigurationsFlags = mempty, - configTests = mempty + configTests = mempty, + configLibCoverage = mempty } mappend a b = ConfigFlags { configPrograms = configPrograms b, @@ -583,6 +599,7 @@ configVanillaLib = combine configVanillaLib, configProfLib = combine configProfLib, configSharedLib = combine configSharedLib, + configDynExe = combine configDynExe, configProfExe = combine configProfExe, configConfigureArgs = combine configConfigureArgs, configOptimization = combine configOptimization, @@ -601,7 +618,8 @@ configConstraints = combine configConstraints, configExtraIncludeDirs = combine configExtraIncludeDirs, configConfigurationsFlags = combine configConfigurationsFlags, - configTests = combine configTests + configTests = combine configTests, + configLibCoverage = combine configLibCoverage } where combine field = field a `mappend` field b @@ -745,6 +763,7 @@ -- | Flags to @sdist@: (snapshot, verbosity) data SDistFlags = SDistFlags { sDistSnapshot :: Flag Bool, + sDistDirectory :: Flag FilePath, sDistDistPref :: Flag FilePath, sDistVerbosity :: Flag Verbosity } @@ -753,6 +772,7 @@ defaultSDistFlags :: SDistFlags defaultSDistFlags = SDistFlags { sDistSnapshot = Flag False, + sDistDirectory = mempty, sDistDistPref = Flag defaultDistPref, sDistVerbosity = Flag normal } @@ -773,6 +793,11 @@ "Produce a snapshot source distribution" sDistSnapshot (\v flags -> flags { sDistSnapshot = v }) trueArg + + ,option "" ["output-directory"] + "Generate a source distribution in the given directory" + sDistDirectory (\v flags -> flags { sDistDirectory = v }) + (reqArgFlag "DIR") ] emptySDistFlags :: SDistFlags @@ -781,11 +806,13 @@ instance Monoid SDistFlags where mempty = SDistFlags { sDistSnapshot = mempty, + sDistDirectory = mempty, sDistDistPref = mempty, sDistVerbosity = mempty } mappend a b = SDistFlags { sDistSnapshot = combine sDistSnapshot, + sDistDirectory = combine sDistDirectory, sDistDistPref = combine sDistDistPref, sDistVerbosity = combine sDistVerbosity } @@ -1234,6 +1261,7 @@ testHumanLog :: Flag PathTemplate, testMachineLog :: Flag PathTemplate, testShowDetails :: Flag TestShowDetails, + testKeepTix :: Flag Bool, --TODO: eliminate the test list and pass it directly as positional args to the testHook testList :: Flag [String], -- TODO: think about if/how options are passed to test exes @@ -1247,6 +1275,7 @@ testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log", testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log", testShowDetails = toFlag Failures, + testKeepTix = toFlag False, testList = Flag [], testOptions = Flag [] } @@ -1287,6 +1316,10 @@ (map display knownTestShowDetails)) (fmap toFlag parse)) (flagToList . fmap display)) + , option [] ["keep-tix-files"] + "keep .tix files for HPC between test runs" + testKeepTix (\v flags -> flags { testKeepTix = v}) + trueArg , option [] ["test-options"] ("give extra options to test executables " ++ "(name templates can use $pkgid, $compiler, " @@ -1314,6 +1347,7 @@ testHumanLog = mempty, testMachineLog = mempty, testShowDetails = mempty, + testKeepTix = mempty, testList = mempty, testOptions = mempty } @@ -1323,6 +1357,7 @@ testHumanLog = combine testHumanLog, testMachineLog = combine testMachineLog, testShowDetails = combine testShowDetails, + testKeepTix = combine testKeepTix, testList = combine testList, testOptions = combine testOptions } diff --git a/Distribution/Simple/SrcDist.hs b/Distribution/Simple/SrcDist.hs --- a/Distribution/Simple/SrcDist.hs +++ b/Distribution/Simple/SrcDist.hs @@ -79,13 +79,13 @@ ( Version(versionBranch) ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File - , installOrdinaryFile, installOrdinaryFiles + , installOrdinaryFile, installOrdinaryFiles, setFileExecutable , findFile, findFileWithExtension, matchFileGlob , withTempDirectory, defaultPackageDesc , die, warn, notice, setupMessage ) -import Distribution.Simple.Setup (SDistFlags(..), fromFlag) -import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessSources) -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.Setup (SDistFlags(..), fromFlag, flagToMaybe) +import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessComponent) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), withComponentsLBI ) import Distribution.Simple.BuildPaths ( autogenModuleName ) import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram, rawSystemProgram, tarProgram ) @@ -99,7 +99,6 @@ import System.Time (getClockTime, toCalendarTime, CalendarTime(..)) import System.Directory ( doesFileExist, Permissions(executable), getPermissions ) -import Distribution.Compat.CopyFile (setFileExecutable) import Distribution.Verbosity (Verbosity) import System.FilePath ( (), (<.>), takeDirectory, dropExtension, isAbsolute ) @@ -112,9 +111,6 @@ -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) -> IO () sdist pkg mb_lbi flags mkTmpDir pps = do - let distPref = fromFlag $ sDistDistPref flags - targetPref = distPref - tmpTargetDir = mkTmpDir distPref -- do some QA printPackageProblems verbosity pkg @@ -122,26 +118,39 @@ when (isNothing mb_lbi) $ warn verbosity "Cannot run preprocessors. Run 'configure' command first." - createDirectoryIfMissingVerbose verbosity True tmpTargetDir - withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + date <- toCalendarTime =<< getClockTime + let pkg' | snapshot = snapshotPackage date pkg + | otherwise = pkg - date <- toCalendarTime =<< getClockTime - let pkg' | snapshot = snapshotPackage date pkg - | otherwise = pkg - setupMessage verbosity "Building source dist for" (packageId pkg') + case flagToMaybe (sDistDirectory flags) of + Just targetDir -> do + generateSourceDir targetDir pkg' + notice verbosity $ "Source directory created: " ++ targetDir - -- FIXME This looks a bit suspicious. Should createArchive be passed - -- the result of prepareSnapshotTree/prepareTree? - _ <- if snapshot - then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps - else prepareTree verbosity pkg' mb_lbi distPref tmpDir pps - targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref - notice verbosity $ "Source tarball created: " ++ targzFile + Nothing -> do + createDirectoryIfMissingVerbose verbosity True tmpTargetDir + withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + let targetDir = tmpDir tarBallName pkg' + generateSourceDir targetDir pkg' + targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref + notice verbosity $ "Source tarball created: " ++ targzFile where + generateSourceDir targetDir pkg' = do + + setupMessage verbosity "Building source dist for" (packageId pkg') + prepareTree verbosity pkg' mb_lbi distPref targetDir pps + when snapshot $ + overwriteSnapshotPackageDesc verbosity pkg' targetDir + verbosity = fromFlag (sDistVerbosity flags) snapshot = fromFlag (sDistSnapshot flags) + distPref = fromFlag $ sDistDistPref flags + targetPref = distPref + tmpTargetDir = mkTmpDir distPref + + -- |Prepare a directory tree of source files. prepareTree :: Verbosity -- ^verbosity -> PackageDescription -- ^info from the cabal file @@ -149,14 +158,14 @@ -> FilePath -- ^dist dir -> FilePath -- ^source tree to populate -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) - -> IO FilePath -- ^the name of the dir created and populated - -prepareTree verbosity pkg_descr0 mb_lbi distPref tmpDir pps = do - let targetDir = tmpDir tarBallName pkg_descr + -> IO () +prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do createDirectoryIfMissingVerbose verbosity True targetDir + -- maybe move the library files into place withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } -> prepareDir verbosity pkg_descr distPref targetDir pps modules libBi + -- move the executables into place withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do prepareDir verbosity pkg_descr distPref targetDir pps [] exeBi @@ -166,6 +175,7 @@ Nothing -> findFile (hsSourceDirs exeBi) mainPath Just pp -> return pp copyFileTo verbosity targetDir srcMainFile + -- move the test suites into place withTest $ \t -> do let bi = testBuildInfo t @@ -184,6 +194,7 @@ TestSuiteLibV09 _ m -> do prep [m] bi TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " ++ show tp + flip mapM_ (dataFiles pkg_descr) $ \ filename -> do files <- matchFileGlob (dataDir pkg_descr filename) let dir = takeDirectory (dataDir pkg_descr filename) @@ -214,9 +225,10 @@ -- if the package was configured then we can run platform independent -- pre-processors and include those generated files case mb_lbi of - Just lbi | not (null pps) - -> preprocessSources pkg_descr (lbi { buildDir = targetDir buildDir lbi }) - True verbosity pps + Just lbi | not (null pps) -> do + let lbi' = lbi{ buildDir = targetDir buildDir lbi } + withComponentsLBI pkg_descr lbi' $ \c _ -> + preprocessComponent pkg_descr c lbi' True verbosity pps _ -> return () -- setup isn't listed in the description file. @@ -230,7 +242,6 @@ -- the description file itself descFile <- defaultPackageDesc verbosity installOrdinaryFile verbosity descFile (targetDir descFile) - return targetDir where pkg_descr = mapAllBuildInfo filterAutogenModule pkg_descr0 @@ -261,21 +272,24 @@ -> FilePath -- ^dist dir -> FilePath -- ^source tree to populate -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) - -> IO FilePath -- ^the resulting temp dir -prepareSnapshotTree verbosity pkg mb_lbi distPref tmpDir pps = do - targetDir <- prepareTree verbosity pkg mb_lbi distPref tmpDir pps - overwriteSnapshotPackageDesc (packageVersion pkg) targetDir - return targetDir + -> IO () +prepareSnapshotTree verbosity pkg mb_lbi distPref targetDir pps = do + prepareTree verbosity pkg mb_lbi distPref targetDir pps + overwriteSnapshotPackageDesc verbosity pkg targetDir - where - overwriteSnapshotPackageDesc version targetDir = do - -- We could just writePackageDescription targetDescFile pkg_descr, - -- but that would lose comments and formatting. - descFile <- defaultPackageDesc verbosity - withUTF8FileContents descFile $ - writeUTF8File (targetDir descFile) - . unlines . map (replaceVersion version) . lines +overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> FilePath -- ^source tree + -> IO () +overwriteSnapshotPackageDesc verbosity pkg targetDir = do + -- We could just writePackageDescription targetDescFile pkg_descr, + -- but that would lose comments and formatting. + descFile <- defaultPackageDesc verbosity + withUTF8FileContents descFile $ + writeUTF8File (targetDir descFile) + . unlines . map (replaceVersion (packageVersion pkg)) . lines + where replaceVersion :: Version -> String -> String replaceVersion version line | "version:" `isPrefixOf` map toLower line diff --git a/Distribution/Simple/Test.hs b/Distribution/Simple/Test.hs --- a/Distribution/Simple/Test.hs +++ b/Distribution/Simple/Test.hs @@ -57,11 +57,13 @@ import Distribution.Package ( PackageId ) import qualified Distribution.PackageDescription as PD - ( PackageDescription(..), TestSuite(..) + ( PackageDescription(..), BuildInfo(buildable) + , TestSuite(..) , TestSuiteInterface(..), testType, hasTests ) import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar ) import Distribution.Simple.BuildPaths ( exeExtension ) import Distribution.Simple.Compiler ( Compiler(..), CompilerId ) +import Distribution.Simple.Hpc ( doHpcMarkup, findTixFiles, tixDir ) import Distribution.Simple.InstallDirs ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) , substPathTemplate , toPathTemplate, PathTemplate ) @@ -173,11 +175,20 @@ existingEnv <- getEnvironment let dataDirPath = pwd PD.dataDir pkg_descr shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath) + : ("HPCTIXDIR", pwd tixDir distPref suite) : existingEnv bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog -> bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do + -- Create directory for HPC files. + createDirectoryIfMissing True $ tixDir distPref suite + + -- Remove old .tix files if appropriate. + tixFiles <- findTixFiles distPref suite + unless (fromFlag $ testKeepTix flags) + $ mapM_ deleteIfExists tixFiles + -- Write summary notices indicating start of test suite notice verbosity $ summarizeSuiteStart $ PD.testName suite appendFile tempLog $ summarizeSuiteStart $ PD.testName suite @@ -221,6 +232,8 @@ -- Write summary notice to terminal indicating end of test suite notice verbosity $ summarizeSuiteFinish suiteLog' + doHpcMarkup verbosity distPref (display $ PD.package pkg_descr) suite + return suiteLog' where deleteIfExists file = do @@ -245,7 +258,9 @@ testLogDir = distPref "test" testNames = fromFlag $ testList flags pkgTests = PD.testSuites pkg_descr - enabledTests = filter PD.testEnabled pkgTests + enabledTests = [ t | t <- pkgTests + , PD.testEnabled t + , PD.buildable (PD.testBuildInfo t) ] doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog doTest (suite, mLog) = do diff --git a/Distribution/Simple/UHC.hs b/Distribution/Simple/UHC.hs --- a/Distribution/Simple/UHC.hs +++ b/Distribution/Simple/UHC.hs @@ -95,19 +95,23 @@ -- | The flags for the supported extensions. uhcLanguageExtensions :: [(Extension, C.Flag)] uhcLanguageExtensions = - [(CPP, "--cpp"), - (PolymorphicComponents, ""), - (ExistentialQuantification, ""), - (ForeignFunctionInterface, ""), - (UndecidableInstances, ""), - (MultiParamTypeClasses, ""), - (Rank2Types, ""), - (PatternSignatures, ""), - (EmptyDataDecls, ""), - (NoImplicitPrelude, "--no-prelude"), - (TypeOperators, ""), - (OverlappingInstances, ""), - (FlexibleInstances, "")] + let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), + (DisableExtension f, disable)] + alwaysOn = ("", ""{- wrong -}) + in concatMap doFlag + [(CPP, ("--cpp", ""{- wrong -})), + (PolymorphicComponents, alwaysOn), + (ExistentialQuantification, alwaysOn), + (ForeignFunctionInterface, alwaysOn), + (UndecidableInstances, alwaysOn), + (MultiParamTypeClasses, alwaysOn), + (Rank2Types, alwaysOn), + (PatternSignatures, alwaysOn), + (EmptyDataDecls, alwaysOn), + (ImplicitPrelude, ("", "--no-prelude"{- wrong -})), + (TypeOperators, alwaysOn), + (OverlappingInstances, alwaysOn), + (FlexibleInstances, alwaysOn)] getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration -> IO PackageIndex diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs --- a/Distribution/Simple/Utils.hs +++ b/Distribution/Simple/Utils.hs @@ -79,11 +79,16 @@ installOrdinaryFiles, installDirectoryContents, + -- * File permissions + setFileOrdinary, + setFileExecutable, + -- * file names currentDir, -- * finding files findFile, + findFirstFile, findFileWithExtension, findFileWithExtension', findModuleFile, @@ -160,7 +165,7 @@ ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) import System.IO.Error as IO.Error - ( try, isDoesNotExistError, isAlreadyExistsError + ( isDoesNotExistError, isAlreadyExistsError , ioeSetFileName, ioeGetFileName, ioeGetErrorString ) #if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)) import System.IO.Error @@ -192,11 +197,11 @@ import Distribution.Compat.CopyFile ( copyFile, copyOrdinaryFile, copyExecutableFile - , setDirOrdinary ) + , setFileOrdinary, setFileExecutable, setDirOrdinary ) import Distribution.Compat.TempFile ( openTempFile, openNewBinaryFile, createTempDirectory ) import Distribution.Compat.Exception - ( IOException, throwIOIO, catchIO, catchExit, onException ) + ( IOException, throwIOIO, tryIO, catchIO, catchExit, onException ) import Distribution.Verbosity #ifdef VERSION_base @@ -233,7 +238,7 @@ die msg = ioError (userError msg) topHandler :: IO a -> IO a -topHandler prog = catch prog handle +topHandler prog = catchIO prog handle where handle ioe = do hFlush stdout @@ -721,7 +726,7 @@ createDir :: FilePath -> (IOException -> IO ()) -> IO () createDir dir notExistHandler = do - r <- try $ createDirectoryVerbose verbosity dir + r <- tryIO $ createDirectoryVerbose verbosity dir case (r :: Either IOException ()) of Right () -> return () Left e @@ -737,7 +742,7 @@ isDir <- doesDirectoryExist dir if isDir then return () else throwIOIO e - ) `catch` ((\_ -> return ()) :: IOException -> IO ()) + ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) | otherwise -> throwIOIO e createDirectoryVerbose :: Verbosity -> FilePath -> IO () @@ -925,7 +930,7 @@ -- rewriteFile :: FilePath -> String -> IO () rewriteFile path newContent = - flip catch mightNotExist $ do + flip catchIO mightNotExist $ do existingContent <- readFile path _ <- evaluate (length existingContent) unless (existingContent == newContent) $ diff --git a/Distribution/System.hs b/Distribution/System.hs --- a/Distribution/System.hs +++ b/Distribution/System.hs @@ -58,16 +58,23 @@ -- * Operating System -- ------------------------------------------------------------ -data OS = Linux | Windows | OSX - | FreeBSD | OpenBSD | NetBSD - | Solaris | AIX | HPUX | IRIX +data OS = Linux | Windows | OSX -- teir 1 desktop OSs + | FreeBSD | OpenBSD | NetBSD -- other free unix OSs + | Solaris | AIX | HPUX | IRIX -- ageing Unix OSs + | HaLVM -- bare metal / VMs / hypervisors | OtherOS String deriving (Eq, Ord, Show, Read) +--TODO: decide how to handle Android and iOS. +-- They are like Linux and OSX but with some differences. +-- Should they be separate from linux/osx, or a subtype? +-- e.g. should we have os(linux) && os(android) true simultaneously? + knownOSs :: [OS] knownOSs = [Linux, Windows, OSX ,FreeBSD, OpenBSD, NetBSD - ,Solaris, AIX, HPUX, IRIX] + ,Solaris, AIX, HPUX, IRIX + ,HaLVM] osAliases :: ClassificationStrictness -> OS -> [String] osAliases Permissive Windows = ["mingw32", "cygwin32"] diff --git a/Distribution/Text.hs b/Distribution/Text.hs --- a/Distribution/Text.hs +++ b/Distribution/Text.hs @@ -52,13 +52,13 @@ Parse.string "false") >> return False ] instance Text Version where - disp (Version branch _tags) -- Do not display the tags + disp (Version branch _tags) -- Death to version tags!! = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch)) parse = do branch <- Parse.sepBy1 digits (Parse.char '.') tags <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum) - return (Version branch tags) + return (Version branch tags) --TODO: should we ignore the tags? where digits = do first <- Parse.satisfy Char.isDigit diff --git a/Distribution/Version.hs b/Distribution/Version.hs --- a/Distribution/Version.hs +++ b/Distribution/Version.hs @@ -76,7 +76,7 @@ -- ** 'VersionIntervals' abstract type -- | The 'VersionIntervals' type and the accompanying functions are exposed - -- primarily for completeness and testing purposes. In practice + -- primarily for completeness and testing purposes. In practice -- 'asVersionIntervals' is the main function to use to -- view a 'VersionRange' as a bunch of 'VersionInterval's. -- @@ -680,7 +680,7 @@ (\v _ -> (Disp.text "==" <> dispWild v , 0)) (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) - id + (\(r, p) -> (Disp.parens r, p)) where dispWild (Version b _) = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) diff --git a/Language/Haskell/Extension.hs b/Language/Haskell/Extension.hs --- a/Language/Haskell/Extension.hs +++ b/Language/Haskell/Extension.hs @@ -43,6 +43,7 @@ knownLanguages, Extension(..), + KnownExtension(..), knownExtensions, deprecatedExtensions ) where @@ -99,13 +100,11 @@ -- * Extension -- ------------------------------------------------------------ --- Note: if you add a new 'Extension': +-- Note: if you add a new 'KnownExtension': -- -- * also add it to the Distribution.Simple.X.languageExtensions lists -- (where X is each compiler: GHC, JHC, Hugs, NHC) -- --- * also to the 'knownExtensions' list below. - -- | This represents language extensions beyond a base 'Language' definition -- (such as 'Haskell98') that are supported by some implementations, usually -- in some special mode. @@ -115,7 +114,20 @@ -- documented in section 7.2.1 of the GHC User's Guide. data Extension = - + -- | Enable a known extension + EnableExtension KnownExtension + + -- | Disable a known extension + | DisableExtension KnownExtension + + -- | An unknown extension, identified by the name of its @LANGUAGE@ + -- pragma. + | UnknownExtension String + + deriving (Show, Read, Eq) + +data KnownExtension = + -- | [GHC § 7.6.3.4] Allow overlapping class instances, -- provided there is a unique most specific instance for each use. OverlappingInstances @@ -149,8 +161,8 @@ -- | [GHC § 7.6.1.1] Allow multiple parameters in a type class. | MultiParamTypeClasses - -- | [GHC § 7.17] Disable the dreaded monomorphism restriction. - | NoMonomorphismRestriction + -- | [GHC § 7.17] Enable the dreaded monomorphism restriction. + | MonomorphismRestriction -- | [GHC § 7.6.2] Allow a specification attached to a -- multi-parameter type class which indicates that some parameters @@ -230,11 +242,11 @@ -- defined in terms of the algebraic structure of a type. | Generics - -- | [GHC § 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 § 7.3.11] Enable the implicit importing of the module + -- @Prelude@. When disabled, when desugaring certain built-in syntax + -- into ordinary identifiers, use whatever is in scope rather than the + -- @Prelude@ -- version. + | ImplicitPrelude -- | [GHC § 7.3.15] Enable syntax for implicitly binding local names -- corresponding to the field names of a record. Puns bind specific @@ -310,13 +322,15 @@ -- | [GHC § 7.4.6] Enable generalized algebraic data types, in -- which type variables may be instantiated on a per-constructor - -- basis. Enables \"GADT syntax\" which can be used to declare - -- GADTs as well as ordinary algebraic types. + -- basis. Implies GADTSyntax. | GADTs - -- | [GHC § 7.17.2] Allow pattern bindings to be polymorphic. - | NoMonoPatBinds + -- | Enable GADT syntax for declaring ordinary algebraic datatypes. + | GADTSyntax + -- | [GHC § 7.17.2] Make pattern bindings monomorphic. + | MonoPatBinds + -- | [GHC § 7.8.8] Relax the requirements on mutually-recursive -- polymorphic functions. | RelaxedPolyRec @@ -368,8 +382,8 @@ | ViewPatterns -- | Allow concrete XML syntax to be used in expressions and patterns, - -- as per the Haskell Server Pages extension language: - -- . The ideas behind it are + -- as per the Haskell Server Pages extension language: + -- . The ideas behind it are -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\" -- by Niklas Broberg, from Haskell Workshop '05. | XmlSyntax @@ -419,110 +433,65 @@ -- | Enable @deriving@ for the @Data.Foldable.Foldable@ class. | DeriveFoldable - -- | An unknown extension, identified by the name of its @LANGUAGE@ - -- pragma. - | UnknownExtension String - deriving (Show, Read, Eq) + -- | Enable non-decreasing indentation for 'do' blocks. + | NondecreasingIndentation + deriving (Show, Read, Eq, Enum, Bounded) + +{-# DEPRECATED knownExtensions + "KnownExtension is an instance of Enum and Bounded, use those instead." #-} +knownExtensions :: [KnownExtension] +knownExtensions = [minBound..maxBound] + -- | Extensions that have been deprecated, possibly paired with another -- extension that replaces it. -- deprecatedExtensions :: [(Extension, Maybe Extension)] deprecatedExtensions = - [ (RecordPuns, Just NamedFieldPuns) - , (PatternSignatures, Just ScopedTypeVariables) - ] - -knownExtensions :: [Extension] -knownExtensions = - [ OverlappingInstances - , UndecidableInstances - , IncoherentInstances - , DoRec - , RecursiveDo - , ParallelListComp - , MultiParamTypeClasses - , NoMonomorphismRestriction - , FunctionalDependencies - , Rank2Types - , RankNTypes - , PolymorphicComponents - , ExistentialQuantification - , ScopedTypeVariables - , ImplicitParams - , FlexibleContexts - , FlexibleInstances - , EmptyDataDecls - , CPP - - , KindSignatures - , BangPatterns - , TypeSynonymInstances - , TemplateHaskell - , ForeignFunctionInterface - , Arrows - , Generics - , NoImplicitPrelude - , NamedFieldPuns - , PatternGuards - , GeneralizedNewtypeDeriving - - , ExtensibleRecords - , RestrictedTypeSynonyms - , HereDocuments - , MagicHash - , TypeFamilies - , StandaloneDeriving - - , UnicodeSyntax - , PatternSignatures - , UnliftedFFITypes - , LiberalTypeSynonyms - , TypeOperators ---PArr -- not ready yet, and will probably be renamed to ParallelArrays - , RecordWildCards - , RecordPuns - , DisambiguateRecordFields - , OverloadedStrings - , GADTs - , NoMonoPatBinds - , RelaxedPolyRec - , ExtendedDefaultRules - , UnboxedTuples - , DeriveDataTypeable - , ConstrainedClassMethods - , PackageImports - , ImpredicativeTypes - , NewQualifiedOperators - , PostfixOperators - , QuasiQuotes - , TransformListComp - , ViewPatterns - , XmlSyntax - , RegularPatterns - - , TupleSections - , GHCForeignImportPrim - , NPlusKPatterns - , DoAndIfThenElse - , RebindableSyntax - , ExplicitForAll - , DatatypeContexts - , MonoLocalBinds - , DeriveFunctor - , DeriveTraversable - , DeriveFoldable + [ (EnableExtension RecordPuns, Just (EnableExtension NamedFieldPuns)) + , (EnableExtension PatternSignatures, Just (EnableExtension ScopedTypeVariables)) ] +-- NOTE: when adding deprecated extensions that have new alternatives +-- we must be careful to make sure that the deprecation messages are +-- valid. We must not recomend aliases that cannot be used with older +-- compilers, perhaps by adding support in Cabal to translate the new +-- name to the old one for older compilers. Otherwise we are in danger +-- of the scenario in ticket #689. instance Text Extension where disp (UnknownExtension other) = Disp.text other - disp other = Disp.text (show other) + disp (EnableExtension ke) = Disp.text (show ke) + disp (DisableExtension ke) = Disp.text ("No" ++ show ke) parse = do extension <- Parse.munch1 Char.isAlphaNum return (classifyExtension extension) --- | 'read' for 'Extension's is really really slow so for the Text instance +instance Text KnownExtension where + disp ke = Disp.text (show ke) + + parse = do + extension <- Parse.munch1 Char.isAlphaNum + case classifyKnownExtension extension of + Just ke -> + return ke + Nothing -> + fail ("Can't parse " ++ show extension ++ " as KnownExtension") + +classifyExtension :: String -> Extension +classifyExtension string + = case classifyKnownExtension string of + Just ext -> EnableExtension ext + Nothing -> + case string of + 'N':'o':string' -> + case classifyKnownExtension string' of + Just ext -> DisableExtension ext + Nothing -> UnknownExtension string + _ -> UnknownExtension string + +-- | 'read' for 'KnownExtension's is really really slow so for the Text +-- instance -- what we do is make a simple table indexed off the first letter in the -- extension name. The extension names actually cover the range @'A'-'Z'@ -- pretty densely and the biggest bucket is 7 so it's not too bad. We just do @@ -531,17 +500,17 @@ -- This gives an order of magnitude improvement in parsing speed, and it'll -- also allow us to do case insensitive matches in future if we prefer. -- -classifyExtension :: String -> Extension -classifyExtension string@(c:_) - | inRange (bounds extensionTable) c - = case lookup string (extensionTable ! c) of - Just extension -> extension - Nothing -> UnknownExtension string -classifyExtension string = UnknownExtension string +classifyKnownExtension :: String -> Maybe KnownExtension +classifyKnownExtension "" = Nothing +classifyKnownExtension string@(c : _) + | inRange (bounds knownExtensionTable) c + = lookup string (knownExtensionTable ! c) + | otherwise = Nothing -extensionTable :: Array Char [(String, Extension)] -extensionTable = +knownExtensionTable :: Array Char [(String, KnownExtension)] +knownExtensionTable = accumArray (flip (:)) [] ('A', 'Z') [ (head str, (str, extension)) - | extension <- knownExtensions + | extension <- [toEnum 0 ..] , let str = show extension ] + diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs @@ -0,0 +1,15 @@ +module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive1") [] + result <- cabal_build spec + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $ + "Failed to load interface for `Prelude'" `isInfixOf` outputText result diff --git a/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs @@ -0,0 +1,15 @@ +module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive2") [] + result <- cabal_build spec + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $ + "Failed to load interface for `Prelude'" `isInfixOf` outputText result diff --git a/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs @@ -0,0 +1,20 @@ +module PackageTests.BuildDeps.InternalLibrary0.Check where + +import Test.HUnit +import PackageTests.PackageTester +import Control.Monad +import System.FilePath +import Data.Version +import Data.List (isInfixOf, intercalate) + + +suite :: Version -> Test +suite cabalVersion = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary0") [] + result <- cabal_build spec + assertEqual "cabal build should fail" False (successful result) + when (cabalVersion >= Version [1, 7] []) $ do + -- In 1.7 it should tell you how to enable the desired behaviour. + assertEqual "error should say 'library which is defined within the same package.'" True $ + "library which is defined within the same package." `isInfixOf` (intercalate " " $ lines $ outputText result) + diff --git a/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs @@ -0,0 +1,12 @@ +module PackageTests.BuildDeps.InternalLibrary1.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary1") [] + result <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful result) diff --git a/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs @@ -0,0 +1,24 @@ +module PackageTests.BuildDeps.InternalLibrary2.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import qualified Data.ByteString.Char8 as C + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary2") [] + let specTI = PackageSpec (directory spec "to-install") [] + + unregister "InternalLibrary2" + iResult <- cabal_install specTI + assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) + bResult <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) + unregister "InternalLibrary2" + + (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] + C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) + assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output) + diff --git a/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs @@ -0,0 +1,24 @@ +module PackageTests.BuildDeps.InternalLibrary3.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import qualified Data.ByteString.Char8 as C + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary3") [] + let specTI = PackageSpec (directory spec "to-install") [] + + unregister "InternalLibrary3" + iResult <- cabal_install specTI + assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) + bResult <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) + unregister "InternalLibrary3" + + (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] + C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) + assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output) + diff --git a/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs b/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs @@ -0,0 +1,24 @@ +module PackageTests.BuildDeps.InternalLibrary4.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import qualified Data.ByteString.Char8 as C + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary4") [] + let specTI = PackageSpec (directory spec "to-install") [] + + unregister "InternalLibrary4" + iResult <- cabal_install specTI + assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) + bResult <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) + unregister "InternalLibrary4" + + (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] + C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) + assertEqual "executable should have linked with the installed library" "myLibFunc installed" (concat $ lines output) + diff --git a/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs b/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs @@ -0,0 +1,12 @@ +module PackageTests.BuildDeps.SameDepsAllRound.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "SameDepsAllRound") [] + result <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful result) diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs @@ -0,0 +1,18 @@ +module PackageTests.BuildDeps.TargetSpecificDeps1.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps1") [] + result <- cabal_build spec + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + assertBool "error should be in MyLibrary.hs" $ + "MyLibrary.hs:" `isInfixOf` outputText result + assertBool "error should be \"Could not find module `System.Time\"" $ + "Could not find module `System.Time'" `isInfixOf` + (intercalate " " $ lines $ outputText result) diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs @@ -0,0 +1,13 @@ +module PackageTests.BuildDeps.TargetSpecificDeps2.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps2") [] + result <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful result) diff --git a/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs @@ -0,0 +1,17 @@ +module PackageTests.BuildDeps.TargetSpecificDeps3.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps3") [] + result <- cabal_build spec + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + assertBool "error should be in lemon.hs" $ + "lemon.hs:" `isInfixOf` outputText result + assertBool "error should be \"Could not find module `System.Time\"" $ + "Could not find module `System.Time'" `isInfixOf` (intercalate " " $ lines $ outputText result) diff --git a/tests/PackageTests/PackageTester.hs b/tests/PackageTests/PackageTester.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PackageTester.hs @@ -0,0 +1,192 @@ +module PackageTests.PackageTester ( + PackageSpec(..), + Success(..), + Result(..), + cabal_configure, + cabal_build, + cabal_test, + cabal_install, + unregister, + run + ) where + +import qualified Control.Exception.Extensible as E +import System.Directory +import System.FilePath +import System.IO +import System.Posix.IO +import System.Process +import System.Exit +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Concurrent +import Control.Monad +import Data.List +import Data.Maybe +import qualified Data.ByteString.Char8 as C + + +data PackageSpec = + PackageSpec { + directory :: FilePath, + configOpts :: [String] + } + +data Success = Failure | ConfigureSuccess | BuildSuccess | InstallSuccess | TestSuccess deriving (Eq, Show) + +data Result = Result { + successful :: Bool, + success :: Success, + outputText :: String + } + deriving Show + +nullResult :: Result +nullResult = Result True Failure "" + +recordRun :: (String, ExitCode, String) -> Success -> Result -> Result +recordRun (cmd, exitCode, exeOutput) thisSucc res = + res { + successful = successful res && exitCode == ExitSuccess, + success = if exitCode == ExitSuccess then thisSucc + else success res, + outputText = + (if null $ outputText res then "" else outputText res ++ "\n") ++ + cmd ++ "\n" ++ exeOutput + } + +cabal_configure :: PackageSpec -> IO Result +cabal_configure spec = do + res <- doCabalConfigure spec + record spec res + return res + +doCabalConfigure :: PackageSpec -> IO Result +doCabalConfigure spec = do + cleanResult@(_, _, cleanOutput) <- cabal spec ["clean"] + requireSuccess cleanResult + res <- cabal spec $ ["configure", "--user"] ++ configOpts spec + return $ recordRun res ConfigureSuccess nullResult + +doCabalBuild :: PackageSpec -> IO Result +doCabalBuild spec = do + configResult <- doCabalConfigure spec + if successful configResult + then do + res <- cabal spec ["build"] + return $ recordRun res BuildSuccess configResult + else + return configResult + +cabal_build :: PackageSpec -> IO Result +cabal_build spec = do + res <- doCabalBuild spec + record spec res + return res + +unregister :: String -> IO () +unregister libraryName = do + res@(_, _, output) <- run Nothing "ghc-pkg" ["unregister", "--user", libraryName] + if "cannot find package" `isInfixOf` output + then return () + else requireSuccess res + +-- | Install this library in the user area +cabal_install :: PackageSpec -> IO Result +cabal_install spec = do + buildResult <- doCabalBuild spec + res <- if successful buildResult + then do + res <- cabal spec ["install"] + return $ recordRun res InstallSuccess buildResult + else + return buildResult + record spec res + return res + +cabal_test :: PackageSpec -> IO Result +cabal_test spec = do + res <- cabal spec ["test"] + let r = recordRun res TestSuccess nullResult + record spec r + return r + +-- | Returns the command that was issued, the return code, and hte output text +cabal :: PackageSpec -> [String] -> IO (String, ExitCode, String) +cabal spec cabalArgs = do + wd <- getCurrentDirectory + r <- run (Just $ directory spec) "ghc" + [ "--make" + , "-fhpc" + , "-package-conf " ++ wd "../dist/package.conf.inplace" + , "Setup.hs" + ] + requireSuccess r + run (Just $ directory spec) (wd directory spec "Setup") cabalArgs + +-- | Returns the command that was issued, the return code, and hte output text +run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String) +run cwd cmd args = do + -- Posix-specific + (outf, outf0) <- createPipe + (errf, errf0) <- createPipe + outh <- fdToHandle outf + outh0 <- fdToHandle outf0 + errh <- fdToHandle errf + errh0 <- fdToHandle errf0 + pid <- runProcess cmd args cwd Nothing Nothing (Just outh0) (Just errh0) + + {- + -- ghc-6.10.1 specific + (Just inh, Just outh, Just errh, pid) <- + createProcess (proc cmd args){ std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe, + cwd = cwd } + hClose inh -- done with stdin + -} + + -- fork off a thread to start consuming the output + outChan <- newChan + forkIO $ suckH outChan outh + forkIO $ suckH outChan errh + + output <- suckChan outChan + + hClose outh + hClose errh + + -- wait on the process + ex <- waitForProcess pid + let fullCmd = intercalate " " $ cmd:args + return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, + ex, output) + where + suckH chan h = do + eof <- hIsEOF h + if eof + then writeChan chan Nothing + else do + c <- hGetChar h + writeChan chan $ Just c + suckH chan h + suckChan chan = sc' chan 2 [] + where + sc' _ 0 acc = return $ reverse acc + sc' chan eofs acc = do + mC <- readChan chan + case mC of + Just c -> sc' chan eofs (c:acc) + Nothing -> sc' chan (eofs-1) acc + +requireSuccess :: (String, ExitCode, String) -> IO () +requireSuccess (cmd, exitCode, output) = do + case exitCode of + ExitSuccess -> return () + ExitFailure r -> do + ioError $ userError $ "Command " ++ cmd ++ " failed." + +record :: PackageSpec -> Result -> IO () +record spec res = do + C.writeFile (directory spec "test-log.txt") (C.pack $ outputText res) + diff --git a/tests/PackageTests/TestStanza/Check.hs b/tests/PackageTests/TestStanza/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestStanza/Check.hs @@ -0,0 +1,57 @@ +module PackageTests.TestStanza.Check where + +import Test.HUnit +import System.FilePath +import PackageTests.PackageTester +import Data.List (isInfixOf, intercalate) +import Distribution.Version +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Dependency(..) ) +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), TestSuite(..), Library(..) + , TestSuiteInterface(..) + , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary + , emptyTestSuite, BuildType(..) ) +import Distribution.Verbosity (silent) +import Distribution.License (License(..)) +import Distribution.ModuleName (fromString) +import Distribution.System (buildPlatform) +import Distribution.Compiler + ( CompilerId(..), CompilerFlavor(..) ) +import Distribution.Text + +suite :: Version -> Test +suite cabalVersion = TestCase $ do + let directory = "PackageTests" "TestStanza" + pdFile = directory "my" <.> "cabal" + spec = PackageSpec directory [] + result <- cabal_configure spec + let message = "cabal configure should recognize test section" + test = "unknown section type" + `isInfixOf` + (intercalate " " $ lines $ outputText result) + assertEqual message False test + genPD <- readPackageDescription silent pdFile + let compiler = CompilerId GHC $ Version [6, 12, 2] [] + anyV = intersectVersionRanges anyVersion anyVersion + anticipatedTestSuite = emptyTestSuite + { testName = "dummy" + , testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs" + , testBuildInfo = emptyBuildInfo + { targetBuildDepends = + [ Dependency (PackageName "base") anyVersion ] + , hsSourceDirs = ["."] + } + , testEnabled = False + } + case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of + Left xs -> let depMessage = "should not have missing dependencies:\n" ++ + (unlines $ map (show . disp) xs) + in assertEqual depMessage True False + Right (f, _) -> let gotTest = head $ testSuites f + in assertEqual "parsed test-suite stanza does not match anticipated" + gotTest anticipatedTestSuite diff --git a/tests/PackageTests/TestSuiteExeV10/Check.hs b/tests/PackageTests/TestSuiteExeV10/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestSuiteExeV10/Check.hs @@ -0,0 +1,47 @@ +module PackageTests.TestSuiteExeV10.Check + ( checkTest + , checkTestWithHpc + ) where + +import Distribution.PackageDescription ( TestSuite(..), emptyTestSuite ) +import Distribution.Simple.Hpc +import Distribution.Version +import Test.HUnit +import System.Directory +import System.FilePath +import PackageTests.PackageTester + +dir :: FilePath +dir = "PackageTests" "TestSuiteExeV10" + +checkTest :: Version -> Test +checkTest cabalVersion = TestCase $ do + let spec = PackageSpec dir ["--enable-tests"] + buildResult <- cabal_build spec + let buildMessage = "\'setup build\' should succeed" + assertEqual buildMessage True $ successful buildResult + testResult <- cabal_test spec + let testMessage = "\'setup test\' should succeed" + assertEqual testMessage True $ successful testResult + +checkTestWithHpc :: Version -> Test +checkTestWithHpc cabalVersion = TestCase $ do + let spec = PackageSpec dir [ "--enable-tests" + , "--enable-library-coverage" + ] + buildResult <- cabal_build spec + let buildMessage = "\'setup build\' should succeed" + assertEqual buildMessage True $ successful buildResult + testResult <- cabal_test spec + let testMessage = "\'setup test\' should succeed" + assertEqual testMessage True $ successful testResult + let dummy = emptyTestSuite { testName = "test-Foo" } + tixFile = tixFilePath (dir "dist") dummy + tixFileMessage = ".tix file should exist" + markupDir = tixDir (dir "dist") dummy + markupFile = markupDir "hpc_index" <.> "html" + markupFileMessage = "HPC markup file should exist" + tixFileExists <- doesFileExist tixFile + assertEqual tixFileMessage True tixFileExists + markupFileExists <- doesFileExist markupFile + assertEqual markupFileMessage True markupFileExists diff --git a/tests/suite.hs b/tests/suite.hs new file mode 100644 --- /dev/null +++ b/tests/suite.hs @@ -0,0 +1,66 @@ +-- The intention is that this will be the new unit test framework. +-- Please add any working tests here. This file should do nothing +-- but import tests from other modules. +-- +-- Stephen Blackheath, 2009 + +module Main where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import qualified Test.HUnit as HUnit +import PackageTests.BuildDeps.SameDepsAllRound.Check +import PackageTests.BuildDeps.TargetSpecificDeps1.Check +import PackageTests.BuildDeps.TargetSpecificDeps1.Check +import PackageTests.BuildDeps.TargetSpecificDeps2.Check +import PackageTests.BuildDeps.TargetSpecificDeps3.Check +import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check +import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check +import PackageTests.BuildDeps.InternalLibrary0.Check +import PackageTests.BuildDeps.InternalLibrary1.Check +import PackageTests.BuildDeps.InternalLibrary2.Check +import PackageTests.BuildDeps.InternalLibrary3.Check +import PackageTests.BuildDeps.InternalLibrary4.Check +import PackageTests.TestStanza.Check +import PackageTests.TestSuiteExeV10.Check +import Distribution.Text (display) +import Distribution.Simple.Utils (cabalVersion) +import Data.Version +import System.Directory + +hunit :: TestName -> HUnit.Test -> Test +hunit name test = testGroup name $ hUnitTestToTests test + +tests :: Version -> [Test] +tests cabalVersion = [ + hunit "PackageTests/BuildDeps/SameDepsAllRound/" PackageTests.BuildDeps.SameDepsAllRound.Check.suite, + hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check.suite, + hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary0/" (PackageTests.BuildDeps.InternalLibrary0.Check.suite cabalVersion), + hunit "PackageTests/TestStanza/" (PackageTests.TestStanza.Check.suite cabalVersion), + -- ^ The Test stanza test will eventually be required + -- only for higher versions. + hunit "PackageTests/TestSuiteExeV10/Test" + (PackageTests.TestSuiteExeV10.Check.checkTest cabalVersion), + hunit "PackageTests/TestSuiteExeV10/TestWithHpc" + (PackageTests.TestSuiteExeV10.Check.checkTestWithHpc cabalVersion) + ] ++ + -- These tests are only required to pass on cabal version >= 1.7 + (if cabalVersion >= Version [1, 7] [] + then [ + hunit "PackageTests/BuildDeps/TargetSpecificDeps1/" PackageTests.BuildDeps.TargetSpecificDeps1.Check.suite, + hunit "PackageTests/BuildDeps/TargetSpecificDeps2/" PackageTests.BuildDeps.TargetSpecificDeps2.Check.suite, + hunit "PackageTests/BuildDeps/TargetSpecificDeps3/" PackageTests.BuildDeps.TargetSpecificDeps3.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary1/" PackageTests.BuildDeps.InternalLibrary1.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary2/" PackageTests.BuildDeps.InternalLibrary2.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary3/" PackageTests.BuildDeps.InternalLibrary3.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary4/" PackageTests.BuildDeps.InternalLibrary4.Check.suite + ] + else []) + +main = do + putStrLn $ "Cabal test suite - testing cabal version "++display cabalVersion + setCurrentDirectory "tests" + defaultMain (tests cabalVersion) +